Fix bug and clean up optimizer

db4
Slava Pestov 2008-02-13 20:07:08 -06:00
parent bb2684f3df
commit 6f1dc49fa8
7 changed files with 484 additions and 362 deletions

View File

@ -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 ;

255
core/optimizer/control/control.factor Normal file → Executable file
View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ] }

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 ;
continuations growable optimizer.inlining ;
IN: temporary
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [

View File

@ -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 ? )