steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Rewriting method dispatch to support inheritance

db4
Slava Pestov 2008-04-02 00:28:07 -05:00
parent a2971bd3be
commit fa8b578370
22 changed files with 573 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/bootstrap/layouts/layouts.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays
float-arrays quotations assocs layouts classes.tuple.private ;
float-arrays quotations assocs layouts classes.tuple.private
kernel.private ;
BIN: 111 tag-mask set
8 num-tags set
@ -15,6 +16,7 @@ H{
{ bignum BIN: 001 }
{ tuple BIN: 010 }
{ object BIN: 011 }
{ hi-tag BIN: 011 }
{ ratio BIN: 100 }
{ float BIN: 101 }
{ complex BIN: 110 }

23
core/bootstrap/primitives.factor
View File

@ -101,17 +101,24 @@ num-types get f <array> builtins set
} [ create-vocab drop ] each
! Builtin classes
: builtin-predicate-quot ( class -- quot )
: lo-tag-eq-quot ( n -- quot )
[ \ tag , , \ eq? , ] [ ] make ;
: hi-tag-eq-quot ( n -- quot )
[
"type" word-prop
[ tag-mask get < \ tag \ type ? , ] [ , ] bi
\ eq? ,
[ dup tag ] % \ hi-tag tag-number , \ eq? ,
[ [ hi-tag ] % , \ eq? , ] [ ] make ,
[ drop f ] ,
\ if ,
] [ ] make ;
: builtin-predicate-quot ( class -- quot )
"type" word-prop
dup tag-mask get <
[ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
: define-builtin-predicate ( class -- )
[ dup builtin-predicate-quot define-predicate ]
[ predicate-word make-inline ]
bi ;
dup builtin-predicate-quot define-predicate ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
@ -363,7 +370,7 @@ define-class
f builtins get [ ] subset union-class define-class
! Class of objects with object tag
"hi-tag" "classes.private" create
"hi-tag" "kernel.private" create
f builtins get num-tags get tail union-class define-class
! Null class with no instances.

6
core/classes/classes.factor
View File

@ -124,6 +124,8 @@ GENERIC: update-methods ( assoc -- )
] bi
] 2tri ;
GENERIC: class ( object -- class ) inline
GENERIC: class ( object -- class )
M: object class type type>class ;
M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;

8
core/combinators/combinators.factor
View File

@ -9,24 +9,24 @@ hashtables sorting ;
[ call ] with each ;
: cleave>quot ( seq -- quot )
[ [ keep ] curry ] map concat [ drop ] append ;
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
: 2cleave ( x seq -- )
[ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
[ [ 2keep ] curry ] map concat [ 2drop ] append ;
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
: 3cleave ( x seq -- )
[ 3keep ] each 3drop ;
: 3cleave>quot ( seq -- quot )
[ [ 3keep ] curry ] map concat [ 3drop ] append ;
[ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
: spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi
append ;
append [ ] like ;
: spread ( objs... seq -- )
spread>quot call ;

8
core/compiler/tests/intrinsics.factor
View File

@ -174,11 +174,6 @@ sequences.private ;
[ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
[ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
[ t ] [ f type f [ type ] compile-call eq? ] unit-test
[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
@ -223,9 +218,6 @@ sequences.private ;
[ t ] [ f [ f eq? ] compile-call ] unit-test
! regression
[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test
! regression
[ 3 ] [
100001 f <array> 3 100000 pick set-nth

4
core/compiler/tests/templates.factor
View File

@ -26,10 +26,6 @@ IN: compiler.tests
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test
[ { 1 2 3 } { 1 4 3 } 8 8 ]
[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ]
unit-test
! Test literals in either side of a shuffle
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test

52
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics
{ +output+ { "in" } }
} define-intrinsic
\ type [
"end" define-label
! Make a copy
"x" operand "obj" operand MOV
! Get the tag
"x" operand tag-mask get AND
! Tag the tag
"x" operand %tag-fixnum
! Compare with object tag number (3).
"x" operand object tag-number tag-fixnum CMP
"end" get JNE
! If we have equality, load type from header
"x" operand "obj" operand -3 [+] MOV
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
\ class-hash [
"end" define-label
"tuple" define-label
"object" define-label
! Make a copy
"x" operand "obj" operand MOV
! Get the tag
"x" operand tag-mask get AND
! Tag the tag
"x" operand %tag-fixnum
! Compare with tuple tag number (2).
"x" operand tuple tag-number tag-fixnum CMP
"tuple" get JE
! Compare with object tag number (3).
"x" operand object tag-number tag-fixnum CMP
"object" get JE
"end" get JMP
"object" get resolve-label
! Load header type
"x" operand "obj" operand header-offset [+] MOV
"end" get JMP
"tuple" get resolve-label
! Load class hash
"x" operand "obj" operand tuple-class-offset [+] MOV
"x" operand dup class-hash-offset [+] MOV
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
! Slots
: %slot-literal-known-tag
"obj" operand

8
core/generic/generic.factor
View File

@ -37,10 +37,12 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
: sort-methods ( assoc -- assoc' )
[ keys sort-classes ]
[ [ dupd at ] curry ] bi { } map>assoc ;
: methods ( word -- assoc )
"methods" word-prop
[ keys sort-classes ] keep
[ dupd at ] curry { } map>assoc ;
"methods" word-prop sort-methods ;
TUPLE: check-method class generic ;

49
core/generic/standard/engines/engines.factor Normal file
View File

@ -0,0 +1,49 @@
USING: assocs kernel namespaces quotations generic math
sequences combinators words classes.algebra ;
IN: generic.standard.engines
SYMBOL: default
SYMBOL: assumed
GENERIC: engine>quot ( engine -- quot )
M: quotation engine>quot ;
M: method-body engine>quot 1quotation ;
: engines>quots ( assoc -- assoc' )
[ engine>quot ] assoc-map ;
: engines>quots* ( assoc -- assoc' )
[ over assumed [ engine>quot ] with-variable ] assoc-map ;
: if-small? ( assoc true false -- )
>r >r dup assoc-size 4 <= r> r> if ; inline
: linear-dispatch-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
alist>quot ;
: split-methods ( assoc class -- first second )
[ [ nip class< not ] curry assoc-subset ]
[ [ nip class< ] curry assoc-subset ] 2bi ;
: convert-methods ( assoc class word -- assoc' )
over >r >r split-methods dup assoc-empty? [
r> r> 3drop
] [
r> execute r> pick set-at
] if ; inline
SYMBOL: (dispatch#)
: (picker) ( n -- quot )
{
{ 0 [ [ dup ] ] }
{ 1 [ [ over ] ] }
{ 2 [ [ pick ] ] }
[ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
} case ;
: picker ( -- quot ) \ (dispatch#) get (picker) ;

28
core/generic/standard/engines/predicate/predicate.factor Normal file
View File

@ -0,0 +1,28 @@
USING: generic.standard.engines generic namespaces kernel
sequences classes.algebra accessors words combinators
assocs ;
IN: generic.standard.engines.predicate
TUPLE: predicate-dispatch-engine methods ;
C: <predicate-dispatch-engine> predicate-dispatch-engine
: class-predicates ( assoc -- assoc )
[ >r "predicate" word-prop picker prepend r> ] assoc-map ;
: keep-going? ( assoc -- ? )
assumed get swap second first class< ;
: prune-redundant-predicates ( assoc -- default assoc' )
{
{ [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
{ [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
} cond ;
M: predicate-dispatch-engine engine>quot
methods>> clone
default get object bootstrap-word pick set-at engines>quots
sort-methods prune-redundant-predicates
class-predicates alist>quot ;

48
core/generic/standard/engines/tag/tag.factor Normal file
View File

@ -0,0 +1,48 @@
USING: classes.private generic.standard.engines namespaces
arrays mirrors assocs sequences.private quotations
kernel.private layouts math slots.private math.private
kernel accessors ;
IN: generic.standard.engines.tag
TUPLE: lo-tag-dispatch-engine methods ;
C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
TUPLE: hi-tag-dispatch-engine methods ;
C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
: convert-hi-tag-methods ( assoc -- assoc' )
hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
: direct-dispatch-quot ( alist n -- quot )
default get <array>
[ <enum> swap update ] keep
[ dispatch ] curry >quotation ;
M: lo-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r tag-number r> ] assoc-map
[
picker % [ tag ] % [
linear-dispatch-quot
] [
num-tags get direct-dispatch-quot
] if-small? %
] [ ] make ;
: num-hi-tags num-types get num-tags get - ;
: hi-tag-number type-number num-tags get - ;
: hi-tag-quot ( -- quot )
[ 0 slot ] num-tags get [ fixnum- ] curry compose ;
M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
[
picker % hi-tag-quot % [
linear-dispatch-quot
] [
num-hi-tags direct-dispatch-quot
] if-small? %
] [ ] make ;

109
core/generic/standard/engines/tuple/tuple.factor Normal file
View File

@ -0,0 +1,109 @@
IN: generic.standard.engines.tuple
USING: kernel classes.tuple.private hashtables assocs sorting
accessors combinators sequences slots.private math.parser words
effects namespaces generic generic.standard.engines
classes.algebra math math.private quotations ;
TUPLE: echelon-dispatch-engine n methods ;
C: <echelon-dispatch-engine> echelon-dispatch-engine
TUPLE: trivial-tuple-dispatch-engine methods ;
C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
TUPLE: tuple-dispatch-engine echelons ;
: push-echelon ( class method assoc -- )
>r swap dup tuple-layout layout-echelon r>
[ ?set-at ] change-at ;
: echelon-sort ( assoc -- assoc' )
V{ } clone [
[
push-echelon
] curry assoc-each
] keep sort-keys ;
: <tuple-dispatch-engine> ( methods -- engine )
echelon-sort
[ dupd <echelon-dispatch-engine> ] assoc-map
\ tuple-dispatch-engine construct-boa ;
: convert-tuple-methods ( assoc -- assoc' )
tuple \ <tuple-dispatch-engine> convert-methods ;
M: trivial-tuple-dispatch-engine engine>quot
methods>> engines>quots* linear-dispatch-quot ;
: hash-methods ( methods -- buckets )
>alist V{ } clone [ class-hashes ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
: class-hash-dispatch-quot ( methods -- quot )
#! 1 slot == word hashcode
[
[ dup 1 slot ] %
hash-methods [ engine>quot ] map hash-dispatch-quot %
] [ ] make ;
: tuple-dispatch-engine-word-name ( engine -- string )
[
generic get word-name %
"/tuple-dispatch-engine/" %
n>> #
] "" make ;
PREDICATE: tuple-dispatch-engine-word < word
"tuple-dispatch-engine" word-prop ;
M: tuple-dispatch-engine-word stack-effect
"tuple-dispatch-generic" word-prop stack-effect ;
: <tuple-dispatch-engine-word> ( engine -- word )
tuple-dispatch-engine-word-name f <word>
[ t "tuple-dispatch-engine" set-word-prop ]
[ generic get "tuple-dispatch-generic" set-word-prop ]
[ ]
tri ;
: define-tuple-dispatch-engine-word ( engine quot -- word )
>r <tuple-dispatch-engine-word> dup r> define ;
: tuple-dispatch-engine-body ( engine -- quot )
#! 1 slot == tuple-layout
#! 2 slot == 0 array-nth
#! 4 slot == layout-superclasses
[
picker %
[ 1 slot 4 slot ] %
[ n>> 2 + , [ slot ] % ]
[
methods>> [
<trivial-tuple-dispatch-engine> engine>quot
] [
class-hash-dispatch-quot
] if-small? %
] bi
] [ ] make ;
M: echelon-dispatch-engine engine>quot
dup tuple-dispatch-engine-body
define-tuple-dispatch-engine-word
1quotation ;
: >=-case-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
alist>quot ;
M: tuple-dispatch-engine engine>quot
#! 1 slot == tuple-layout
#! 5 slot == layout-echelon
[
picker %
[ 1 slot 5 slot ] %
echelons>>
[ [ engine>quot dup default set ] assoc-map ] with-scope
>=-case-quot %
] [ ] make ;

141
core/generic/standard/new/new-tests.factor Normal file
View File

@ -0,0 +1,141 @@
IN: generic.standard.new.tests
USING: tools.test math math.functions math.constants
generic.standard.new strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser ;
<< : GENERIC: CREATE-GENERIC define-simple-generic ; parsing >>
GENERIC: lo-tag-test
M: integer lo-tag-test 3 + ;
M: float lo-tag-test 4 - ;
M: rational lo-tag-test 2 - ;
M: complex lo-tag-test sq ;
[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
GENERIC: hi-tag-test
M: string hi-tag-test ", in bed" append ;
M: number hi-tag-test 3 + ;
M: array hi-tag-test [ hi-tag-test ] map ;
M: sequence hi-tag-test reverse ;
[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
TUPLE: shape ;
TUPLE: abstract-rectangle < shape width height ;
TUPLE: rectangle < abstract-rectangle ;
C: <rectangle> rectangle
TUPLE: parallelogram < abstract-rectangle skew ;
C: <parallelogram> parallelogram
TUPLE: circle < shape radius ;
C: <circle> circle
GENERIC: area
M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
M: circle area radius>> sq pi * ;
[ 12 ] [ 4 3 <rectangle> area ] unit-test
[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
[ t ] [ 2 <circle> area 4 pi * = ] unit-test
GENERIC: perimiter
: rectangle-perimiter + 2 * ;
M: rectangle perimiter
[ width>> ] [ height>> ] bi
rectangle-perimiter ;
: hypotenuse [ sq ] bi@ + sqrt ;
M: parallelogram perimiter
[ width>> ]
[ [ height>> ] [ skew>> ] bi hypotenuse ] bi
rectangle-perimiter ;
M: circle perimiter 2 * pi * ;
[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
GENERIC: big-mix-test
M: object big-mix-test drop "object" ;
M: tuple big-mix-test drop "tuple" ;
M: integer big-mix-test drop "integer" ;
M: float big-mix-test drop "float" ;
M: complex big-mix-test drop "complex" ;
M: string big-mix-test drop "string" ;
M: array big-mix-test drop "array" ;
M: sequence big-mix-test drop "sequence" ;
M: rectangle big-mix-test drop "rectangle" ;
M: parallelogram big-mix-test drop "parallelogram" ;
M: circle big-mix-test drop "circle" ;
[ "integer" ] [ 3 big-mix-test ] unit-test
[ "float" ] [ 5.0 big-mix-test ] unit-test
[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
[ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test
[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
[ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test
[ "string" ] [ "hello" big-mix-test ] unit-test
[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
[ "tuple" ] [ H{ } big-mix-test ] unit-test
[ "object" ] [ \ + big-mix-test ] unit-test
GENERIC: small-lo-tag
M: fixnum small-lo-tag drop "fixnum" ;
M: string small-lo-tag drop "string" ;
M: array small-lo-tag drop "array" ;
M: float-array small-lo-tag drop "float-array" ;
M: byte-array small-lo-tag drop "byte-array" ;
[ "fixnum" ] [ 3 small-lo-tag ] unit-test
[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test

139
core/generic/standard/new/new.factor Normal file
View File

@ -0,0 +1,139 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions
hashtables layouts combinators sequences.private generic
classes classes.algebra classes.private generic.standard.engines
generic.standard.engines.tag generic.standard.engines.predicate
generic.standard.engines.tuple accessors ;
IN: generic.standard.new
: unpickers
{
[ nip ]
[ >r nip r> swap ]
[ >r >r nip r> r> -rot ]
} ; inline
: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
ERROR: no-method object generic ;
: error-method ( word -- quot )
picker swap [ no-method ] curry append ;
: empty-method ( word -- quot )
[
picker % [ delegate dup ] %
unpicker over suffix ,
error-method \ drop prefix , \ if ,
] [ ] make ;
: default-method ( word -- pair )
"default-method" word-prop
object bootstrap-word swap 2array ;
: push-method ( method specializer atomic assoc -- )
[
[ H{ } clone <predicate-dispatch-engine> ] unless*
[ methods>> set-at ] keep
] change-at ;
: flatten-method ( class method assoc -- )
>r >r dup flatten-class keys swap r> r> [
>r spin r> push-method
] 3curry each ;
: flatten-methods ( assoc -- assoc' )
H{ } clone [
[
flatten-method
] curry assoc-each
] keep ;
: <big-dispatch-engine> ( assoc -- engine )
flatten-methods
convert-tuple-methods
convert-hi-tag-methods
<lo-tag-dispatch-engine> ;
: find-default ( methods -- quot )
#! Side-effects methods.
object swap delete-at* [
drop generic get "default-method" word-prop
] unless 1quotation ;
GENERIC: mangle-method ( method generic -- quot )
: single-combination ( words -- quot )
[
object bootstrap-word assumed set
[ generic set ]
[
"methods" word-prop
[ generic get mangle-method ] assoc-map
[ find-default default set ]
[
generic get "inline" word-prop [
<predicate-dispatch-engine>
] [
<big-dispatch-engine>
] if
] bi
engine>quot
] bi
] with-scope ;
TUPLE: standard-combination # ;
C: <standard-combination> standard-combination
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
PREDICATE: simple-generic < standard-generic
"combination" word-prop #>> zero? ;
: define-simple-generic ( word -- )
T{ standard-combination f 0 } define-generic ;
: with-standard ( combination quot -- quot' )
>r #>> (dispatch#) r> with-variable ;
M: standard-combination make-default-method
[ empty-method ] with-standard ;
M: standard-combination perform-combination
[ single-combination ] with-standard ;
TUPLE: hook-combination var ;
C: <hook-combination> hook-combination
PREDICATE: hook-generic < generic
"combination" word-prop hook-combination? ;
: with-hook ( combination quot -- quot' )
0 (dispatch#) [
dip var>> [ get ] curry prepend
] with-variable ; inline
M: hook-combination make-default-method
[ error-method ] with-hook ;
M: hook-combination perform-combination
[ single-combination ] with-hook ;
GENERIC: dispatch# ( word -- n )
M: word dispatch# "combination" word-prop dispatch# ;
M: standard-combination dispatch# #>> ;
M: hook-combination dispatch# drop 0 ;
M: simple-generic definer drop \ GENERIC: f ;
M: standard-generic definer drop \ GENERIC# f ;
M: hook-generic definer drop \ HOOK: f ;

24
core/generic/standard/standard.factor
View File

@ -41,23 +41,13 @@ ERROR: no-method object generic ;
: class-predicates ( assoc -- assoc )
[ >r "predicate" word-prop picker prepend r> ] assoc-map ;
: (simplify-alist) ( class i assoc -- default assoc )
2dup length 1- = [
nth second { } rot drop
] [
3dup >r 1+ r> nth first class< [
>r 1+ r> (simplify-alist)
] [
[ nth second ] 2keep swap 1+ tail rot drop
] if
] if ;
: simplify-alist ( class assoc -- default assoc )
dup empty? [
2drop [ "Unreachable" throw ] { }
] [
0 swap (simplify-alist)
] if ;
: simplify-alist ( class assoc -- default assoc' )
{
{ [ dup empty? ] [ 2drop [ "Unreachable" throw ] { } ] }
{ [ dup length 1 = ] [ nip first second { } ] }
{ [ 2dup second first class< ] [ 1 tail-slice simplify-alist ] }
{ [ t ] [ nip [ first second ] [ 1 tail-slice ] bi ] }
} cond ;
: default-method ( word -- pair )
"default-method" word-prop

15
core/inference/backend/backend.factor
View File

@ -3,14 +3,23 @@
USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors ;
continuations debugger assocs combinators compiler.errors
generic.standard.engines.tuple ;
IN: inference.backend
: recursive-label ( word -- label/f )
recursive-state get at ;
: inline? ( word -- ? )
dup "method-generic" word-prop swap or "inline" word-prop ;
GENERIC: inline? ( word -- ? )
M: method-body inline?
"method-generic" word-prop inline? ;
M: tuple-dispatch-engine-word inline?
"tuple-dispatch-generic" word-prop inline? ;
M: word inline?
"inline" word-prop ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys

2
core/inference/class/class-tests.factor
View File

@ -120,7 +120,7 @@ M: object xyz ;
[
[ no-cond ] 1
[ 1array dup quotation? [ >quotation ] unless ] times
] \ type inlined?
] \ quotation? inlined?
] unit-test
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test

3
core/inference/known-words/known-words.factor
View File

@ -383,9 +383,6 @@ set-primitive-effect
\ millis { } { integer } <effect> set-primitive-effect
\ millis make-flushable
\ type { object } { fixnum } <effect> set-primitive-effect
\ type make-foldable
\ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable

6
core/kernel/kernel-docs.factor
View File

@ -413,12 +413,6 @@ HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
HELP: type ( object -- n )
{ $values { "object" object } { "n" "a type number" } }
{ $description "Outputs an object's type number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
{ type tag type>class } related-words
HELP: ? ( ? true false -- true/false )
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;

10
core/kernel/kernel.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel.private ;
USING: kernel.private slots.private ;
IN: kernel
! Stack stuff
@ -99,14 +99,14 @@ DEFER: if
! Appliers
: bi@ ( x y quot -- )
tuck 2slip call ; inline
dup bi* ; inline
: tri@ ( x y z quot -- )
tuck >r bi@ r> call ; inline
dup dup tri* ; inline
! Double appliers
: 2bi@ ( w x y z quot -- )
dup -roll 3slip call ; inline
dup 2bi* ; inline
: while ( pred body tail -- )
>r >r dup slip r> r> roll
@ -194,6 +194,8 @@ GENERIC: construct-boa ( ... class -- tuple )
<PRIVATE
: hi-tag ( obj -- n ) 0 slot ;
: declare ( spec -- ) drop ;
: do-primitive ( number -- ) "Improper primitive call" throw ;

4
core/layouts/layouts-docs.factor
View File

@ -14,7 +14,7 @@ HELP: tag-mask
{ $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
HELP: num-types
{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link type } " primitive." } ;
{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
HELP: tag-number
{ $values { "class" class } { "n" "an integer or " { $link f } } }
@ -76,7 +76,7 @@ HELP: bootstrap-cell-bits
ARTICLE: "layouts-types" "Type numbers"
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
{ $subsection type }
{ $subsection hi-tag }
"Built-in type numbers can be converted to classes, and vice versa:"
{ $subsection type>class }
{ $subsection type-number }

23
core/optimizer/known-words/known-words.factor
View File

@ -87,29 +87,6 @@ sequences.private combinators ;
{ { @ @ } [ 2drop t ] }
} define-identities
! type applied to an object of a known type can be folded
: known-type? ( node -- ? )
node-class-first class-types length 1 number= ;
: fold-known-type ( node -- node )
dup node-class-first class-types inline-literals ;
\ type [
{ [ dup known-type? ] [ fold-known-type ] }
] define-optimizers
! if the result of type is n, then the object has type n
{ tag type } [
[
num-types get swap [
[
[ type>class object or 0 `input class, ] keep
0 `output literal,
] set-constraints
] curry each
] "constraints" set-word-prop
] each
! Specializers
{ 1+ 1- sq neg recip sgn } [
{ number } "specializer" set-word-prop