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

#loop optimization fixes

db4
Slava Pestov 2008-02-15 18:07:56 -06:00
parent 3694064f41
commit f9c76689d6
3 changed files with 139 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
core/generator/generator.factor
View File

@ -26,7 +26,7 @@ SYMBOL: compiling-word
SYMBOL: compiling-label SYMBOL: compiling-label
SYMBOL: compiling-loop? SYMBOL: compiling-loops
! Label of current word, after prologue, makes recursion faster ! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start SYMBOL: current-label-start
@ -34,7 +34,7 @@ SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ; : compiled-stack-traces? ( -- ? ) 36 getenv ;
: begin-compiling ( word label -- ) : begin-compiling ( word label -- )
compiling-loop? off H{ } clone compiling-loops set
compiling-label set compiling-label set
compiling-word set compiling-word set
compiled-stack-traces? compiled-stack-traces?
@ -94,8 +94,8 @@ M: node generate-node drop iterate-next ;
: generate-call ( label -- next ) : generate-call ( label -- next )
dup maybe-compile dup maybe-compile
end-basic-block end-basic-block
dup compiling-label get eq? compiling-loop? get and [ dup compiling-loops get at [
drop current-label-start get %jump-label f %jump-label f
] [ ] [
tail-call? [ tail-call? [
%jump f %jump f
@ -104,7 +104,7 @@ M: node generate-node drop iterate-next ;
%call %call
iterate-next iterate-next
] if ] if
] if ; ] ?if ;
! #label ! #label
M: #label generate-node M: #label generate-node
@ -113,17 +113,13 @@ M: #label generate-node
r> ; r> ;
! #loop ! #loop
: compiling-loop ( word -- )
<label> dup resolve-label swap compiling-loops get set-at ;
M: #loop generate-node M: #loop generate-node
end-basic-block end-basic-block
[ dup node-param compiling-loop
dup node-param compiling-label set node-child generate-nodes
current-label-start define-label
current-label-start resolve-label
compiling-loop? on
node-child generate-nodes
end-basic-block
] with-scope
init-templates
iterate-next ; iterate-next ;
! #if ! #if
@ -269,5 +265,6 @@ M: #r> generate-node
! #return ! #return
M: #return generate-node M: #return generate-node
node-param compiling-label get eq? compiling-loop? get and end-basic-block
[ end-basic-block %return ] unless f ; node-param compiling-loops get key?
[ %return ] unless f ;

35
core/optimizer/control/control-tests.factor Normal file → Executable file
View File

@ -113,7 +113,7 @@ optimizer ;
] unit-test ] unit-test
[ f ] [ [ f ] [
[ [ [ ] map ] map ] dataflow optimize [ [ [ ] map ] map ] dataflow dup detect-loops
[ dup #label? swap #loop? not and ] node-exists? [ dup #label? swap #loop? not and ] node-exists?
] unit-test ] unit-test
@ -146,3 +146,36 @@ DEFER: a
[ a ] dataflow dup detect-loops [ a ] dataflow dup detect-loops
\ b label-is-loop? \ b label-is-loop?
] unit-test ] unit-test
DEFER: a'
: b' ( -- )
blah [ b' b' ] [ a' ] if ; inline
: a' ( -- )
blah [ b' ] [ a' ] if ; inline
[ f ] [
[ a' ] dataflow dup detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ b' ] dataflow dup detect-loops
\ b' label-is-loop?
] unit-test
! I used to think this should be f, but doing this on pen and
! paper almost convinced me that a loop conversion here is
! sound. The loop analysis algorithm looks pretty solid -- its
! a standard iterative dataflow problem after all -- so I'm
! tempted to believe the computer here
[ t ] [
[ b' ] dataflow dup detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ a' ] dataflow dup detect-loops
\ b' label-is-loop?
] unit-test

143
core/optimizer/control/control.factor
View File

@ -7,7 +7,7 @@ combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard ; optimizer.backend generic.standard ;
IN: optimizer.control IN: optimizer.control
! ! ! Loop detection ! ! ! Rudimentary CFA
! A LOOP ! A LOOP
! !
@ -36,7 +36,8 @@ IN: optimizer.control
! | ! |
! #values ! #values
! !
! NOT A LOOP (call to A nested inside another label/loop): ! NOT A LOOP (call to A nested inside another label which is
! not a loop):
! !
! !
! #label A ! #label A
@ -53,38 +54,70 @@ IN: optimizer.control
! | | ! | |
! #call-label A | ! #call-label A |
! | | ! | |
! ... ... ! #values |
! #call-label B
! |
! ...
GENERIC: detect-loops* ( node -- ) ! Mapping word => { node { nesting tail? }+ height }
! We record all calls to a label, their control nesting and
! whether it is a tail call or not
SYMBOL: label-info
M: node detect-loops* drop ; GENERIC: collect-label-info* ( node -- )
M: #label detect-loops* t swap set-#label-loop? ; M: #label collect-label-info*
[ V{ } clone node-stack get length 3array ] keep
node-param label-info get set-at ;
: not-a-loop ( #label -- ) USE: prettyprint
f swap set-#label-loop? ;
: tail-call? ( -- ? ) M: #call-label collect-label-info*
node-stack get node-param label-info get at
dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail node-stack get over third tail
[ node-successor #tail? ] all? ; [ [ #label? ] subset [ node-param ] map ] keep
USE: io [ node-successor #tail? ] all? 2array
: detect-loop ( seen-other? label node -- seen-other? continue? ) swap second push ;
#! seen-other?: have we seen another label?
{
{ [ dup #label? not ] [ 2drop t ] }
{ [ 2dup node-param eq? not ] [ 3drop t t ] }
{ [ tail-call? not ] [ not-a-loop drop f ] }
{ [ pick ] [ not-a-loop drop f ] }
{ [ t ] [ 2drop f ] }
} cond ;
M: #call-label detect-loops* M: node collect-label-info*
f swap node-param node-stack get <reversed> drop ;
[ detect-loop ] with all? 2drop ;
: detect-loops ( node -- ) : collect-label-info ( node -- )
[ detect-loops* ] each-node ; H{ } clone label-info set
[ collect-label-info* ] each-node ;
! Mapping word => label
SYMBOL: potential-loops
: remove-non-tail-calls ( -- )
label-info get
[ nip second [ second ] all? ] assoc-subset
[ first ] assoc-map
potential-loops set ;
: remove-non-loop-calls ( -- )
! Boolean is set to t if something changed.
! We recurse until a fixed point is reached.
f label-info get [
! If label X is called from within a label Y that is
! no longer a potential loop, then X is no longer a
! potential loop either.
over potential-loops get key? [
second [ first ] map concat
potential-loops get [ key? ] curry all?
[ drop ] [ potential-loops get delete-at t or ] if
] [ 2drop ] if
] assoc-each [ remove-non-loop-calls ] when ;
: detect-loops ( nodes -- )
[
collect-label-info
remove-non-tail-calls
remove-non-loop-calls
potential-loops get [
nip t swap set-#label-loop?
] assoc-each
] with-scope ;
! ! ! Constant branch folding ! ! ! Constant branch folding
! !
@ -204,7 +237,7 @@ M: #if optimize-node*
! #label -> C -> #return 1 ! #label -> C -> #return 1
! | ! |
! -> #if -> #merge -> #return 2 ! -> #if -> #merge (*) -> #return 2
! | ! |
! -------- ! --------
! | | ! | |
@ -218,19 +251,19 @@ M: #if optimize-node*
! AFTER: ! AFTER:
! #label -> #terminate ! #label -> #return 1
! |
! -> #if -> #terminate
! | ! |
! -------- ! -> #if -------> #merge (*) -> #return 2
! | | ! | \-------------------/
! A B ! ---------------- |
! | | ! | | |
! #values | ! A B unreacachable code needed to
! | #call-label ! | | preserve invariants
! #merge | ! #values |
! | | ! | #call-label
! C #values ! #merge (*) |
! | |
! C #values
! | ! |
! #return 1 ! #return 1
@ -282,14 +315,22 @@ M: node add-loop-exit*
] [ 2drop f ] if ] [ 2drop f ] if
] [ drop f ] if ; ] [ drop f ] if ;
! M: #loop optimize-node* M: #loop optimize-node*
! dup lift-loop-tail? dup [ dup lift-loop-tail? dup [
! last-node >r last-node "values" set
! dup detach-node-successor
! over node-child find-final-if detach-node-successor dup node-successor "tail" set
! [ set-node-successor ] keep dup node-successor last-node "return" set
! r> set-node-successor dup node-child find-final-if node-successor "merge" set
! t
! ] [ ! #label -> #return
! 2drop t f "return" get clone-node over set-node-successor
! ] if ; ! #merge -> C
"merge" get clone-node "tail" get over set-node-successor
! #values -> #merge ->C
"values" get set-node-successor
t
] [
2drop t f
] if ;