New generic word implementation reduces compile time
parent
d0e5b238e2
commit
dee25cda13
|
@ -203,7 +203,14 @@ M: f '
|
||||||
|
|
||||||
! Words
|
! Words
|
||||||
|
|
||||||
|
DEFER: emit-word
|
||||||
|
|
||||||
|
: emit-generic ( generic -- )
|
||||||
|
dup "default-method" word-prop method-word emit-word
|
||||||
|
"methods" word-prop [ nip method-word emit-word ] assoc-each ;
|
||||||
|
|
||||||
: emit-word ( word -- )
|
: emit-word ( word -- )
|
||||||
|
dup generic? [ dup emit-generic ] when
|
||||||
[
|
[
|
||||||
dup hashcode ' ,
|
dup hashcode ' ,
|
||||||
dup word-name ' ,
|
dup word-name ' ,
|
||||||
|
@ -224,7 +231,7 @@ M: f '
|
||||||
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
|
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
|
||||||
|
|
||||||
: transfer-word ( word -- word )
|
: transfer-word ( word -- word )
|
||||||
dup target-word [ ] [ word-name no-word ] ?if ;
|
dup target-word swap or ;
|
||||||
|
|
||||||
: fixup-word ( word -- offset )
|
: fixup-word ( word -- offset )
|
||||||
transfer-word dup objects get at
|
transfer-word dup objects get at
|
||||||
|
@ -285,17 +292,20 @@ M: float-array ' float-array emit-dummy-array ;
|
||||||
] emit-object ;
|
] emit-object ;
|
||||||
|
|
||||||
: emit-tuple ( obj -- pointer )
|
: emit-tuple ( obj -- pointer )
|
||||||
objects get [
|
[
|
||||||
[ tuple>array unclip transfer-word , % ] { } make
|
[ tuple>array unclip transfer-word , % ] { } make
|
||||||
tuple type-number dup emit-array
|
tuple type-number dup emit-array
|
||||||
] cache ; inline
|
]
|
||||||
|
! Hack
|
||||||
|
over class word-name "tombstone" =
|
||||||
|
[ objects get swap cache ] [ call ] if ;
|
||||||
|
|
||||||
M: tuple ' emit-tuple ;
|
M: tuple ' emit-tuple ;
|
||||||
|
|
||||||
M: tombstone '
|
M: tombstone '
|
||||||
delegate
|
delegate
|
||||||
"((tombstone))" "((empty))" ? "hashtables.private" lookup
|
"((tombstone))" "((empty))" ? "hashtables.private" lookup
|
||||||
word-def first emit-tuple ;
|
word-def first objects get [ emit-tuple ] cache ;
|
||||||
|
|
||||||
M: array '
|
M: array '
|
||||||
array type-number object tag-number emit-array ;
|
array type-number object tag-number emit-array ;
|
||||||
|
@ -313,41 +323,6 @@ M: quotation '
|
||||||
] emit-object
|
] emit-object
|
||||||
] cache ;
|
] cache ;
|
||||||
|
|
||||||
! Vectors and sbufs
|
|
||||||
|
|
||||||
M: vector '
|
|
||||||
dup length swap underlying '
|
|
||||||
tuple type-number tuple tag-number [
|
|
||||||
4 emit-fixnum
|
|
||||||
vector ' emit
|
|
||||||
f ' emit
|
|
||||||
emit ! array ptr
|
|
||||||
emit-fixnum ! length
|
|
||||||
] emit-object ;
|
|
||||||
|
|
||||||
M: sbuf '
|
|
||||||
dup length swap underlying '
|
|
||||||
tuple type-number tuple tag-number [
|
|
||||||
4 emit-fixnum
|
|
||||||
sbuf ' emit
|
|
||||||
f ' emit
|
|
||||||
emit ! array ptr
|
|
||||||
emit-fixnum ! length
|
|
||||||
] emit-object ;
|
|
||||||
|
|
||||||
! Hashes
|
|
||||||
|
|
||||||
M: hashtable '
|
|
||||||
[ hash-array ' ] keep
|
|
||||||
tuple type-number tuple tag-number [
|
|
||||||
5 emit-fixnum
|
|
||||||
hashtable ' emit
|
|
||||||
f ' emit
|
|
||||||
dup hash-count emit-fixnum
|
|
||||||
hash-deleted emit-fixnum
|
|
||||||
emit ! array ptr
|
|
||||||
] emit-object ;
|
|
||||||
|
|
||||||
! Curries
|
! Curries
|
||||||
|
|
||||||
M: curry '
|
M: curry '
|
||||||
|
|
|
@ -118,11 +118,11 @@ H{ } clone update-map set
|
||||||
H{ } clone typemap set
|
H{ } clone typemap set
|
||||||
num-types get f <array> builtins set
|
num-types get f <array> builtins set
|
||||||
|
|
||||||
! These symbols are needed by the code that executes below
|
! Forward definitions
|
||||||
{
|
"object" "kernel" create t "class" set-word-prop
|
||||||
{ "object" "kernel" }
|
"object" "kernel" create union-class "metaclass" set-word-prop
|
||||||
{ "null" "kernel" }
|
|
||||||
} [ create drop ] assoc-each
|
"null" "kernel" create drop
|
||||||
|
|
||||||
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
|
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
|
||||||
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
|
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
|
||||||
|
|
|
@ -32,6 +32,7 @@ vocabs.loader system ;
|
||||||
|
|
||||||
"io.streams.c" require
|
"io.streams.c" require
|
||||||
"vocabs.loader" require
|
"vocabs.loader" require
|
||||||
|
|
||||||
"syntax" require
|
"syntax" require
|
||||||
"bootstrap.layouts" require
|
"bootstrap.layouts" require
|
||||||
|
|
||||||
|
|
|
@ -15,7 +15,7 @@ IN: bootstrap.stage2
|
||||||
vm file-name windows? [ "." split1 drop ] when
|
vm file-name windows? [ "." split1 drop ] when
|
||||||
".image" append "output-image" set-global
|
".image" append "output-image" set-global
|
||||||
|
|
||||||
"math tools help compiler ui ui.tools io" "include" set-global
|
"math help compiler tools ui ui.tools io" "include" set-global
|
||||||
"" "exclude" set-global
|
"" "exclude" set-global
|
||||||
|
|
||||||
parse-command-line
|
parse-command-line
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
! Copyright (C) 2004, 2007 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: classes
|
IN: classes
|
||||||
USING: arrays definitions assocs kernel
|
USING: arrays definitions assocs kernel
|
||||||
|
|
|
@ -1,19 +1,34 @@
|
||||||
! Copyright (C) 2004, 2007 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: words sequences kernel assocs combinators classes
|
USING: words sequences kernel assocs combinators classes
|
||||||
generic.standard namespaces arrays ;
|
generic.standard namespaces arrays math quotations ;
|
||||||
IN: classes.union
|
IN: classes.union
|
||||||
|
|
||||||
PREDICATE: class union-class
|
PREDICATE: class union-class
|
||||||
"metaclass" word-prop union-class eq? ;
|
"metaclass" word-prop union-class eq? ;
|
||||||
|
|
||||||
! Union classes for dispatch on multiple classes.
|
! Union classes for dispatch on multiple classes.
|
||||||
|
: small-union-predicate-quot ( members -- quot )
|
||||||
|
dup empty? [
|
||||||
|
drop [ drop f ]
|
||||||
|
] [
|
||||||
|
unclip first "predicate" word-prop swap
|
||||||
|
[ >r "predicate" word-prop [ dup ] swap append r> ]
|
||||||
|
assoc-map alist>quot
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: big-union-predicate-quot ( members -- quot )
|
||||||
|
[ small-union-predicate-quot ] [ dup ]
|
||||||
|
class-hash-dispatch-quot ;
|
||||||
|
|
||||||
: union-predicate-quot ( members -- quot )
|
: union-predicate-quot ( members -- quot )
|
||||||
0 (dispatch#) [
|
[ [ drop t ] ] { } map>assoc
|
||||||
[ [ drop t ] ] { } map>assoc
|
dup length 4 <= [
|
||||||
object bootstrap-word [ drop f ] 2array add*
|
small-union-predicate-quot
|
||||||
single-combination
|
] [
|
||||||
] with-variable ;
|
flatten-methods
|
||||||
|
big-union-predicate-quot
|
||||||
|
] if ;
|
||||||
|
|
||||||
: define-union-predicate ( class -- )
|
: define-union-predicate ( class -- )
|
||||||
dup predicate-word
|
dup predicate-word
|
||||||
|
|
|
@ -26,7 +26,7 @@ IN: compiler
|
||||||
>r dupd save-effect r>
|
>r dupd save-effect r>
|
||||||
f pick compiler-error
|
f pick compiler-error
|
||||||
over compiled-unxref
|
over compiled-unxref
|
||||||
over word-vocabulary [ compiled-xref ] [ 2drop ] if ;
|
compiled-xref ;
|
||||||
|
|
||||||
: compile-succeeded ( word -- effect dependencies )
|
: compile-succeeded ( word -- effect dependencies )
|
||||||
[
|
[
|
||||||
|
|
|
@ -42,12 +42,16 @@ M: integer (stack-picture) drop "object" ;
|
||||||
] "" make ;
|
] "" make ;
|
||||||
|
|
||||||
: stack-effect ( word -- effect/f )
|
: stack-effect ( word -- effect/f )
|
||||||
dup symbol? [
|
{
|
||||||
drop 0 1 <effect>
|
{ [ dup symbol? ] [ drop 0 1 <effect> ] }
|
||||||
] [
|
{ [ dup "parent-generic" word-prop ] [
|
||||||
{ "declared-effect" "inferred-effect" }
|
"parent-generic" word-prop stack-effect
|
||||||
swap word-props [ at ] curry map [ ] find nip
|
] }
|
||||||
] if ;
|
{ [ t ] [
|
||||||
|
{ "declared-effect" "inferred-effect" }
|
||||||
|
swap word-props [ at ] curry map [ ] find nip
|
||||||
|
] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
M: effect clone
|
M: effect clone
|
||||||
[ effect-in clone ] keep effect-out clone <effect> ;
|
[ effect-in clone ] keep effect-out clone <effect> ;
|
||||||
|
|
|
@ -154,9 +154,17 @@ M: #if generate-node
|
||||||
] generate-1
|
] generate-1
|
||||||
] keep ;
|
] keep ;
|
||||||
|
|
||||||
|
: tail-dispatch? ( node -- ? )
|
||||||
|
#! Is the dispatch a jump to a tail call to a word?
|
||||||
|
dup #call? swap node-successor #return? and ;
|
||||||
|
|
||||||
: dispatch-branches ( node -- )
|
: dispatch-branches ( node -- )
|
||||||
node-children [
|
node-children [
|
||||||
compiling-word get dispatch-branch %dispatch-label
|
dup tail-dispatch? [
|
||||||
|
node-param
|
||||||
|
] [
|
||||||
|
compiling-word get dispatch-branch
|
||||||
|
] if %dispatch-label
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
M: #dispatch generate-node
|
M: #dispatch generate-node
|
||||||
|
|
|
@ -125,16 +125,12 @@ HELP: method
|
||||||
{ $description "Looks up a method definition." }
|
{ $description "Looks up a method definition." }
|
||||||
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
|
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
|
||||||
|
|
||||||
{ method method-def method-loc define-method POSTPONE: M: } related-words
|
{ method define-method POSTPONE: M: } related-words
|
||||||
|
|
||||||
HELP: <method>
|
HELP: <method>
|
||||||
{ $values { "def" "a quotation" } { "method" "a new method definition" } }
|
{ $values { "def" "a quotation" } { "method" "a new method definition" } }
|
||||||
{ $description "Creates a new "{ $link method } " instance." } ;
|
{ $description "Creates a new "{ $link method } " instance." } ;
|
||||||
|
|
||||||
HELP: sort-methods
|
|
||||||
{ $values { "assoc" "an assoc mapping classes to methods" } { "newassoc" "an association list mapping classes to quotations" } }
|
|
||||||
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
|
|
||||||
|
|
||||||
HELP: methods
|
HELP: methods
|
||||||
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
|
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
|
||||||
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
|
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
|
||||||
|
|
|
@ -5,12 +5,7 @@ definitions kernel.private classes classes.private
|
||||||
quotations arrays vocabs ;
|
quotations arrays vocabs ;
|
||||||
IN: generic
|
IN: generic
|
||||||
|
|
||||||
PREDICATE: word generic "combination" word-prop >boolean ;
|
! Method combination protocol
|
||||||
|
|
||||||
M: generic definer drop f f ;
|
|
||||||
|
|
||||||
M: generic definition drop f ;
|
|
||||||
|
|
||||||
GENERIC: perform-combination ( word combination -- quot )
|
GENERIC: perform-combination ( word combination -- quot )
|
||||||
|
|
||||||
M: object perform-combination
|
M: object perform-combination
|
||||||
|
@ -22,22 +17,22 @@ M: object perform-combination
|
||||||
#! the method will throw an error. We don't want that.
|
#! the method will throw an error. We don't want that.
|
||||||
nip [ "Invalid method combination" throw ] curry [ ] like ;
|
nip [ "Invalid method combination" throw ] curry [ ] like ;
|
||||||
|
|
||||||
|
GENERIC: method-prologue ( class combination -- quot )
|
||||||
|
|
||||||
|
M: object method-prologue 2drop [ ] ;
|
||||||
|
|
||||||
|
GENERIC: make-default-method ( generic combination -- method )
|
||||||
|
|
||||||
|
PREDICATE: word generic "combination" word-prop >boolean ;
|
||||||
|
|
||||||
|
M: generic definer drop f f ;
|
||||||
|
|
||||||
|
M: generic definition drop f ;
|
||||||
|
|
||||||
: make-generic ( word -- )
|
: make-generic ( word -- )
|
||||||
dup dup "combination" word-prop perform-combination define ;
|
dup dup "combination" word-prop perform-combination define ;
|
||||||
|
|
||||||
: init-methods ( word -- )
|
TUPLE: method word def specializer generic loc ;
|
||||||
dup "methods" word-prop
|
|
||||||
H{ } assoc-like
|
|
||||||
"methods" set-word-prop ;
|
|
||||||
|
|
||||||
: define-generic ( word combination -- )
|
|
||||||
dupd "combination" set-word-prop
|
|
||||||
dup init-methods make-generic ;
|
|
||||||
|
|
||||||
TUPLE: method loc def ;
|
|
||||||
|
|
||||||
: <method> ( def -- method )
|
|
||||||
{ set-method-def } \ method construct ;
|
|
||||||
|
|
||||||
: method ( class generic -- method/f )
|
: method ( class generic -- method/f )
|
||||||
"methods" word-prop at ;
|
"methods" word-prop at ;
|
||||||
|
@ -48,12 +43,10 @@ PREDICATE: pair method-spec
|
||||||
: order ( generic -- seq )
|
: order ( generic -- seq )
|
||||||
"methods" word-prop keys sort-classes ;
|
"methods" word-prop keys sort-classes ;
|
||||||
|
|
||||||
: sort-methods ( assoc -- newassoc )
|
|
||||||
[ keys sort-classes ] keep
|
|
||||||
[ dupd at method-def ] curry { } map>assoc ;
|
|
||||||
|
|
||||||
: methods ( word -- assoc )
|
: methods ( word -- assoc )
|
||||||
"methods" word-prop sort-methods ;
|
"methods" word-prop
|
||||||
|
[ keys sort-classes ] keep
|
||||||
|
[ dupd at method-word ] curry { } map>assoc ;
|
||||||
|
|
||||||
TUPLE: check-method class generic ;
|
TUPLE: check-method class generic ;
|
||||||
|
|
||||||
|
@ -66,10 +59,31 @@ TUPLE: check-method class generic ;
|
||||||
swap [ "methods" word-prop swap call ] keep make-generic ;
|
swap [ "methods" word-prop swap call ] keep make-generic ;
|
||||||
inline
|
inline
|
||||||
|
|
||||||
: define-method ( method class generic -- )
|
: method-word-name ( class word -- string )
|
||||||
>r >r <method> r> bootstrap-word r> check-method
|
word-name "/" rot word-name 3append ;
|
||||||
|
|
||||||
|
: make-method-def ( quot word combination -- quot )
|
||||||
|
"combination" word-prop method-prologue swap append ;
|
||||||
|
|
||||||
|
: <method-word> ( quot class generic -- word )
|
||||||
|
[ make-method-def ] 2keep
|
||||||
|
[ method-word-name f <word> dup ] keep
|
||||||
|
"parent-generic" set-word-prop
|
||||||
|
dup rot define ;
|
||||||
|
|
||||||
|
: <method> ( quot class generic -- method )
|
||||||
|
check-method
|
||||||
|
[ <method-word> ] 3keep f \ method construct-boa ;
|
||||||
|
|
||||||
|
: define-method ( quot class generic -- )
|
||||||
|
>r bootstrap-word r>
|
||||||
|
[ <method> ] 2keep
|
||||||
[ set-at ] with-methods ;
|
[ set-at ] with-methods ;
|
||||||
|
|
||||||
|
: define-default-method ( generic combination -- )
|
||||||
|
dupd make-default-method object bootstrap-word pick <method>
|
||||||
|
"default-method" set-word-prop ;
|
||||||
|
|
||||||
! Definition protocol
|
! Definition protocol
|
||||||
M: method-spec where
|
M: method-spec where
|
||||||
dup first2 method [ method-loc ] [ second where ] ?if ;
|
dup first2 method [ method-loc ] [ second where ] ?if ;
|
||||||
|
@ -105,3 +119,14 @@ M: class forget* ( class -- )
|
||||||
|
|
||||||
M: assoc update-methods ( assoc -- )
|
M: assoc update-methods ( assoc -- )
|
||||||
implementors* [ make-generic ] each ;
|
implementors* [ make-generic ] each ;
|
||||||
|
|
||||||
|
: init-methods ( word -- )
|
||||||
|
dup "methods" word-prop
|
||||||
|
H{ } assoc-like
|
||||||
|
"methods" set-word-prop ;
|
||||||
|
|
||||||
|
: define-generic ( word combination -- )
|
||||||
|
2dup "combination" set-word-prop
|
||||||
|
dupd define-default-method
|
||||||
|
dup init-methods
|
||||||
|
make-generic ;
|
||||||
|
|
|
@ -38,9 +38,13 @@ TUPLE: no-math-method left right generic ;
|
||||||
: no-math-method ( left right generic -- * )
|
: no-math-method ( left right generic -- * )
|
||||||
\ no-math-method construct-boa throw ;
|
\ no-math-method construct-boa throw ;
|
||||||
|
|
||||||
|
: default-math-method ( generic -- quot )
|
||||||
|
[ no-math-method ] curry [ ] like ;
|
||||||
|
|
||||||
: applicable-method ( generic class -- quot )
|
: applicable-method ( generic class -- quot )
|
||||||
over method
|
over method
|
||||||
[ method-def ] [ [ no-math-method ] curry [ ] like ] ?if ;
|
[ method-word word-def ]
|
||||||
|
[ default-math-method ] ?if ;
|
||||||
|
|
||||||
: object-method ( generic -- quot )
|
: object-method ( generic -- quot )
|
||||||
object bootstrap-word applicable-method ;
|
object bootstrap-word applicable-method ;
|
||||||
|
@ -66,6 +70,9 @@ TUPLE: no-math-method left right generic ;
|
||||||
|
|
||||||
TUPLE: math-combination ;
|
TUPLE: math-combination ;
|
||||||
|
|
||||||
|
M: math-combination make-default-method
|
||||||
|
drop default-math-method ;
|
||||||
|
|
||||||
M: math-combination perform-combination
|
M: math-combination perform-combination
|
||||||
drop
|
drop
|
||||||
\ over [
|
\ over [
|
||||||
|
|
|
@ -8,6 +8,10 @@ IN: generic.standard
|
||||||
|
|
||||||
TUPLE: standard-combination # ;
|
TUPLE: standard-combination # ;
|
||||||
|
|
||||||
|
M: standard-combination method-prologue
|
||||||
|
standard-combination-# object
|
||||||
|
<array> swap add [ declare ] curry ;
|
||||||
|
|
||||||
C: <standard-combination> standard-combination
|
C: <standard-combination> standard-combination
|
||||||
|
|
||||||
SYMBOL: (dispatch#)
|
SYMBOL: (dispatch#)
|
||||||
|
@ -31,10 +35,10 @@ TUPLE: no-method object generic ;
|
||||||
: no-method ( object generic -- * )
|
: no-method ( object generic -- * )
|
||||||
\ no-method construct-boa throw ;
|
\ no-method construct-boa throw ;
|
||||||
|
|
||||||
: error-method ( word -- method )
|
: error-method ( word -- quot )
|
||||||
picker swap [ no-method ] curry append ;
|
picker swap [ no-method ] curry append ;
|
||||||
|
|
||||||
: empty-method ( word -- method )
|
: empty-method ( word -- quot )
|
||||||
[
|
[
|
||||||
picker % [ delegate dup ] %
|
picker % [ delegate dup ] %
|
||||||
unpicker over add ,
|
unpicker over add ,
|
||||||
|
@ -65,13 +69,15 @@ TUPLE: no-method object generic ;
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: default-method ( word -- pair )
|
: default-method ( word -- pair )
|
||||||
empty-method object bootstrap-word swap 2array ;
|
"default-method" word-prop method-word
|
||||||
|
object bootstrap-word swap 2array ;
|
||||||
|
|
||||||
: method-alist>quot ( alist base-class -- quot )
|
: method-alist>quot ( alist base-class -- quot )
|
||||||
bootstrap-word swap simplify-alist
|
bootstrap-word swap simplify-alist
|
||||||
class-predicates alist>quot ;
|
class-predicates alist>quot ;
|
||||||
|
|
||||||
: small-generic ( methods -- def )
|
: small-generic ( methods -- def )
|
||||||
|
[ 1quotation ] assoc-map
|
||||||
object method-alist>quot ;
|
object method-alist>quot ;
|
||||||
|
|
||||||
: hash-methods ( methods -- buckets )
|
: hash-methods ( methods -- buckets )
|
||||||
|
@ -83,9 +89,12 @@ TUPLE: no-method object generic ;
|
||||||
] if
|
] if
|
||||||
] distribute-buckets ;
|
] distribute-buckets ;
|
||||||
|
|
||||||
|
: class-hash-dispatch-quot ( methods quot picker -- quot )
|
||||||
|
>r >r hash-methods r> map
|
||||||
|
hash-dispatch-quot r> [ class-hash ] rot 3append ;
|
||||||
|
|
||||||
: big-generic ( methods -- quot )
|
: big-generic ( methods -- quot )
|
||||||
hash-methods [ small-generic ] map
|
[ small-generic ] picker class-hash-dispatch-quot ;
|
||||||
hash-dispatch-quot picker [ class-hash ] rot 3append ;
|
|
||||||
|
|
||||||
: vtable-class ( n -- class )
|
: vtable-class ( n -- class )
|
||||||
type>class [ hi-tag bootstrap-word ] unless* ;
|
type>class [ hi-tag bootstrap-word ] unless* ;
|
||||||
|
@ -100,7 +109,8 @@ TUPLE: no-method object generic ;
|
||||||
|
|
||||||
: build-type-vtable ( alist-seq -- alist-seq )
|
: build-type-vtable ( alist-seq -- alist-seq )
|
||||||
dup length [
|
dup length [
|
||||||
vtable-class swap simplify-alist
|
vtable-class
|
||||||
|
swap [ word-def ] assoc-map simplify-alist
|
||||||
class-predicates alist>quot
|
class-predicates alist>quot
|
||||||
] 2map ;
|
] 2map ;
|
||||||
|
|
||||||
|
@ -137,30 +147,35 @@ TUPLE: no-method object generic ;
|
||||||
: standard-methods ( word -- alist )
|
: standard-methods ( word -- alist )
|
||||||
dup methods swap default-method add* ;
|
dup methods swap default-method add* ;
|
||||||
|
|
||||||
|
M: standard-combination make-default-method
|
||||||
|
standard-combination-# (dispatch#)
|
||||||
|
[ empty-method ] with-variable ;
|
||||||
|
|
||||||
M: standard-combination perform-combination
|
M: standard-combination perform-combination
|
||||||
standard-combination-# (dispatch#) [
|
standard-combination-# (dispatch#) [
|
||||||
[ standard-methods ] keep "inline" word-prop
|
[ standard-methods ] keep "inline" word-prop
|
||||||
[ small-generic ] [ single-combination ] if
|
[ small-generic ] [ single-combination ] if
|
||||||
] with-variable ;
|
] with-variable ;
|
||||||
|
|
||||||
: default-hook-method ( word -- pair )
|
|
||||||
error-method object bootstrap-word swap 2array ;
|
|
||||||
|
|
||||||
: hook-methods ( word -- methods )
|
|
||||||
dup methods [ [ drop ] swap append ] assoc-map
|
|
||||||
swap default-hook-method add* ;
|
|
||||||
|
|
||||||
TUPLE: hook-combination var ;
|
TUPLE: hook-combination var ;
|
||||||
|
|
||||||
C: <hook-combination> hook-combination
|
C: <hook-combination> hook-combination
|
||||||
|
|
||||||
M: hook-combination perform-combination
|
M: hook-combination method-prologue
|
||||||
|
2drop [ drop ] ;
|
||||||
|
|
||||||
|
: with-hook ( combination quot -- quot' )
|
||||||
0 (dispatch#) [
|
0 (dispatch#) [
|
||||||
[
|
swap slip
|
||||||
hook-combination-var [ get ] curry %
|
hook-combination-var [ get ] curry
|
||||||
hook-methods single-combination %
|
swap append
|
||||||
] [ ] make
|
] with-variable ; inline
|
||||||
] with-variable ;
|
|
||||||
|
M: hook-combination make-default-method
|
||||||
|
[ error-method ] with-hook ;
|
||||||
|
|
||||||
|
M: hook-combination perform-combination
|
||||||
|
[ standard-methods single-combination ] with-hook ;
|
||||||
|
|
||||||
: define-simple-generic ( word -- )
|
: define-simple-generic ( word -- )
|
||||||
T{ standard-combination f 0 } define-generic ;
|
T{ standard-combination f 0 } define-generic ;
|
||||||
|
|
|
@ -9,9 +9,13 @@ IN: inference.backend
|
||||||
: recursive-label ( word -- label/f )
|
: recursive-label ( word -- label/f )
|
||||||
recursive-state get at ;
|
recursive-state get at ;
|
||||||
|
|
||||||
|
: inline? ( word -- ? )
|
||||||
|
dup "parent-generic" word-prop
|
||||||
|
[ inline? ] [ "inline" word-prop ] ?if ;
|
||||||
|
|
||||||
: local-recursive-state ( -- assoc )
|
: local-recursive-state ( -- assoc )
|
||||||
recursive-state get dup keys
|
recursive-state get dup keys
|
||||||
[ dup word? [ "inline" word-prop ] when not ] find drop
|
[ dup word? [ inline? ] when not ] find drop
|
||||||
[ head-slice ] when* ;
|
[ head-slice ] when* ;
|
||||||
|
|
||||||
: inline-recursive-label ( word -- label/f )
|
: inline-recursive-label ( word -- label/f )
|
||||||
|
@ -157,7 +161,7 @@ TUPLE: too-many-r> ;
|
||||||
meta-d get push-all ;
|
meta-d get push-all ;
|
||||||
|
|
||||||
: if-inline ( word true false -- )
|
: if-inline ( word true false -- )
|
||||||
>r >r dup "inline" word-prop r> r> if ; inline
|
>r >r dup inline? r> r> if ; inline
|
||||||
|
|
||||||
: consume/produce ( effect node -- )
|
: consume/produce ( effect node -- )
|
||||||
over effect-in over consume-values
|
over effect-in over consume-values
|
||||||
|
@ -331,7 +335,7 @@ TUPLE: unbalanced-branches-error quots in out ;
|
||||||
#merge node, ; inline
|
#merge node, ; inline
|
||||||
|
|
||||||
: make-call-node ( word effect -- )
|
: make-call-node ( word effect -- )
|
||||||
swap dup "inline" word-prop
|
swap dup inline?
|
||||||
over dup recursive-label eq? not and [
|
over dup recursive-label eq? not and [
|
||||||
meta-d get clone -rot
|
meta-d get clone -rot
|
||||||
recursive-label #call-label [ consume/produce ] keep
|
recursive-label #call-label [ consume/produce ] keep
|
||||||
|
|
|
@ -245,11 +245,19 @@ M: #dispatch optimize-node*
|
||||||
: dispatching-class ( node word -- class )
|
: dispatching-class ( node word -- class )
|
||||||
[ dispatch# node-class# ] keep specific-method ;
|
[ dispatch# node-class# ] keep specific-method ;
|
||||||
|
|
||||||
|
: flat-length ( seq -- n )
|
||||||
|
[
|
||||||
|
dup quotation? over array? or
|
||||||
|
[ flat-length ] [ drop 1 ] if
|
||||||
|
] map sum ;
|
||||||
|
|
||||||
: will-inline-method ( node word -- method-spec/t quot/t )
|
: will-inline-method ( node word -- method-spec/t quot/t )
|
||||||
#! t indicates failure
|
#! t indicates failure
|
||||||
tuck dispatching-class dup [
|
tuck dispatching-class dup [
|
||||||
swap [ 2array ] 2keep
|
swap [ 2array ] 2keep
|
||||||
method method-def
|
method method-word
|
||||||
|
dup word-def flat-length 5 >=
|
||||||
|
[ 1quotation ] [ word-def ] if
|
||||||
] [
|
] [
|
||||||
2drop t t
|
2drop t t
|
||||||
] if ;
|
] if ;
|
||||||
|
|
|
@ -154,7 +154,8 @@ SYMBOL: changed-words
|
||||||
} reset-props ;
|
} reset-props ;
|
||||||
|
|
||||||
: reset-generic ( word -- )
|
: reset-generic ( word -- )
|
||||||
dup reset-word { "methods" "combination" } reset-props ;
|
dup reset-word
|
||||||
|
{ "methods" "combination" "default-method" } reset-props ;
|
||||||
|
|
||||||
: gensym ( -- word )
|
: gensym ( -- word )
|
||||||
"G:" \ gensym counter number>string append f <word> ;
|
"G:" \ gensym counter number>string append f <word> ;
|
||||||
|
|
|
@ -0,0 +1,77 @@
|
||||||
|
USING: classes kernel sequences vocabs math ;
|
||||||
|
IN: benchmark.dispatch5
|
||||||
|
|
||||||
|
MIXIN: g
|
||||||
|
|
||||||
|
TUPLE: x1 ;
|
||||||
|
INSTANCE: x1 g
|
||||||
|
TUPLE: x2 ;
|
||||||
|
INSTANCE: x2 g
|
||||||
|
TUPLE: x3 ;
|
||||||
|
INSTANCE: x3 g
|
||||||
|
TUPLE: x4 ;
|
||||||
|
INSTANCE: x4 g
|
||||||
|
TUPLE: x5 ;
|
||||||
|
INSTANCE: x5 g
|
||||||
|
TUPLE: x6 ;
|
||||||
|
INSTANCE: x6 g
|
||||||
|
TUPLE: x7 ;
|
||||||
|
INSTANCE: x7 g
|
||||||
|
TUPLE: x8 ;
|
||||||
|
INSTANCE: x8 g
|
||||||
|
TUPLE: x9 ;
|
||||||
|
INSTANCE: x9 g
|
||||||
|
TUPLE: x10 ;
|
||||||
|
INSTANCE: x10 g
|
||||||
|
TUPLE: x11 ;
|
||||||
|
INSTANCE: x11 g
|
||||||
|
TUPLE: x12 ;
|
||||||
|
INSTANCE: x12 g
|
||||||
|
TUPLE: x13 ;
|
||||||
|
INSTANCE: x13 g
|
||||||
|
TUPLE: x14 ;
|
||||||
|
INSTANCE: x14 g
|
||||||
|
TUPLE: x15 ;
|
||||||
|
INSTANCE: x15 g
|
||||||
|
TUPLE: x16 ;
|
||||||
|
INSTANCE: x16 g
|
||||||
|
TUPLE: x17 ;
|
||||||
|
INSTANCE: x17 g
|
||||||
|
TUPLE: x18 ;
|
||||||
|
INSTANCE: x18 g
|
||||||
|
TUPLE: x19 ;
|
||||||
|
INSTANCE: x19 g
|
||||||
|
TUPLE: x20 ;
|
||||||
|
INSTANCE: x20 g
|
||||||
|
TUPLE: x21 ;
|
||||||
|
INSTANCE: x21 g
|
||||||
|
TUPLE: x22 ;
|
||||||
|
INSTANCE: x22 g
|
||||||
|
TUPLE: x23 ;
|
||||||
|
INSTANCE: x23 g
|
||||||
|
TUPLE: x24 ;
|
||||||
|
INSTANCE: x24 g
|
||||||
|
TUPLE: x25 ;
|
||||||
|
INSTANCE: x25 g
|
||||||
|
TUPLE: x26 ;
|
||||||
|
INSTANCE: x26 g
|
||||||
|
TUPLE: x27 ;
|
||||||
|
INSTANCE: x27 g
|
||||||
|
TUPLE: x28 ;
|
||||||
|
INSTANCE: x28 g
|
||||||
|
TUPLE: x29 ;
|
||||||
|
INSTANCE: x29 g
|
||||||
|
TUPLE: x30 ;
|
||||||
|
INSTANCE: x30 g
|
||||||
|
|
||||||
|
: my-classes ( -- seq )
|
||||||
|
"benchmark.dispatch5" words [ tuple-class? ] subset ;
|
||||||
|
|
||||||
|
: a-bunch-of-objects ( -- seq )
|
||||||
|
my-classes [ construct-empty ] map ;
|
||||||
|
|
||||||
|
: dispatch-benchmark ( -- )
|
||||||
|
1000000 a-bunch-of-objects
|
||||||
|
[ f [ g? or ] reduce drop ] curry times ;
|
||||||
|
|
||||||
|
MAIN: dispatch-benchmark
|
|
@ -14,8 +14,7 @@ IN: tools.crossref
|
||||||
|
|
||||||
: (method-usage) ( word generic -- methods )
|
: (method-usage) ( word generic -- methods )
|
||||||
tuck methods
|
tuck methods
|
||||||
[ second quot-uses key? ] with subset
|
[ second uses member? ] with subset keys
|
||||||
0 <column>
|
|
||||||
swap [ 2array ] curry map ;
|
swap [ 2array ] curry map ;
|
||||||
|
|
||||||
: method-usage ( word seq -- methods )
|
: method-usage ( word seq -- methods )
|
||||||
|
|
Loading…
Reference in New Issue