#loop optimization fixes
Slava Pestov
parent
3694064f41
commit
f9c76689d6
core
generator
optimizer/control
|
|
@ -26,7 +26,7 @@ SYMBOL: compiling-word
|
|||
|
||||
SYMBOL: compiling-label
|
||||
|
||||
SYMBOL: compiling-loop?
|
||||
SYMBOL: compiling-loops
|
||||
|
||||
! Label of current word, after prologue, makes recursion faster
|
||||
SYMBOL: current-label-start
|
||||
|
|
@ -34,7 +34,7 @@ SYMBOL: current-label-start
|
|||
: compiled-stack-traces? ( -- ? ) 36 getenv ;
|
||||
|
||||
: begin-compiling ( word label -- )
|
||||
compiling-loop? off
|
||||
H{ } clone compiling-loops set
|
||||
compiling-label set
|
||||
compiling-word set
|
||||
compiled-stack-traces?
|
||||
|
|
@ -94,8 +94,8 @@ M: node generate-node drop iterate-next ;
|
|||
: generate-call ( label -- next )
|
||||
dup maybe-compile
|
||||
end-basic-block
|
||||
dup compiling-label get eq? compiling-loop? get and [
|
||||
drop current-label-start get %jump-label f
|
||||
dup compiling-loops get at [
|
||||
%jump-label f
|
||||
] [
|
||||
tail-call? [
|
||||
%jump f
|
||||
|
|
@ -104,7 +104,7 @@ M: node generate-node drop iterate-next ;
|
|||
%call
|
||||
iterate-next
|
||||
] if
|
||||
] if ;
|
||||
] ?if ;
|
||||
|
||||
! #label
|
||||
M: #label generate-node
|
||||
|
|
@ -113,17 +113,13 @@ M: #label generate-node
|
|||
r> ;
|
||||
|
||||
! #loop
|
||||
: compiling-loop ( word -- )
|
||||
<label> dup resolve-label swap compiling-loops get set-at ;
|
||||
|
||||
M: #loop generate-node
|
||||
end-basic-block
|
||||
[
|
||||
dup node-param compiling-label set
|
||||
current-label-start define-label
|
||||
current-label-start resolve-label
|
||||
compiling-loop? on
|
||||
node-child generate-nodes
|
||||
end-basic-block
|
||||
] with-scope
|
||||
init-templates
|
||||
dup node-param compiling-loop
|
||||
node-child generate-nodes
|
||||
iterate-next ;
|
||||
|
||||
! #if
|
||||
|
|
@ -269,5 +265,6 @@ M: #r> generate-node
|
|||
|
||||
! #return
|
||||
M: #return generate-node
|
||||
node-param compiling-label get eq? compiling-loop? get and
|
||||
[ end-basic-block %return ] unless f ;
|
||||
end-basic-block
|
||||
node-param compiling-loops get key?
|
||||
[ %return ] unless f ;
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@ optimizer ;
|
|||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ [ [ ] map ] map ] dataflow optimize
|
||||
[ [ [ ] map ] map ] dataflow dup detect-loops
|
||||
[ dup #label? swap #loop? not and ] node-exists?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -146,3 +146,36 @@ DEFER: a
|
|||
[ a ] dataflow dup detect-loops
|
||||
\ b label-is-loop?
|
||||
] 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
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ combinators classes generic.math continuations optimizer.def-use
|
|||
optimizer.backend generic.standard ;
|
||||
IN: optimizer.control
|
||||
|
||||
! ! ! Loop detection
|
||||
! ! ! Rudimentary CFA
|
||||
|
||||
! A LOOP
|
||||
!
|
||||
|
|
@ -36,7 +36,8 @@ IN: optimizer.control
|
|||
! |
|
||||
! #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
|
||||
|
|
@ -53,38 +54,70 @@ IN: optimizer.control
|
|||
! | |
|
||||
! #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 -- )
|
||||
f swap set-#label-loop? ;
|
||||
USE: prettyprint
|
||||
|
||||
: tail-call? ( -- ? )
|
||||
node-stack get
|
||||
dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail
|
||||
[ node-successor #tail? ] all? ;
|
||||
USE: io
|
||||
: detect-loop ( seen-other? label node -- seen-other? continue? )
|
||||
#! 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 collect-label-info*
|
||||
node-param label-info get at
|
||||
node-stack get over third tail
|
||||
[ [ #label? ] subset [ node-param ] map ] keep
|
||||
[ node-successor #tail? ] all? 2array
|
||||
swap second push ;
|
||||
|
||||
M: #call-label detect-loops*
|
||||
f swap node-param node-stack get <reversed>
|
||||
[ detect-loop ] with all? 2drop ;
|
||||
M: node collect-label-info*
|
||||
drop ;
|
||||
|
||||
: detect-loops ( node -- )
|
||||
[ detect-loops* ] each-node ;
|
||||
: collect-label-info ( 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
|
||||
!
|
||||
|
|
@ -204,7 +237,7 @@ M: #if optimize-node*
|
|||
|
||||
! #label -> C -> #return 1
|
||||
! |
|
||||
! -> #if -> #merge -> #return 2
|
||||
! -> #if -> #merge (*) -> #return 2
|
||||
! |
|
||||
! --------
|
||||
! | |
|
||||
|
|
@ -218,19 +251,19 @@ M: #if optimize-node*
|
|||
|
||||
! AFTER:
|
||||
|
||||
! #label -> #terminate
|
||||
! |
|
||||
! -> #if -> #terminate
|
||||
! #label -> #return 1
|
||||
! |
|
||||
! --------
|
||||
! | |
|
||||
! A B
|
||||
! | |
|
||||
! #values |
|
||||
! | #call-label
|
||||
! #merge |
|
||||
! | |
|
||||
! C #values
|
||||
! -> #if -------> #merge (*) -> #return 2
|
||||
! | \-------------------/
|
||||
! ---------------- |
|
||||
! | | |
|
||||
! A B unreacachable code needed to
|
||||
! | | preserve invariants
|
||||
! #values |
|
||||
! | #call-label
|
||||
! #merge (*) |
|
||||
! | |
|
||||
! C #values
|
||||
! |
|
||||
! #return 1
|
||||
|
||||
|
|
@ -282,14 +315,22 @@ M: node add-loop-exit*
|
|||
] [ 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 ;
|
||||
M: #loop optimize-node*
|
||||
dup lift-loop-tail? dup [
|
||||
last-node "values" set
|
||||
|
||||
dup node-successor "tail" set
|
||||
dup node-successor last-node "return" set
|
||||
dup node-child find-final-if node-successor "merge" set
|
||||
|
||||
! #label -> #return
|
||||
"return" get clone-node over set-node-successor
|
||||
! #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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue