Fix bug and clean up optimizer
Slava Pestov
parent
bb2684f3df
commit
6f1dc49fa8
|
|
@ -3,8 +3,7 @@
|
||||||
USING: arrays generic assocs inference inference.class
|
USING: arrays generic assocs inference inference.class
|
||||||
inference.dataflow inference.backend inference.state io kernel
|
inference.dataflow inference.backend inference.state io kernel
|
||||||
math namespaces sequences vectors words quotations hashtables
|
math namespaces sequences vectors words quotations hashtables
|
||||||
combinators classes generic.math continuations optimizer.def-use
|
combinators classes optimizer.def-use ;
|
||||||
optimizer.pattern-match generic.standard optimizer.specializers ;
|
|
||||||
IN: optimizer.backend
|
IN: optimizer.backend
|
||||||
|
|
||||||
SYMBOL: class-substitutions
|
SYMBOL: class-substitutions
|
||||||
|
|
@ -76,7 +75,6 @@ DEFER: optimize-nodes
|
||||||
optimizer-changed get
|
optimizer-changed get
|
||||||
] with-scope optimizer-changed set ;
|
] with-scope optimizer-changed set ;
|
||||||
|
|
||||||
! Generic nodes
|
|
||||||
M: node optimize-node* drop t f ;
|
M: node optimize-node* drop t f ;
|
||||||
|
|
||||||
! Post-inlining cleanup
|
! Post-inlining cleanup
|
||||||
|
|
@ -112,362 +110,10 @@ M: #return optimize-node* cleanup-inlining ;
|
||||||
! #values
|
! #values
|
||||||
M: #values optimize-node* cleanup-inlining ;
|
M: #values optimize-node* cleanup-inlining ;
|
||||||
|
|
||||||
! Some utilities for splicing in dataflow IR subtrees
|
|
||||||
M: f set-node-successor 2drop ;
|
M: f set-node-successor 2drop ;
|
||||||
|
|
||||||
: splice-node ( old new -- )
|
: splice-node ( old new -- )
|
||||||
dup splice-def-use last-node set-node-successor ;
|
dup splice-def-use last-node set-node-successor ;
|
||||||
|
|
||||||
GENERIC: remember-method* ( method-spec 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 )
|
|
||||||
over node-in-d dataflow-with
|
|
||||||
[ swap infer-classes/node ] 2keep
|
|
||||||
[ splice-node ] keep ;
|
|
||||||
|
|
||||||
: drop-inputs ( node -- #shuffle )
|
: drop-inputs ( node -- #shuffle )
|
||||||
node-in-d clone \ #shuffle in-node ;
|
node-in-d clone \ #shuffle in-node ;
|
||||||
|
|
||||||
! Constant branch folding
|
|
||||||
: fold-branch ( node branch# -- node )
|
|
||||||
over node-children nth
|
|
||||||
swap node-successor over splice-node ;
|
|
||||||
|
|
||||||
! #if
|
|
||||||
: known-boolean-value? ( node value -- value ? )
|
|
||||||
2dup node-literal? [
|
|
||||||
node-literal t
|
|
||||||
] [
|
|
||||||
node-class {
|
|
||||||
{ [ dup null class< ] [ drop f f ] }
|
|
||||||
{ [ dup general-t class< ] [ drop t t ] }
|
|
||||||
{ [ dup \ f class< ] [ drop f t ] }
|
|
||||||
{ [ t ] [ drop f f ] }
|
|
||||||
} cond
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: fold-if-branch? dup node-in-d first known-boolean-value? ;
|
|
||||||
|
|
||||||
: fold-if-branch ( node value -- node' )
|
|
||||||
over drop-inputs >r
|
|
||||||
0 1 ? fold-branch
|
|
||||||
r> [ set-node-successor ] keep ;
|
|
||||||
|
|
||||||
: only-one ( seq -- elt/f )
|
|
||||||
dup length 1 = [ first ] [ drop f ] if ;
|
|
||||||
|
|
||||||
: lift-throw-tail? ( #if -- tail/? )
|
|
||||||
dup node-successor node-successor
|
|
||||||
[ active-children only-one ] [ drop f ] if ;
|
|
||||||
|
|
||||||
: clone-node ( node -- newnode )
|
|
||||||
clone dup [ clone ] modify-values ;
|
|
||||||
|
|
||||||
: detach-node-successor ( node -- successor )
|
|
||||||
dup node-successor #terminate rot set-node-successor ;
|
|
||||||
|
|
||||||
: lift-branch ( #if node -- )
|
|
||||||
>r detach-node-successor r> splice-node ;
|
|
||||||
|
|
||||||
M: #if optimize-node*
|
|
||||||
dup fold-if-branch? [ fold-if-branch t ] [
|
|
||||||
2drop t f
|
|
||||||
! drop dup lift-throw-tail? dup [
|
|
||||||
! dupd lift-branch t
|
|
||||||
! ] [
|
|
||||||
! 2drop t f
|
|
||||||
! ] if
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: fold-dispatch-branch? dup node-in-d first tuck node-literal? ;
|
|
||||||
|
|
||||||
: fold-dispatch-branch ( node value -- node' )
|
|
||||||
dupd node-literal
|
|
||||||
over drop-inputs >r fold-branch r>
|
|
||||||
[ set-node-successor ] keep ;
|
|
||||||
|
|
||||||
M: #dispatch optimize-node*
|
|
||||||
dup fold-dispatch-branch? [
|
|
||||||
fold-dispatch-branch t
|
|
||||||
] [
|
|
||||||
2drop t f
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
! #loop
|
|
||||||
|
|
||||||
|
|
||||||
! BEFORE:
|
|
||||||
|
|
||||||
! #label -> C -> #return 1
|
|
||||||
! |
|
|
||||||
! -> #if -> #merge -> #return 2
|
|
||||||
! |
|
|
||||||
! --------
|
|
||||||
! | |
|
|
||||||
! A B
|
|
||||||
! | |
|
|
||||||
! #values |
|
|
||||||
! #call-label
|
|
||||||
! |
|
|
||||||
! |
|
|
||||||
! #values
|
|
||||||
|
|
||||||
! AFTER:
|
|
||||||
|
|
||||||
! #label -> #terminate
|
|
||||||
! |
|
|
||||||
! -> #if -> #terminate
|
|
||||||
! |
|
|
||||||
! --------
|
|
||||||
! | |
|
|
||||||
! A B
|
|
||||||
! | |
|
|
||||||
! #values |
|
|
||||||
! | #call-label
|
|
||||||
! #merge |
|
|
||||||
! | |
|
|
||||||
! C #values
|
|
||||||
! |
|
|
||||||
! #return 1
|
|
||||||
|
|
||||||
: find-final-if ( node -- #if/f )
|
|
||||||
dup [
|
|
||||||
dup #if? [
|
|
||||||
dup node-successor #tail? [
|
|
||||||
node-successor find-final-if
|
|
||||||
] unless
|
|
||||||
] [
|
|
||||||
node-successor find-final-if
|
|
||||||
] if
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
: lift-loop-tail? ( #label -- tail/f )
|
|
||||||
dup node-successor node-successor [
|
|
||||||
dup node-param swap node-child find-final-if dup [
|
|
||||||
node-children [ penultimate-node ] map
|
|
||||||
[
|
|
||||||
dup #call-label?
|
|
||||||
[ node-param eq? not ] [ 2drop t ] if
|
|
||||||
] with subset only-one
|
|
||||||
] [ 2drop f ] if
|
|
||||||
] [ drop f ] if ;
|
|
||||||
|
|
||||||
! M: #loop optimize-node*
|
|
||||||
! dup lift-loop-tail? dup [
|
|
||||||
! last-node >r
|
|
||||||
! dup detach-node-successor
|
|
||||||
! over node-child find-final-if detach-node-successor
|
|
||||||
! [ set-node-successor ] keep
|
|
||||||
! r> set-node-successor
|
|
||||||
! t
|
|
||||||
! ] [
|
|
||||||
! 2drop t f
|
|
||||||
! ] if ;
|
|
||||||
|
|
||||||
! #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 ;
|
|
||||||
|
|
||||||
! 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 ;
|
|
||||||
|
|
||||||
: (flat-length) ( seq -- n )
|
|
||||||
[
|
|
||||||
{
|
|
||||||
{ [ dup quotation? ] [ (flat-length) 1+ ] }
|
|
||||||
{ [ dup array? ] [ (flat-length) ] }
|
|
||||||
{ [ dup word? ] [ word-flat-length ] }
|
|
||||||
{ [ t ] [ drop 1 ] }
|
|
||||||
} cond
|
|
||||||
] map sum ;
|
|
||||||
|
|
||||||
: 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 ;
|
|
||||||
|
|
||||||
: inline-standard-method ( node word -- node )
|
|
||||||
dupd will-inline-method splice-method ;
|
|
||||||
|
|
||||||
! 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 ;
|
|
||||||
|
|
||||||
: inline-method ( #call -- node )
|
|
||||||
dup node-param {
|
|
||||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
|
||||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
|
||||||
{ [ t ] [ 2drop t ] }
|
|
||||||
} cond ;
|
|
||||||
|
|
||||||
! Resolve type checks at compile time where possible
|
|
||||||
: comparable? ( actual testing -- ? )
|
|
||||||
#! If actual is a subset of testing or if the two classes
|
|
||||||
#! are disjoint, return t.
|
|
||||||
2dup class< >r classes-intersect? not r> or ;
|
|
||||||
|
|
||||||
: optimize-predicate? ( #call -- ? )
|
|
||||||
dup node-param "predicating" word-prop dup [
|
|
||||||
>r node-class-first r> comparable?
|
|
||||||
] [
|
|
||||||
2drop f
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: literal-quot ( node literals -- quot )
|
|
||||||
#! Outputs a quotation which drops the node's inputs, and
|
|
||||||
#! pushes some literals.
|
|
||||||
>r node-in-d length \ drop <repetition>
|
|
||||||
r> [ literalize ] map append >quotation ;
|
|
||||||
|
|
||||||
: inline-literals ( node literals -- node )
|
|
||||||
#! Make #shuffle -> #push -> #return -> successor
|
|
||||||
dupd literal-quot splice-quot ;
|
|
||||||
|
|
||||||
: evaluate-predicate ( #call -- ? )
|
|
||||||
dup node-param "predicating" word-prop >r
|
|
||||||
node-class-first r> class< ;
|
|
||||||
|
|
||||||
: optimize-predicate ( #call -- node )
|
|
||||||
dup evaluate-predicate swap
|
|
||||||
dup node-successor #if? [
|
|
||||||
dup drop-inputs >r
|
|
||||||
node-successor swap 0 1 ? fold-branch
|
|
||||||
r> [ set-node-successor ] keep
|
|
||||||
] [
|
|
||||||
swap 1array inline-literals
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: optimizer-hooks ( node -- conditions )
|
|
||||||
node-param "optimizer-hooks" word-prop ;
|
|
||||||
|
|
||||||
: optimizer-hook ( node -- pair/f )
|
|
||||||
dup optimizer-hooks [ first call ] find 2nip ;
|
|
||||||
|
|
||||||
: optimize-hook ( node -- )
|
|
||||||
dup optimizer-hook second call ;
|
|
||||||
|
|
||||||
: define-optimizers ( word optimizers -- )
|
|
||||||
"optimizer-hooks" set-word-prop ;
|
|
||||||
|
|
||||||
: flush-eval? ( #call -- ? )
|
|
||||||
dup node-param "flushable" word-prop [
|
|
||||||
node-out-d [ unused? ] all?
|
|
||||||
] [
|
|
||||||
drop f
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: flush-eval ( #call -- node )
|
|
||||||
dup node-param +inlined+ depends-on
|
|
||||||
dup node-out-d length f <repetition> inline-literals ;
|
|
||||||
|
|
||||||
: partial-eval? ( #call -- ? )
|
|
||||||
dup node-param "foldable" word-prop [
|
|
||||||
dup node-in-d [ node-literal? ] with all?
|
|
||||||
] [
|
|
||||||
drop f
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: literal-in-d ( #call -- inputs )
|
|
||||||
dup node-in-d [ node-literal ] with map ;
|
|
||||||
|
|
||||||
: partial-eval ( #call -- node )
|
|
||||||
dup node-param +inlined+ depends-on
|
|
||||||
dup literal-in-d over node-param 1quotation
|
|
||||||
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
|
|
||||||
|
|
||||||
: define-identities ( words identities -- )
|
|
||||||
[ "identities" set-word-prop ] curry each ;
|
|
||||||
|
|
||||||
: find-identity ( node -- quot )
|
|
||||||
[ node-param "identities" word-prop ] keep
|
|
||||||
[ swap first in-d-match? ] curry find
|
|
||||||
nip dup [ second ] when ;
|
|
||||||
|
|
||||||
: apply-identities ( node -- node/f )
|
|
||||||
dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
|
|
||||||
|
|
||||||
: optimistic-inline? ( #call -- ? )
|
|
||||||
dup node-param "specializer" word-prop dup [
|
|
||||||
>r node-input-classes r> specialized-length tail*
|
|
||||||
[ types length 1 = ] all?
|
|
||||||
] [
|
|
||||||
2drop f
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: optimistic-inline ( #call -- node )
|
|
||||||
dup node-param dup +inlined+ depends-on
|
|
||||||
word-def splice-quot ;
|
|
||||||
|
|
||||||
: method-body-inline? ( #call -- ? )
|
|
||||||
node-param dup method-body?
|
|
||||||
[ flat-length 8 <= ] [ drop f ] if ;
|
|
||||||
|
|
||||||
M: #call optimize-node*
|
|
||||||
{
|
|
||||||
{ [ dup flush-eval? ] [ flush-eval ] }
|
|
||||||
{ [ dup partial-eval? ] [ partial-eval ] }
|
|
||||||
{ [ dup find-identity ] [ apply-identities ] }
|
|
||||||
{ [ dup optimizer-hook ] [ optimize-hook ] }
|
|
||||||
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
|
|
||||||
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
|
|
||||||
{ [ dup method-body-inline? ] [ optimistic-inline ] }
|
|
||||||
{ [ t ] [ inline-method ] }
|
|
||||||
} cond dup not ;
|
|
||||||
|
|
|
||||||
|
|
@ -1,9 +1,60 @@
|
||||||
! Copyright (C) 2008 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: kernel inference.dataflow combinators sequences
|
USING: arrays generic assocs inference inference.class
|
||||||
namespaces math ;
|
inference.dataflow inference.backend inference.state io kernel
|
||||||
|
math namespaces sequences vectors words quotations hashtables
|
||||||
|
combinators classes generic.math continuations optimizer.def-use
|
||||||
|
optimizer.backend generic.standard ;
|
||||||
IN: optimizer.control
|
IN: optimizer.control
|
||||||
|
|
||||||
|
! ! ! Loop detection
|
||||||
|
|
||||||
|
! A LOOP
|
||||||
|
!
|
||||||
|
! #label A
|
||||||
|
! |
|
||||||
|
! #if ----> #merge ----> #return
|
||||||
|
! |
|
||||||
|
! -------------
|
||||||
|
! | |
|
||||||
|
! #call-label A |
|
||||||
|
! | ...
|
||||||
|
! #values
|
||||||
|
!
|
||||||
|
! NOT A LOOP (call to A not in tail position):
|
||||||
|
!
|
||||||
|
!
|
||||||
|
! #label A
|
||||||
|
! |
|
||||||
|
! #if ----> ... ----> #merge ----> #return
|
||||||
|
! |
|
||||||
|
! -------------
|
||||||
|
! | |
|
||||||
|
! #call-label A |
|
||||||
|
! | ...
|
||||||
|
! ...
|
||||||
|
! |
|
||||||
|
! #values
|
||||||
|
!
|
||||||
|
! NOT A LOOP (call to A nested inside another label/loop):
|
||||||
|
!
|
||||||
|
!
|
||||||
|
! #label A
|
||||||
|
! |
|
||||||
|
! #if ----> #merge ----> ... ----> #return
|
||||||
|
! |
|
||||||
|
! -------------
|
||||||
|
! | |
|
||||||
|
! ... #label B
|
||||||
|
! |
|
||||||
|
! #if -> ...
|
||||||
|
! |
|
||||||
|
! ---------
|
||||||
|
! | |
|
||||||
|
! #call-label A |
|
||||||
|
! | |
|
||||||
|
! ... ...
|
||||||
|
|
||||||
GENERIC: detect-loops* ( node -- )
|
GENERIC: detect-loops* ( node -- )
|
||||||
|
|
||||||
M: node detect-loops* drop ;
|
M: node detect-loops* drop ;
|
||||||
|
|
@ -34,3 +85,201 @@ M: #call-label detect-loops*
|
||||||
|
|
||||||
: detect-loops ( node -- )
|
: detect-loops ( node -- )
|
||||||
[ detect-loops* ] each-node ;
|
[ detect-loops* ] each-node ;
|
||||||
|
|
||||||
|
! ! ! Constant branch folding
|
||||||
|
!
|
||||||
|
! BEFORE
|
||||||
|
!
|
||||||
|
! #if ----> #merge ----> C
|
||||||
|
! |
|
||||||
|
! ---------
|
||||||
|
! | |
|
||||||
|
! A B
|
||||||
|
! | |
|
||||||
|
! #values |
|
||||||
|
! #values
|
||||||
|
!
|
||||||
|
! AFTER
|
||||||
|
!
|
||||||
|
! |
|
||||||
|
! A
|
||||||
|
! |
|
||||||
|
! #values
|
||||||
|
! |
|
||||||
|
! #merge
|
||||||
|
! |
|
||||||
|
! C
|
||||||
|
|
||||||
|
: fold-branch ( node branch# -- node )
|
||||||
|
over node-children nth
|
||||||
|
swap node-successor over splice-node ;
|
||||||
|
|
||||||
|
! #if
|
||||||
|
: known-boolean-value? ( node value -- value ? )
|
||||||
|
2dup node-literal? [
|
||||||
|
node-literal t
|
||||||
|
] [
|
||||||
|
node-class {
|
||||||
|
{ [ dup null class< ] [ drop f f ] }
|
||||||
|
{ [ dup general-t class< ] [ drop t t ] }
|
||||||
|
{ [ dup \ f class< ] [ drop f t ] }
|
||||||
|
{ [ t ] [ drop f f ] }
|
||||||
|
} cond
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: fold-if-branch? dup node-in-d first known-boolean-value? ;
|
||||||
|
|
||||||
|
: fold-if-branch ( node value -- node' )
|
||||||
|
over drop-inputs >r
|
||||||
|
0 1 ? fold-branch
|
||||||
|
r> [ set-node-successor ] keep ;
|
||||||
|
|
||||||
|
! ! ! Lifting code after a conditional if one branch throws
|
||||||
|
: only-one ( seq -- elt/f )
|
||||||
|
dup length 1 = [ first ] [ drop f ] if ;
|
||||||
|
|
||||||
|
: lift-throw-tail? ( #if -- tail/? )
|
||||||
|
dup node-successor #tail?
|
||||||
|
[ drop f ] [ active-children only-one ] if ;
|
||||||
|
|
||||||
|
: clone-node ( node -- newnode )
|
||||||
|
clone dup [ clone ] modify-values ;
|
||||||
|
|
||||||
|
: detach-node-successor ( node -- successor )
|
||||||
|
dup node-successor #terminate rot set-node-successor ;
|
||||||
|
|
||||||
|
! BEFORE
|
||||||
|
!
|
||||||
|
! #if ----> #merge ----> B ----> #return/#values
|
||||||
|
! |
|
||||||
|
! |
|
||||||
|
! ---------
|
||||||
|
! | |
|
||||||
|
! | A
|
||||||
|
! #terminate |
|
||||||
|
! #values
|
||||||
|
!
|
||||||
|
! AFTER
|
||||||
|
!
|
||||||
|
! #if ----> #merge (*) ----> #return/#values (**)
|
||||||
|
! |
|
||||||
|
! |
|
||||||
|
! ---------
|
||||||
|
! | |
|
||||||
|
! | A
|
||||||
|
! #terminate |
|
||||||
|
! #values
|
||||||
|
! |
|
||||||
|
! #merge (***)
|
||||||
|
! |
|
||||||
|
! B
|
||||||
|
! |
|
||||||
|
! #return/#values
|
||||||
|
!
|
||||||
|
! (*) has the same outputs as the inputs of (**), and it is not
|
||||||
|
! the same node as (***)
|
||||||
|
!
|
||||||
|
! Note: if (**) is #return is is sound to put #terminate there,
|
||||||
|
! but not if (**) is #values
|
||||||
|
|
||||||
|
: lift-branch
|
||||||
|
over
|
||||||
|
last-node clone-node
|
||||||
|
dup node-in-d \ #merge out-node
|
||||||
|
[ set-node-successor ] keep -rot
|
||||||
|
>r dup node-successor r> splice-node
|
||||||
|
set-node-successor ;
|
||||||
|
|
||||||
|
M: #if optimize-node*
|
||||||
|
dup fold-if-branch? [ fold-if-branch t ] [
|
||||||
|
drop dup lift-throw-tail? dup [
|
||||||
|
dupd lift-branch t
|
||||||
|
] [
|
||||||
|
2drop t f
|
||||||
|
] if
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: fold-dispatch-branch? dup node-in-d first tuck node-literal? ;
|
||||||
|
|
||||||
|
: fold-dispatch-branch ( node value -- node' )
|
||||||
|
dupd node-literal
|
||||||
|
over drop-inputs >r fold-branch r>
|
||||||
|
[ set-node-successor ] keep ;
|
||||||
|
|
||||||
|
M: #dispatch optimize-node*
|
||||||
|
dup fold-dispatch-branch? [
|
||||||
|
fold-dispatch-branch t
|
||||||
|
] [
|
||||||
|
2drop t f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
! Loop tail hoising: code after a loop can sometimes go in the
|
||||||
|
! non-recursive branch of the loop
|
||||||
|
|
||||||
|
! BEFORE:
|
||||||
|
|
||||||
|
! #label -> C -> #return 1
|
||||||
|
! |
|
||||||
|
! -> #if -> #merge -> #return 2
|
||||||
|
! |
|
||||||
|
! --------
|
||||||
|
! | |
|
||||||
|
! A B
|
||||||
|
! | |
|
||||||
|
! #values |
|
||||||
|
! #call-label
|
||||||
|
! |
|
||||||
|
! |
|
||||||
|
! #values
|
||||||
|
|
||||||
|
! AFTER:
|
||||||
|
|
||||||
|
! #label -> #terminate
|
||||||
|
! |
|
||||||
|
! -> #if -> #terminate
|
||||||
|
! |
|
||||||
|
! --------
|
||||||
|
! | |
|
||||||
|
! A B
|
||||||
|
! | |
|
||||||
|
! #values |
|
||||||
|
! | #call-label
|
||||||
|
! #merge |
|
||||||
|
! | |
|
||||||
|
! C #values
|
||||||
|
! |
|
||||||
|
! #return 1
|
||||||
|
|
||||||
|
: find-final-if ( node -- #if/f )
|
||||||
|
dup [
|
||||||
|
dup #if? [
|
||||||
|
dup node-successor #tail? [
|
||||||
|
node-successor find-final-if
|
||||||
|
] unless
|
||||||
|
] [
|
||||||
|
node-successor find-final-if
|
||||||
|
] if
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: lift-loop-tail? ( #label -- tail/f )
|
||||||
|
dup node-successor node-successor [
|
||||||
|
dup node-param swap node-child find-final-if dup [
|
||||||
|
node-children [ penultimate-node ] map
|
||||||
|
[
|
||||||
|
dup #call-label?
|
||||||
|
[ node-param eq? not ] [ 2drop t ] if
|
||||||
|
] with subset only-one
|
||||||
|
] [ 2drop f ] if
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
||||||
|
! M: #loop optimize-node*
|
||||||
|
! dup lift-loop-tail? dup [
|
||||||
|
! last-node >r
|
||||||
|
! dup detach-node-successor
|
||||||
|
! over node-child find-final-if detach-node-successor
|
||||||
|
! [ set-node-successor ] keep
|
||||||
|
! r> set-node-successor
|
||||||
|
! t
|
||||||
|
! ] [
|
||||||
|
! 2drop t f
|
||||||
|
! ] if ;
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,227 @@
|
||||||
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: arrays generic assocs inference inference.class
|
||||||
|
inference.dataflow inference.backend inference.state io kernel
|
||||||
|
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 ;
|
||||||
|
IN: optimizer.inlining
|
||||||
|
|
||||||
|
GENERIC: remember-method* ( method-spec 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 )
|
||||||
|
over node-in-d dataflow-with
|
||||||
|
[ swap infer-classes/node ] 2keep
|
||||||
|
[ splice-node ] keep ;
|
||||||
|
|
||||||
|
! #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 ;
|
||||||
|
|
||||||
|
! 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 ;
|
||||||
|
|
||||||
|
: (flat-length) ( seq -- n )
|
||||||
|
[
|
||||||
|
{
|
||||||
|
{ [ dup quotation? ] [ (flat-length) 1+ ] }
|
||||||
|
{ [ dup array? ] [ (flat-length) ] }
|
||||||
|
{ [ dup word? ] [ word-flat-length ] }
|
||||||
|
{ [ t ] [ drop 1 ] }
|
||||||
|
} cond
|
||||||
|
] map sum ;
|
||||||
|
|
||||||
|
: 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 ;
|
||||||
|
|
||||||
|
: inline-standard-method ( node word -- node )
|
||||||
|
dupd will-inline-method splice-method ;
|
||||||
|
|
||||||
|
! 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 ;
|
||||||
|
|
||||||
|
: inline-method ( #call -- node )
|
||||||
|
dup node-param {
|
||||||
|
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||||
|
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||||
|
{ [ t ] [ 2drop t ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
! Resolve type checks at compile time where possible
|
||||||
|
: comparable? ( actual testing -- ? )
|
||||||
|
#! If actual is a subset of testing or if the two classes
|
||||||
|
#! are disjoint, return t.
|
||||||
|
2dup class< >r classes-intersect? not r> or ;
|
||||||
|
|
||||||
|
: optimize-predicate? ( #call -- ? )
|
||||||
|
dup node-param "predicating" word-prop dup [
|
||||||
|
>r node-class-first r> comparable?
|
||||||
|
] [
|
||||||
|
2drop f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: literal-quot ( node literals -- quot )
|
||||||
|
#! Outputs a quotation which drops the node's inputs, and
|
||||||
|
#! pushes some literals.
|
||||||
|
>r node-in-d length \ drop <repetition>
|
||||||
|
r> [ literalize ] map append >quotation ;
|
||||||
|
|
||||||
|
: inline-literals ( node literals -- node )
|
||||||
|
#! Make #shuffle -> #push -> #return -> successor
|
||||||
|
dupd literal-quot splice-quot ;
|
||||||
|
|
||||||
|
: evaluate-predicate ( #call -- ? )
|
||||||
|
dup node-param "predicating" word-prop >r
|
||||||
|
node-class-first r> class< ;
|
||||||
|
|
||||||
|
: optimize-predicate ( #call -- node )
|
||||||
|
#! If the predicate is followed by a branch we fold it
|
||||||
|
#! immediately
|
||||||
|
dup evaluate-predicate swap
|
||||||
|
dup node-successor #if? [
|
||||||
|
dup drop-inputs >r
|
||||||
|
node-successor swap 0 1 ? fold-branch
|
||||||
|
r> [ set-node-successor ] keep
|
||||||
|
] [
|
||||||
|
swap 1array inline-literals
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: optimizer-hooks ( node -- conditions )
|
||||||
|
node-param "optimizer-hooks" word-prop ;
|
||||||
|
|
||||||
|
: optimizer-hook ( node -- pair/f )
|
||||||
|
dup optimizer-hooks [ first call ] find 2nip ;
|
||||||
|
|
||||||
|
: optimize-hook ( node -- )
|
||||||
|
dup optimizer-hook second call ;
|
||||||
|
|
||||||
|
: define-optimizers ( word optimizers -- )
|
||||||
|
"optimizer-hooks" set-word-prop ;
|
||||||
|
|
||||||
|
: flush-eval? ( #call -- ? )
|
||||||
|
dup node-param "flushable" word-prop [
|
||||||
|
node-out-d [ unused? ] all?
|
||||||
|
] [
|
||||||
|
drop f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: flush-eval ( #call -- node )
|
||||||
|
dup node-param +inlined+ depends-on
|
||||||
|
dup node-out-d length f <repetition> inline-literals ;
|
||||||
|
|
||||||
|
: partial-eval? ( #call -- ? )
|
||||||
|
dup node-param "foldable" word-prop [
|
||||||
|
dup node-in-d [ node-literal? ] with all?
|
||||||
|
] [
|
||||||
|
drop f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: literal-in-d ( #call -- inputs )
|
||||||
|
dup node-in-d [ node-literal ] with map ;
|
||||||
|
|
||||||
|
: partial-eval ( #call -- node )
|
||||||
|
dup node-param +inlined+ depends-on
|
||||||
|
dup literal-in-d over node-param 1quotation
|
||||||
|
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
|
||||||
|
|
||||||
|
: define-identities ( words identities -- )
|
||||||
|
[ "identities" set-word-prop ] curry each ;
|
||||||
|
|
||||||
|
: find-identity ( node -- quot )
|
||||||
|
[ node-param "identities" word-prop ] keep
|
||||||
|
[ swap first in-d-match? ] curry find
|
||||||
|
nip dup [ second ] when ;
|
||||||
|
|
||||||
|
: apply-identities ( node -- node/f )
|
||||||
|
dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
: optimistic-inline? ( #call -- ? )
|
||||||
|
dup node-param "specializer" word-prop dup [
|
||||||
|
>r node-input-classes r> specialized-length tail*
|
||||||
|
[ types length 1 = ] all?
|
||||||
|
] [
|
||||||
|
2drop f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: optimistic-inline ( #call -- node )
|
||||||
|
dup node-param dup +inlined+ depends-on
|
||||||
|
word-def splice-quot ;
|
||||||
|
|
||||||
|
: method-body-inline? ( #call -- ? )
|
||||||
|
node-param dup method-body?
|
||||||
|
[ flat-length 8 <= ] [ drop f ] if ;
|
||||||
|
|
||||||
|
M: #call optimize-node*
|
||||||
|
{
|
||||||
|
{ [ dup flush-eval? ] [ flush-eval ] }
|
||||||
|
{ [ dup partial-eval? ] [ partial-eval ] }
|
||||||
|
{ [ dup find-identity ] [ apply-identities ] }
|
||||||
|
{ [ dup optimizer-hook ] [ optimize-hook ] }
|
||||||
|
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
|
||||||
|
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
|
||||||
|
{ [ dup method-body-inline? ] [ optimistic-inline ] }
|
||||||
|
{ [ t ] [ inline-method ] }
|
||||||
|
} cond dup not ;
|
||||||
|
|
@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
|
||||||
io.streams.string layouts splitting math.intervals
|
io.streams.string layouts splitting math.intervals
|
||||||
math.floats.private tuples tuples.private classes
|
math.floats.private tuples tuples.private classes
|
||||||
optimizer.def-use optimizer.backend optimizer.pattern-match
|
optimizer.def-use optimizer.backend optimizer.pattern-match
|
||||||
float-arrays sequences.private combinators ;
|
optimizer.inlining float-arrays sequences.private combinators ;
|
||||||
|
|
||||||
! the output of <tuple> and <tuple-boa> has the class which is
|
! the output of <tuple> and <tuple-boa> has the class which is
|
||||||
! its second-to-last input
|
! its second-to-last input
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,7 @@ inference.class inference.dataflow vectors strings sbufs io
|
||||||
namespaces assocs quotations math.intervals sequences.private
|
namespaces assocs quotations math.intervals sequences.private
|
||||||
combinators splitting layouts math.parser classes generic.math
|
combinators splitting layouts math.parser classes generic.math
|
||||||
optimizer.pattern-match optimizer.backend optimizer.def-use
|
optimizer.pattern-match optimizer.backend optimizer.def-use
|
||||||
generic.standard system ;
|
optimizer.inlining generic.standard system ;
|
||||||
|
|
||||||
{ + bignum+ float+ fixnum+fast } {
|
{ + bignum+ float+ fixnum+fast } {
|
||||||
{ { number 0 } [ drop ] }
|
{ { number 0 } [ drop ] }
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
|
||||||
kernel.private math optimizer prettyprint sequences sbufs
|
kernel.private math optimizer prettyprint sequences sbufs
|
||||||
strings tools.test vectors words sequences.private quotations
|
strings tools.test vectors words sequences.private quotations
|
||||||
optimizer.backend classes inference.dataflow tuples.private
|
optimizer.backend classes inference.dataflow tuples.private
|
||||||
continuations growable ;
|
continuations growable optimizer.inlining ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
|
||||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel namespaces optimizer.backend optimizer.def-use
|
USING: kernel namespaces optimizer.backend optimizer.def-use
|
||||||
optimizer.known-words optimizer.math optimizer.control
|
optimizer.known-words optimizer.math optimizer.control
|
||||||
inference.class ;
|
optimizer.inlining inference.class ;
|
||||||
IN: optimizer
|
IN: optimizer
|
||||||
|
|
||||||
: optimize-1 ( node -- newnode ? )
|
: optimize-1 ( node -- newnode ? )
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue