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

Fixing some bugs, tweaking optimizer inlining

db4
Slava Pestov 2008-02-16 18:50:16 -06:00
parent a71665d821
commit 9c684bf1c5
5 changed files with 91 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
core/generic/generic.factor
View File

@ -82,10 +82,19 @@ M: method-body stack-effect
[ <method-word> ] 3keep f \ method construct-boa
dup method-word over "method" set-word-prop ;
: redefine-method ( quot method -- )
2dup set-method-def
method-word swap define ;
: define-method ( quot class generic -- )
>r bootstrap-word r>
[ <method> ] 2keep
[ set-at ] with-methods ;
2dup method dup [
2nip redefine-method
] [
drop
[ <method> ] 2keep
[ set-at ] with-methods
] if ;
: define-default-method ( generic combination -- )
dupd make-default-method object bootstrap-word pick <method>

118
core/optimizer/inlining/inlining.factor
View File

@ -6,62 +6,38 @@ math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control ;
optimizer.control kernel.private ;
IN: optimizer.inlining
GENERIC: remember-method* ( method-spec node -- )
: remember-inlining ( node history -- )
[ swap set-node-history ] curry each-node ;
M: #call remember-method*
[ node-history ?push ] keep set-node-history ;
M: node remember-method*
2drop ;
: remember-method ( method-spec node -- )
swap dup second +inlined+ depends-on
[ swap remember-method* ] curry each-node ;
: (splice-method) ( #call method-spec quot -- node )
#! Must remember the method before splicing in, otherwise
#! the rest of the IR will also remember the method
pick node-in-d dataflow-with
[ remember-method ] keep
[ swap infer-classes/node ] 2keep
[ splice-node ] keep ;
: splice-quot ( #call quot -- node )
: inlining-quot ( node quot -- node )
over node-in-d dataflow-with
[ swap infer-classes/node ] 2keep
[ splice-node ] keep ;
dup rot infer-classes/node ;
! #call
: splice-method ( #call method-spec/t quot/t -- node/t )
#! t indicates failure
{
{ [ dup t eq? ] [ 3drop t ] }
{ [ 2over swap node-history member? ] [ 3drop t ] }
{ [ t ] [ (splice-method) ] }
} cond ;
! Single dispatch method inlining optimization
: already-inlined? ( node -- ? )
#! Was this node inlined from definition of 'word'?
dup node-param swap node-history memq? ;
: specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ;
: dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ;
: splice-quot ( #call quot history -- node )
#! Must add history *before* splicing in, otherwise
#! the rest of the IR will also remember the history
pick node-history append
>r dupd inlining-quot dup r> remember-inlining
tuck splice-node ;
! A heuristic to avoid excessive inlining
DEFER: (flat-length)
: word-flat-length ( word -- n )
dup get over inline? not or
[ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
{
! heuristic: { ... } declare comes up in method bodies
! and we don't care about it
{ [ dup \ declare eq? ] [ drop -2 ] }
! recursive
{ [ dup get ] [ drop 1 ] }
! not inline
{ [ dup inline? not ] [ drop 1 ] }
! inline
{ [ t ] [ dup dup set word-def (flat-length) ] }
} cond ;
: (flat-length) ( seq -- n )
[
@ -76,32 +52,29 @@ DEFER: (flat-length)
: flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ;
: will-inline-method ( node word -- method-spec/t quot/t )
#! t indicates failure
tuck dispatching-class dup [
swap [ 2array ] 2keep
method method-word
dup flat-length 10 >=
[ 1quotation ] [ word-def ] if
] [
2drop t t
] if ;
! Single dispatch method inlining optimization
: specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ;
: dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ;
: inline-standard-method ( node word -- node )
dupd will-inline-method splice-method ;
2dup dispatching-class dup [
swap method method-word 1quotation f splice-quot
] [
3drop t
] if ;
! Partial dispatch of math-generic words
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
: will-inline-math-method ( word left right -- method-spec/t quot/t )
#! t indicates failure
3dup math-both-known?
[ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
: inline-math-method ( #call word -- node )
over node-input-classes first2
will-inline-math-method splice-method ;
over node-input-classes first2 3dup math-both-known?
[ math-method f splice-quot ] [ 2drop 2drop t ] if ;
: inline-method ( #call -- node )
dup node-param {
@ -131,7 +104,7 @@ DEFER: (flat-length)
: inline-literals ( node literals -- node )
#! Make #shuffle -> #push -> #return -> successor
dupd literal-quot splice-quot ;
dupd literal-quot f splice-quot ;
: evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r
@ -196,7 +169,7 @@ DEFER: (flat-length)
nip dup [ second ] when ;
: apply-identities ( node -- node/f )
dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
@ -206,13 +179,20 @@ DEFER: (flat-length)
2drop f
] if ;
: splice-word-def ( #call word -- node )
dup +inlined+ depends-on
dup word-def swap 1array splice-quot ;
: optimistic-inline ( #call -- node )
dup node-param dup +inlined+ depends-on
word-def splice-quot ;
dup node-param over node-history memq? [
drop t
] [
dup node-param splice-word-def
] if ;
: method-body-inline? ( #call -- ? )
node-param dup method-body?
[ flat-length 8 <= ] [ drop f ] if ;
[ flat-length 10 <= ] [ drop f ] if ;
M: #call optimize-node*
{

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

@ -40,7 +40,7 @@ optimizer.inlining float-arrays sequences.private combinators ;
: flip-branches ( #call -- #if )
#! If a not is followed by an #if, flip branches and
#! remove the not.
dup sole-consumer (flip-branches) [ ] splice-quot ;
dup sole-consumer (flip-branches) [ ] f splice-quot ;
\ not {
{ [ dup flip-branches? ] [ flip-branches ] }
@ -63,7 +63,7 @@ optimizer.inlining float-arrays sequences.private combinators ;
[ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot splice-quot ;
dup node-in-d peek value-literal member-quot f splice-quot ;
\ member? {
{ [ dup literal-member? ] [ expand-member ] }

6
core/optimizer/math/math.factor
View File

@ -366,7 +366,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
} [
[
[ dup remove-overflow-check? ] ,
[ splice-quot ] curry ,
[ f splice-quot ] curry ,
] { } make 1array define-optimizers
] assoc-each
@ -436,7 +436,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
dup remove-overflow-check?
over coereced-to-fixnum? or
] ,
[ splice-quot ] curry ,
[ f splice-quot ] curry ,
] { } make 1array define-optimizers
] assoc-each
@ -461,6 +461,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
\ fixnum-shift {
{
[ dup fixnum-shift-fast? ]
[ [ fixnum-shift-fast ] splice-quot ]
[ [ fixnum-shift-fast ] f splice-quot ]
}
} define-optimizers

27
core/optimizer/optimizer-tests.factor
View File

@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private
continuations growable optimizer.inlining namespaces ;
continuations growable optimizer.inlining namespaces hints ;
IN: temporary
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@ -351,3 +351,28 @@ M: integer generic-inline-test ;
\ generic-inline-test-1 word-def dataflow
[ optimize-1 , optimize-1 , drop ] { } make
] unit-test
! Forgot a recursive inline check
: recursive-inline-hang ( a -- a )
dup array? [ recursive-inline-hang ] when ;
HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1
{ } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
DEFER: recursive-inline-hang-3
: recursive-inline-hang-2 ( a -- a )
dup array? [ recursive-inline-hang-3 ] when ;
HINTS: recursive-inline-hang-2 array ;
: recursive-inline-hang-3 ( a -- a )
dup array? [ recursive-inline-hang-2 ] when ;
HINTS: recursive-inline-hang-3 array ;