Fix bug and clean up optimizer
Slava Pestov
parent
bb2684f3df
commit
6f1dc49fa8
core/optimizer
backend
control
inlining
known-words
math
|
|
@ -3,8 +3,7 @@
|
|||
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.pattern-match generic.standard optimizer.specializers ;
|
||||
combinators classes optimizer.def-use ;
|
||||
IN: optimizer.backend
|
||||
|
||||
SYMBOL: class-substitutions
|
||||
|
|
@ -76,7 +75,6 @@ DEFER: optimize-nodes
|
|||
optimizer-changed get
|
||||
] with-scope optimizer-changed set ;
|
||||
|
||||
! Generic nodes
|
||||
M: node optimize-node* drop t f ;
|
||||
|
||||
! Post-inlining cleanup
|
||||
|
|
@ -112,362 +110,10 @@ M: #return optimize-node* cleanup-inlining ;
|
|||
! #values
|
||||
M: #values optimize-node* cleanup-inlining ;
|
||||
|
||||
! Some utilities for splicing in dataflow IR subtrees
|
||||
M: f set-node-successor 2drop ;
|
||||
|
||||
: splice-node ( old new -- )
|
||||
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 )
|
||||
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.
|
||||
USING: kernel inference.dataflow combinators sequences
|
||||
namespaces math ;
|
||||
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 ;
|
||||
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 -- )
|
||||
|
||||
M: node detect-loops* drop ;
|
||||
|
|
@ -34,3 +85,201 @@ M: #call-label detect-loops*
|
|||
|
||||
: detect-loops ( 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
|
||||
math.floats.private tuples tuples.private classes
|
||||
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
|
||||
! its second-to-last input
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ inference.class inference.dataflow vectors strings sbufs io
|
|||
namespaces assocs quotations math.intervals sequences.private
|
||||
combinators splitting layouts math.parser classes generic.math
|
||||
optimizer.pattern-match optimizer.backend optimizer.def-use
|
||||
generic.standard system ;
|
||||
optimizer.inlining generic.standard system ;
|
||||
|
||||
{ + bignum+ float+ fixnum+fast } {
|
||||
{ { number 0 } [ drop ] }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
continuations growable optimizer.inlining ;
|
||||
IN: temporary
|
||||
|
||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces optimizer.backend optimizer.def-use
|
||||
optimizer.known-words optimizer.math optimizer.control
|
||||
inference.class ;
|
||||
optimizer.inlining inference.class ;
|
||||
IN: optimizer
|
||||
|
||||
: optimize-1 ( node -- newnode ? )
|
||||
|
|
|
|||
Loading…
Reference in New Issue