2008-07-27 21:25:42 -04:00
|
|
|
! Copyright (C) 2008 Slava Pestov.
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2009-02-08 23:12:11 -05:00
|
|
|
USING: accessors kernel arrays sequences math math.order call
|
2008-08-31 20:17:04 -04:00
|
|
|
math.partial-dispatch generic generic.standard generic.math
|
|
|
|
classes.algebra classes.union sets quotations assocs combinators
|
2009-01-09 00:09:38 -05:00
|
|
|
words namespaces continuations classes fry combinators.smart
|
2008-07-30 04:38:10 -04:00
|
|
|
compiler.tree
|
|
|
|
compiler.tree.builder
|
2008-09-12 06:17:27 -04:00
|
|
|
compiler.tree.recursive
|
2008-09-12 09:18:44 -04:00
|
|
|
compiler.tree.combinators
|
2008-07-30 04:38:10 -04:00
|
|
|
compiler.tree.normalization
|
|
|
|
compiler.tree.propagation.info
|
|
|
|
compiler.tree.propagation.nodes ;
|
2008-07-27 21:25:42 -04:00
|
|
|
IN: compiler.tree.propagation.inlining
|
2008-07-30 04:38:10 -04:00
|
|
|
|
2008-09-12 09:18:44 -04:00
|
|
|
! We count nodes up-front; if there are relatively few nodes,
|
|
|
|
! we are more eager to inline
|
|
|
|
SYMBOL: node-count
|
|
|
|
|
2009-03-07 00:34:01 -05:00
|
|
|
: count-nodes ( nodes -- n )
|
|
|
|
0 swap [ drop 1+ ] each-node ;
|
|
|
|
|
|
|
|
: compute-node-count ( nodes -- ) count-nodes node-count set ;
|
2008-09-12 09:18:44 -04:00
|
|
|
|
2008-12-04 08:05:59 -05:00
|
|
|
! We try not to inline the same word too many times, to avoid
|
|
|
|
! combinatorial explosion
|
|
|
|
SYMBOL: inlining-count
|
|
|
|
|
2008-07-30 04:38:10 -04:00
|
|
|
! Splicing nodes
|
|
|
|
GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
|
|
|
|
|
|
|
|
M: word splicing-nodes
|
|
|
|
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
|
|
|
|
|
2008-12-03 09:11:51 -05:00
|
|
|
M: callable splicing-nodes
|
2008-09-12 06:36:06 -04:00
|
|
|
build-sub-tree analyze-recursive normalize ;
|
2008-07-30 04:38:10 -04:00
|
|
|
|
|
|
|
! Dispatch elimination
|
2008-09-12 19:08:38 -04:00
|
|
|
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
|
2008-08-30 03:31:27 -04:00
|
|
|
dup [
|
|
|
|
[ >>class ] dip
|
2008-07-30 04:38:10 -04:00
|
|
|
over method>> over = [ drop ] [
|
|
|
|
2dup splicing-nodes
|
|
|
|
[ >>method ] [ >>body ] bi*
|
|
|
|
] if
|
2009-03-07 00:34:01 -05:00
|
|
|
body>> (propagate) t
|
2008-08-30 03:31:27 -04:00
|
|
|
] [ 2drop f >>method f >>body f >>class drop f ] if ;
|
2008-07-30 04:38:10 -04:00
|
|
|
|
2008-08-30 03:31:27 -04:00
|
|
|
: inlining-standard-method ( #call word -- class/f method/f )
|
2008-12-08 20:14:18 -05:00
|
|
|
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
|
|
|
|
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
|
|
|
|
[ swap nth value-info class>> dup ] dip
|
|
|
|
specific-method
|
|
|
|
] if ;
|
2008-07-30 04:38:10 -04:00
|
|
|
|
|
|
|
: inline-standard-method ( #call word -- ? )
|
|
|
|
dupd inlining-standard-method eliminate-dispatch ;
|
|
|
|
|
|
|
|
: normalize-math-class ( class -- class' )
|
|
|
|
{
|
|
|
|
null
|
|
|
|
fixnum bignum integer
|
|
|
|
ratio rational
|
|
|
|
float real
|
|
|
|
complex number
|
|
|
|
object
|
|
|
|
} [ class<= ] with find nip ;
|
|
|
|
|
2008-08-30 03:31:27 -04:00
|
|
|
: inlining-math-method ( #call word -- class/f quot/f )
|
2008-07-30 04:38:10 -04:00
|
|
|
swap in-d>>
|
|
|
|
first2 [ value-info class>> normalize-math-class ] bi@
|
2008-08-30 03:31:27 -04:00
|
|
|
3dup math-both-known?
|
|
|
|
[ math-method* ] [ 3drop f ] if
|
|
|
|
number swap ;
|
2008-07-30 04:38:10 -04:00
|
|
|
|
|
|
|
: inline-math-method ( #call word -- ? )
|
|
|
|
dupd inlining-math-method eliminate-dispatch ;
|
|
|
|
|
2008-08-30 03:31:27 -04:00
|
|
|
: inlining-math-partial ( #call word -- class/f quot/f )
|
2008-07-30 04:38:10 -04:00
|
|
|
[ "derived-from" word-prop first inlining-math-method ]
|
|
|
|
[ nip 1quotation ] 2bi
|
|
|
|
[ = not ] [ drop ] 2bi and ;
|
|
|
|
|
|
|
|
: inline-math-partial ( #call word -- ? )
|
|
|
|
dupd inlining-math-partial eliminate-dispatch ;
|
|
|
|
|
|
|
|
! Method body inlining
|
|
|
|
SYMBOL: recursive-calls
|
|
|
|
DEFER: (flat-length)
|
|
|
|
|
|
|
|
: word-flat-length ( word -- n )
|
|
|
|
{
|
2008-11-24 06:46:26 -05:00
|
|
|
! special-case
|
|
|
|
{ [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
|
2008-07-30 04:38:10 -04:00
|
|
|
! not inline
|
|
|
|
{ [ dup inline? not ] [ drop 1 ] }
|
|
|
|
! recursive and inline
|
|
|
|
{ [ dup recursive-calls get key? ] [ drop 10 ] }
|
|
|
|
! inline
|
|
|
|
[ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
|
|
|
|
} cond ;
|
|
|
|
|
|
|
|
: (flat-length) ( seq -- n )
|
|
|
|
[
|
|
|
|
{
|
|
|
|
{ [ dup quotation? ] [ (flat-length) 2 + ] }
|
|
|
|
{ [ dup array? ] [ (flat-length) ] }
|
|
|
|
{ [ dup word? ] [ word-flat-length ] }
|
|
|
|
[ drop 0 ]
|
|
|
|
} cond
|
|
|
|
] sigma ;
|
|
|
|
|
|
|
|
: flat-length ( word -- n )
|
|
|
|
H{ } clone recursive-calls [
|
|
|
|
[ recursive-calls get conjoin ]
|
|
|
|
[ def>> (flat-length) 5 /i ]
|
|
|
|
bi
|
|
|
|
] with-variable ;
|
|
|
|
|
|
|
|
: classes-known? ( #call -- ? )
|
|
|
|
in-d>> [
|
|
|
|
value-info class>>
|
|
|
|
[ class-types length 1 = ]
|
|
|
|
[ union-class? not ]
|
|
|
|
bi and
|
2009-01-29 23:19:07 -05:00
|
|
|
] any? ;
|
2008-07-30 04:38:10 -04:00
|
|
|
|
2008-12-04 08:05:59 -05:00
|
|
|
: node-count-bias ( -- n )
|
|
|
|
45 node-count get [-] 8 /i ;
|
|
|
|
|
|
|
|
: body-length-bias ( word -- n )
|
2008-12-05 02:50:14 -05:00
|
|
|
[ flat-length ] [ inlining-count get at 0 or ] bi
|
|
|
|
over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
|
2008-12-04 08:05:59 -05:00
|
|
|
|
2008-07-30 04:38:10 -04:00
|
|
|
: inlining-rank ( #call word -- n )
|
|
|
|
[
|
2009-01-09 00:09:38 -05:00
|
|
|
[ classes-known? 2 0 ? ]
|
|
|
|
[
|
|
|
|
{
|
|
|
|
[ body-length-bias ]
|
|
|
|
[ "default" word-prop -4 0 ? ]
|
|
|
|
[ "specializer" word-prop 1 0 ? ]
|
|
|
|
[ method-body? 1 0 ? ]
|
|
|
|
} cleave
|
|
|
|
node-count-bias
|
|
|
|
loop-nesting get 0 or 2 *
|
|
|
|
] bi*
|
|
|
|
] sum-outputs ;
|
2008-07-30 04:38:10 -04:00
|
|
|
|
|
|
|
: should-inline? ( #call word -- ? )
|
2008-11-06 01:02:44 -05:00
|
|
|
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
|
2008-07-30 04:38:10 -04:00
|
|
|
|
|
|
|
SYMBOL: history
|
|
|
|
|
|
|
|
: remember-inlining ( word -- )
|
2008-12-09 17:54:48 -05:00
|
|
|
[ inlining-count get inc-at ]
|
2008-12-04 08:05:59 -05:00
|
|
|
[ history [ swap suffix ] change ]
|
|
|
|
bi ;
|
2008-07-30 04:38:10 -04:00
|
|
|
|
2008-12-03 09:11:51 -05:00
|
|
|
: inline-word-def ( #call word quot -- ? )
|
2008-12-04 08:05:59 -05:00
|
|
|
over history get memq? [ 3drop f ] [
|
2008-07-30 04:38:10 -04:00
|
|
|
[
|
2009-03-07 00:34:01 -05:00
|
|
|
[ remember-inlining ] dip
|
|
|
|
[ drop ] [ splicing-nodes ] 2bi
|
|
|
|
[ >>body drop ] [ count-nodes ] [ (propagate) ] tri
|
|
|
|
] with-scope node-count +@
|
2008-08-28 23:28:34 -04:00
|
|
|
t
|
2008-07-30 04:38:10 -04:00
|
|
|
] if ;
|
|
|
|
|
2008-12-03 09:11:51 -05:00
|
|
|
: inline-word ( #call word -- ? )
|
|
|
|
dup def>> inline-word-def ;
|
|
|
|
|
2008-07-30 04:38:10 -04:00
|
|
|
: inline-method-body ( #call word -- ? )
|
2008-08-28 23:28:34 -04:00
|
|
|
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
|
2008-08-02 00:31:43 -04:00
|
|
|
|
|
|
|
: always-inline-word? ( word -- ? )
|
|
|
|
{ curry compose } memq? ;
|
2008-08-31 20:17:04 -04:00
|
|
|
|
2009-03-01 21:12:35 -05:00
|
|
|
: never-inline-word? ( word -- ? )
|
|
|
|
[ deferred? ] [ { call execute } memq? ] bi or ;
|
|
|
|
|
2008-09-12 19:08:38 -04:00
|
|
|
: custom-inlining? ( word -- ? )
|
|
|
|
"custom-inlining" word-prop ;
|
|
|
|
|
|
|
|
: inline-custom ( #call word -- ? )
|
2009-02-08 23:12:11 -05:00
|
|
|
[ dup ] [ "custom-inlining" word-prop ] bi*
|
|
|
|
call( #call -- word/quot/f )
|
|
|
|
object swap eliminate-dispatch ;
|
2008-09-12 19:08:38 -04:00
|
|
|
|
2008-12-03 09:11:51 -05:00
|
|
|
: inline-instance-check ( #call word -- ? )
|
|
|
|
over in-d>> second value-info literal>> dup class?
|
|
|
|
[ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
|
|
|
|
|
2008-12-06 12:17:19 -05:00
|
|
|
: (do-inlining) ( #call word -- ? )
|
2008-11-03 21:59:48 -05:00
|
|
|
#! If the generic was defined in an outer compilation unit,
|
|
|
|
#! then it doesn't have a definition yet; the definition
|
|
|
|
#! is built at the end of the compilation unit. We do not
|
|
|
|
#! attempt inlining at this stage since the stack discipline
|
|
|
|
#! is not finalized yet, so dispatch# might return an out
|
|
|
|
#! of bounds value. This case comes up if a parsing word
|
|
|
|
#! calls the compiler at parse time (doing so is
|
|
|
|
#! discouraged, but it should still work.)
|
2008-12-06 12:17:19 -05:00
|
|
|
{
|
2009-03-01 21:12:35 -05:00
|
|
|
{ [ dup never-inline-word? ] [ 2drop f ] }
|
2008-12-06 12:17:19 -05:00
|
|
|
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
|
|
|
|
{ [ dup always-inline-word? ] [ inline-word ] }
|
|
|
|
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
|
|
|
{ [ dup math-generic? ] [ inline-math-method ] }
|
|
|
|
{ [ dup method-body? ] [ inline-method-body ] }
|
|
|
|
[ 2drop f ]
|
|
|
|
} cond ;
|
|
|
|
|
|
|
|
: do-inlining ( #call word -- ? )
|
|
|
|
#! Note the logic here: if there's a custom inlining hook,
|
|
|
|
#! it is permitted to return f, which means that we try the
|
|
|
|
#! normal inlining heuristic.
|
|
|
|
dup custom-inlining? [ 2dup inline-custom ] [ f ] if
|
|
|
|
[ 2drop t ] [ (do-inlining) ] if ;
|