Cleaner loop detection pass

db4
Slava Pestov 2008-08-10 19:22:13 -05:00
parent 215f6ef65b
commit bbd05723a5
1 changed files with 40 additions and 55 deletions

View File

@ -1,22 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences namespaces assocs accessors fry
compiler.tree ;
compiler.tree dequeues search-dequeues ;
IN: compiler.tree.loop.detection
! A loop is a #recursive which only tail calls itself, and those
! calls are nested inside other loops only.
TUPLE: recursive-call tail? nesting ;
! calls is a sequence of recursive-call instances
TUPLE: loop-info calls height ;
! Mapping inline-recursive instances to loop-info instances
SYMBOL: loop-infos
! A sequence of inline-recursive instances
SYMBOL: label-stack
! calls are nested inside other loops only. We optimistically
! assume all #recursive nodes are loops, disqualifying them as
! we see evidence to the contrary.
: (tail-calls) ( tail? seq -- seq' )
reverse [ swap [ and ] keep ] map nip reverse ;
@ -29,6 +20,11 @@ SYMBOL: label-stack
tri or or
] map (tail-calls) ;
SYMBOL: loop-heights
SYMBOL: loop-calls
SYMBOL: label-stack
SYMBOL: work-list
GENERIC: collect-loop-info* ( tail? node -- )
: non-tail-label-info ( nodes -- )
@ -37,24 +33,32 @@ GENERIC: collect-loop-info* ( tail? node -- )
: (collect-loop-info) ( tail? nodes -- )
[ tail-calls ] keep [ collect-loop-info* ] 2each ;
: remember-loop-info ( #recursive -- )
V{ } clone label-stack get length loop-info boa
swap label>> loop-infos get set-at ;
: remember-loop-info ( label -- )
label-stack get length swap loop-heights get set-at ;
M: #recursive collect-loop-info*
nip
[
[ label-stack [ swap label>> suffix ] change ]
[ remember-loop-info ]
[ t swap child>> (collect-loop-info) ]
tri
[
label>>
[ label-stack [ swap suffix ] change ]
[ remember-loop-info ]
[ t >>loop? drop ]
tri
]
[ t swap child>> (collect-loop-info) ] bi
] with-scope ;
: current-loop-nesting ( label -- labels )
label-stack get swap loop-heights get at tail ;
: disqualify-loop ( label -- )
work-list get push-front ;
M: #call-recursive collect-loop-info*
label>> loop-infos get at
[ label-stack get swap height>> tail recursive-call boa ]
[ calls>> ]
bi push ;
label>>
swap [ dup disqualify-loop ] unless
dup current-loop-nesting [ loop-calls get push-at ] with each ;
M: #if collect-loop-info*
children>> [ (collect-loop-info) ] with each ;
@ -66,38 +70,19 @@ M: node collect-loop-info* 2drop ;
: collect-loop-info ( node -- )
{ } label-stack set
H{ } clone loop-infos set
H{ } clone loop-calls set
H{ } clone loop-heights set
<hashed-dlist> work-list set
t swap (collect-loop-info) ;
! Sub-assoc of loop-infos
SYMBOL: potential-loops
: remove-non-tail-calls ( -- )
loop-infos get
[ nip calls>> [ tail?>> ] all? ] assoc-filter
potential-loops set ;
: (remove-non-loop-calls) ( loop-infos -- )
f over [
! 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? [
potential-loops get '[ , key? ] all?
[ drop ] [ potential-loops get delete-at t or ] if
] [ 2drop ] if
] assoc-each
[ (remove-non-loop-calls) ] [ drop ] if ;
: remove-non-loop-calls ( -- )
! Boolean is set to t if something changed.
! We recurse until a fixed point is reached.
loop-infos get [ calls>> [ nesting>> ] map concat ] assoc-map
(remove-non-loop-calls) ;
: disqualify-loops ( -- )
work-list get [
dup loop?>> [
[ f >>loop? drop ]
[ loop-calls get at [ disqualify-loop ] each ]
bi
] [ drop ] if
] slurp-dequeue ;
: detect-loops ( nodes -- nodes )
dup
collect-loop-info
remove-non-tail-calls
remove-non-loop-calls
potential-loops get [ drop t >>loop? drop ] assoc-each ;
dup collect-loop-info disqualify-loops ;