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

Expand instance? with literal class

db4
Slava Pestov 2008-12-03 08:11:51 -06:00
parent 8834f8e041
commit d60c79c9bf
1 changed files with 15 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -3,7 +3,7 @@
USING: accessors kernel arrays sequences math math.order USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations words namespaces continuations classes fry
compiler.tree compiler.tree
compiler.tree.builder compiler.tree.builder
compiler.tree.recursive compiler.tree.recursive
@ -26,7 +26,7 @@ GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
M: word splicing-nodes M: word splicing-nodes
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
M: quotation splicing-nodes M: callable splicing-nodes
build-sub-tree analyze-recursive normalize ; build-sub-tree analyze-recursive normalize ;
: propagate-body ( #call -- ) : propagate-body ( #call -- )
@ -140,18 +140,21 @@ SYMBOL: history
: remember-inlining ( word -- ) : remember-inlining ( word -- )
history [ swap suffix ] change ; history [ swap suffix ] change ;
: inline-word ( #call word -- ? ) : inline-word-def ( #call word quot -- ? )
dup history get memq? [ over history get memq? [
2drop f 3drop f
] [ ] [
[ [
dup remember-inlining swap remember-inlining
dupd def>> splicing-nodes >>body dupd splicing-nodes >>body
propagate-body propagate-body
] with-scope ] with-scope
t t
] if ; ] if ;
: inline-word ( #call word -- ? )
dup def>> inline-word-def ;
: inline-method-body ( #call word -- ? ) : inline-method-body ( #call word -- ? )
2dup should-inline? [ inline-word ] [ 2drop f ] if ; 2dup should-inline? [ inline-word ] [ 2drop f ] if ;
@ -165,6 +168,10 @@ SYMBOL: history
[ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
first object swap eliminate-dispatch ; first object swap eliminate-dispatch ;
: inline-instance-check ( #call word -- ? )
over in-d>> second value-info literal>> dup class?
[ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
: do-inlining ( #call word -- ? ) : do-inlining ( #call word -- ? )
#! If the generic was defined in an outer compilation unit, #! If the generic was defined in an outer compilation unit,
#! then it doesn't have a definition yet; the definition #! then it doesn't have a definition yet; the definition
@ -177,6 +184,7 @@ SYMBOL: history
{ {
{ [ dup deferred? ] [ 2drop f ] } { [ dup deferred? ] [ 2drop f ] }
{ [ dup custom-inlining? ] [ inline-custom ] } { [ dup custom-inlining? ] [ inline-custom ] }
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
{ [ dup always-inline-word? ] [ inline-word ] } { [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] } { [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] } { [ dup math-generic? ] [ inline-math-method ] }