Perform loop detection before normalization, clean up normalization pass, more aggressive recursive return value propagation. Fixes regression on nsieve benchmark

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -10,12 +10,13 @@ compiler.tree
 compiler.tree.combinators
 compiler.tree.cleanup
 compiler.tree.builder
+compiler.tree.recursive
 compiler.tree.normalization
 compiler.tree.propagation
 compiler.tree.checker ;
 
 : cleaned-up-tree ( quot -- nodes )
-    build-tree normalize propagate cleanup dup check-nodes ;
+    build-tree analyze-recursive normalize propagate cleanup dup check-nodes ;
 
 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
 

basis/compiler/tree/dead-code/dead-code-tests.factor

@@ -3,16 +3,17 @@ compiler.tree.dead-code compiler.tree.def-use compiler.tree
 compiler.tree.combinators compiler.tree.propagation
 compiler.tree.cleanup compiler.tree.escape-analysis
 compiler.tree.tuple-unboxing compiler.tree.debugger
-compiler.tree.normalization compiler.tree.checker tools.test
-kernel math stack-checker.state accessors combinators io
-prettyprint words sequences.deep sequences.private arrays
-classes kernel.private ;
+compiler.tree.recursive compiler.tree.normalization
+compiler.tree.checker tools.test kernel math stack-checker.state
+accessors combinators io prettyprint words sequences.deep
+sequences.private arrays classes kernel.private ;
 IN: compiler.tree.dead-code.tests
 
 \ remove-dead-code must-infer
 
 : count-live-values ( quot -- n )
     build-tree
+    analyze-recursive
     normalize
     propagate
     cleanup
@@ -64,6 +65,7 @@ IN: compiler.tree.dead-code.tests
 
 : optimize-quot ( quot -- quot' )
     build-tree
+    analyze-recursive
     normalize
     propagate
     cleanup

basis/compiler/tree/def-use/def-use-tests.factor

@@ -1,9 +1,10 @@
 USING: accessors namespaces assocs kernel sequences math
 tools.test words sets combinators.short-circuit
 stack-checker.state compiler.tree compiler.tree.builder
-compiler.tree.normalization compiler.tree.propagation
-compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
-sorting math.order binary-search compiler.tree.checker ;
+compiler.tree.recursive compiler.tree.normalization
+compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.def-use arrays kernel.private sorting math.order
+binary-search compiler.tree.checker ;
 IN: compiler.tree.def-use.tests
 
 \ compute-def-use must-infer
@@ -18,6 +19,7 @@ IN: compiler.tree.def-use.tests
 
 : test-def-use ( quot -- )
     build-tree
+    analyze-recursive
     normalize
     propagate
     cleanup
@@ -27,7 +29,14 @@ IN: compiler.tree.def-use.tests
 : too-deep ( a b -- c )
     dup [ drop ] [ 2dup too-deep too-deep drop ] if ; inline recursive
 
-[ ] [ [ too-deep ] build-tree normalize compute-def-use check-nodes ] unit-test
+[ ] [
+    [ too-deep ]
+    build-tree
+    analyze-recursive
+    normalize
+    compute-def-use
+    check-nodes
+] unit-test
 
 ! compute-def-use checks for SSA violations, so we use that to
 ! ensure we generate some common patterns correctly.

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -1,13 +1,14 @@
 IN: compiler.tree.escape-analysis.tests
 USING: compiler.tree.escape-analysis
 compiler.tree.escape-analysis.allocations compiler.tree.builder
-compiler.tree.normalization math.functions
-compiler.tree.propagation compiler.tree.cleanup
-compiler.tree.combinators compiler.tree sequences math math.private
-kernel tools.test accessors slots.private quotations.private
-prettyprint classes.tuple.private classes classes.tuple
-compiler.intrinsics namespaces compiler.tree.propagation.info
-stack-checker.errors kernel.private ;
+compiler.tree.recursive compiler.tree.normalization
+math.functions compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.combinators compiler.tree sequences math
+math.private kernel tools.test accessors slots.private
+quotations.private prettyprint classes.tuple.private classes
+classes.tuple compiler.intrinsics namespaces
+compiler.tree.propagation.info stack-checker.errors
+kernel.private ;
 
 \ escape-analysis must-infer
 
@@ -28,6 +29,7 @@ M: node count-unboxed-allocations* drop ;
 
 : count-unboxed-allocations ( quot -- sizes )
     build-tree
+    analyze-recursive
     normalize
     propagate
     cleanup

basis/compiler/tree/finalization/finalization.factor

@@ -7,6 +7,7 @@ byte-arrays alien.accessors
 compiler.intrinsics
 compiler.tree
 compiler.tree.builder
+compiler.tree.recursive
 compiler.tree.normalization
 compiler.tree.propagation
 compiler.tree.propagation.info
@@ -39,6 +40,7 @@ M: #shuffle finalize*
 : splice-quot ( quot -- nodes )
     [
         build-tree
+        analyze-recursive 
         normalize
         propagate
         cleanup

basis/compiler/tree/normalization/introductions/introductions.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences accessors math kernel
+compiler.tree ;
+IN: compiler.tree.normalization.introductions
+
+SYMBOL: introductions
+
+GENERIC: count-introductions* ( node -- )
+
+: count-introductions ( nodes -- n )
+    #! Note: we use each, not each-node, since the #branch
+    #! method recurses into children directly and we don't
+    #! recurse into #recursive at all.
+    [
+        0 introductions set
+        [ count-introductions* ] each
+        introductions get
+    ] with-scope ;
+
+: introductions+ ( n -- ) introductions [ + ] change ;
+
+M: #introduce count-introductions*
+    out-d>> length introductions+ ;
+
+M: #branch count-introductions*
+    children>>
+    [ count-introductions ] map supremum
+    introductions+ ;
+
+M: #recursive count-introductions*
+    [ label>> ] [ child>> count-introductions ] bi
+    >>introductions
+    drop ;
+
+M: node count-introductions* drop ;

basis/compiler/tree/normalization/normalization-tests.factor

@@ -1,5 +1,8 @@
 IN: compiler.tree.normalization.tests
-USING: compiler.tree.builder compiler.tree.normalization
+USING: compiler.tree.builder compiler.tree.recursive
+compiler.tree.normalization
+compiler.tree.normalization.introductions
+compiler.tree.normalization.renaming
 compiler.tree compiler.tree.checker
 sequences accessors tools.test kernel math ;
 
@@ -22,27 +25,30 @@ sequences accessors tools.test kernel math ;
 [ 0 2 ] [
     [ foo ] build-tree
     [ recursive-inputs ]
-    [ normalize recursive-inputs ] bi
+    [ analyze-recursive normalize recursive-inputs ] bi
 ] unit-test
 
-[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize check-nodes ] unit-test
+: test-normalization ( quot -- )
+    build-tree analyze-recursive normalize check-nodes ;
+
+[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
 
 DEFER: bbb
 : aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
 : bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
 
-[ ] [ [ bbb ] build-tree normalize check-nodes ] unit-test
+[ ] [ [ bbb ] test-normalization ] unit-test
 
 : ccc ( -- ) ccc drop 1 ; inline recursive
 
-[ ] [ [ ccc ] build-tree normalize check-nodes ] unit-test
+[ ] [ [ ccc ] test-normalization ] unit-test
 
 DEFER: eee
 : ddd ( -- ) eee ; inline recursive
 : eee ( -- ) swap ddd ; inline recursive
 
-[ ] [ [ eee ] build-tree normalize check-nodes ] unit-test
+[ ] [ [ eee ] test-normalization ] unit-test
 
 : call-recursive-5 ( -- ) call-recursive-5 ; inline recursive
 
-[ ] [ [ call-recursive-5 swap ] build-tree normalize check-nodes ] unit-test
+[ ] [ [ call-recursive-5 swap ] test-normalization ] unit-test

basis/compiler/tree/normalization/normalization.factor

@@ -6,7 +6,9 @@ stack-checker.backend
 stack-checker.branches
 stack-checker.inlining
 compiler.tree
-compiler.tree.combinators ;
+compiler.tree.combinators
+compiler.tree.normalization.introductions
+compiler.tree.normalization.renaming ;
 IN: compiler.tree.normalization
 
 ! A transform pass done before optimization can begin to
@@ -16,9 +18,6 @@ IN: compiler.tree.normalization
 ! replaced with a single one, at the beginning of a program.
 ! This simplifies subsequent analysis.
 !
-! - We collect #return-recursive and #call-recursive nodes and
-! store them in the #recursive's label slot.
-!
 ! - We normalize #call-recursive as follows. The stack checker
 ! says that the inputs of a #call-recursive are the entire stack
 ! at the time of the call. This is a conservative estimate; we
@@ -28,93 +27,6 @@ IN: compiler.tree.normalization
 ! #call-recursive into a #copy of the unchanged values and a
 ! #call-recursive with trimmed inputs and outputs.
 
-! Collect introductions
-SYMBOL: introductions
-
-GENERIC: count-introductions* ( node -- )
-
-: count-introductions ( nodes -- n )
-    #! Note: we use each, not each-node, since the #branch
-    #! method recurses into children directly and we don't
-    #! recurse into #recursive at all.
-    [
-        0 introductions set
-        [ count-introductions* ] each
-        introductions get
-    ] with-scope ;
-
-: introductions+ ( n -- ) introductions [ + ] change ;
-
-M: #introduce count-introductions*
-    out-d>> length introductions+ ;
-
-M: #branch count-introductions*
-    children>>
-    [ count-introductions ] map supremum
-    introductions+ ;
-
-M: #recursive count-introductions*
-    [ label>> ] [ child>> count-introductions ] bi
-    >>introductions
-    drop ;
-
-M: node count-introductions* drop ;
-
-! Collect label info
-GENERIC: collect-label-info ( node -- )
-
-M: #return-recursive collect-label-info
-    dup label>> (>>return) ;
-
-M: #call-recursive collect-label-info
-    dup label>> calls>> push ;
-
-M: #recursive collect-label-info
-    label>> V{ } clone >>calls drop ;
-
-M: node collect-label-info drop ;
-
-! Rename
-SYMBOL: rename-map
-
-: rename-value ( value -- value' )
-    [ rename-map get at ] keep or ;
-
-: rename-values ( values -- values' )
-    rename-map get '[ [ _ at ] keep or ] map ;
-
-GENERIC: rename-node-values* ( node -- node )
-
-M: #introduce rename-node-values* ;
-
-M: #shuffle rename-node-values*
-    [ rename-values ] change-in-d
-    [ [ rename-value ] assoc-map ] change-mapping ;
-
-M: #push rename-node-values* ;
-
-M: #r> rename-node-values*
-    [ rename-values ] change-in-r ;
-
-M: #terminate rename-node-values*
-    [ rename-values ] change-in-d
-    [ rename-values ] change-in-r ;
-
-M: #phi rename-node-values*
-    [ [ rename-values ] map ] change-phi-in-d ;
-
-M: #declare rename-node-values*
-    [ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
-
-M: #alien-callback rename-node-values* ;
-
-M: node rename-node-values*
-    [ rename-values ] change-in-d ;
-
-: rename-node-values ( nodes -- nodes' )
-    dup [ rename-node-values* drop ] each-node ;
-
-! Normalize
 GENERIC: normalize* ( node -- node' )
 
 SYMBOL: introduction-stack
@@ -125,10 +37,6 @@ SYMBOL: introduction-stack
 : pop-introductions ( n -- values )
     introduction-stack [ swap cut* swap ] change ;
 
-: add-renamings ( old new -- )
-    [ rename-values ] dip
-    rename-map get '[ _ set-at ] 2each ;
-
 M: #introduce normalize*
     out-d>> [ length pop-introductions ] keep add-renamings f ;
 
@@ -201,9 +109,8 @@ M: #call-recursive normalize*
 M: node normalize* ;
 
 : normalize ( nodes -- nodes' )
-    H{ } clone rename-map set
-    dup [ collect-label-info ] each-node
     dup count-introductions make-values
+    H{ } clone rename-map set
     [ (normalize) ] [ nip ] 2bi
     [ #introduce prefix ] unless-empty
     rename-node-values ;

basis/compiler/tree/normalization/renaming/renaming.factor

@@ -0,0 +1,48 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs kernel accessors sequences fry
+compiler.tree compiler.tree.combinators ;
+IN: compiler.tree.normalization.renaming
+
+SYMBOL: rename-map
+
+: rename-value ( value -- value' )
+    [ rename-map get at ] keep or ;
+
+: rename-values ( values -- values' )
+    rename-map get '[ [ _ at ] keep or ] map ;
+
+: add-renamings ( old new -- )
+    [ rename-values ] dip
+    rename-map get '[ _ set-at ] 2each ;
+
+GENERIC: rename-node-values* ( node -- node )
+
+M: #introduce rename-node-values* ;
+
+M: #shuffle rename-node-values*
+    [ rename-values ] change-in-d
+    [ [ rename-value ] assoc-map ] change-mapping ;
+
+M: #push rename-node-values* ;
+
+M: #r> rename-node-values*
+    [ rename-values ] change-in-r ;
+
+M: #terminate rename-node-values*
+    [ rename-values ] change-in-d
+    [ rename-values ] change-in-r ;
+
+M: #phi rename-node-values*
+    [ [ rename-values ] map ] change-phi-in-d ;
+
+M: #declare rename-node-values*
+    [ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
+
+M: #alien-callback rename-node-values* ;
+
+M: node rename-node-values*
+    [ rename-values ] change-in-d ;
+
+: rename-node-values ( nodes -- nodes' )
+    dup [ rename-node-values* drop ] each-node ;

basis/compiler/tree/optimizer/optimizer.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces
+compiler.tree.recursive
 compiler.tree.normalization
 compiler.tree.propagation
 compiler.tree.cleanup
@@ -9,7 +10,6 @@ compiler.tree.tuple-unboxing
 compiler.tree.def-use
 compiler.tree.dead-code
 compiler.tree.strength-reduction
-compiler.tree.loop.detection
 compiler.tree.finalization
 compiler.tree.checker ;
 IN: compiler.tree.optimizer
@@ -17,10 +17,10 @@ IN: compiler.tree.optimizer
 SYMBOL: check-optimizer?
 
 : optimize-tree ( nodes -- nodes' )
+    analyze-recursive
     normalize
     propagate
     cleanup
-    detect-loops
     escape-analysis
     unbox-tuples
     compute-def-use

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -6,6 +6,7 @@ classes.algebra classes.union sets quotations assocs combinators
 words namespaces
 compiler.tree
 compiler.tree.builder
+compiler.tree.recursive
 compiler.tree.normalization
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes ;
@@ -18,7 +19,7 @@ M: word splicing-nodes
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
 
 M: quotation splicing-nodes
-    build-sub-tree normalize ;
+    build-sub-tree normalize analyze-recursive ;
 
 : propagate-body ( #call -- )
     body>> (propagate) ;

basis/compiler/tree/propagation/propagation-tests.factor

@@ -1,5 +1,5 @@
 USING: kernel compiler.tree.builder compiler.tree
-compiler.tree.propagation
+compiler.tree.propagation compiler.tree.recursive
 compiler.tree.normalization tools.test math math.order
 accessors sequences arrays kernel.private vectors
 alien.accessors alien.c-types sequences.private
@@ -14,6 +14,7 @@ IN: compiler.tree.propagation.tests
 
 : final-info ( quot -- seq )
     build-tree
+    analyze-recursive
     normalize
     propagate
     compute-def-use

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -70,7 +70,8 @@ M: #recursive propagate-around ( #recursive -- )
     [ generalize-return-interval ] map ;
 
 : return-infos ( node -- infos )
-    label>> return>> node-input-infos generalize-return ;
+    label>> [ return>> node-input-infos ] [ loop?>> ] bi
+    [ generalize-return ] unless ;
 
 M: #call-recursive propagate-before ( #call-recursive -- )
     [ ] [ return-infos ] [ node-output-infos ] tri

basis/compiler/tree/recursive/recursive-tests.factor

@@ -1,5 +1,5 @@
-IN: compiler.tree.loop.detection.tests
-USING: compiler.tree.loop.detection tools.test
+IN: compiler.tree.recursive.tests
+USING: compiler.tree.recursive tools.test
 kernel combinators.short-circuit math sequences accessors
 compiler.tree
 compiler.tree.builder
@@ -10,7 +10,7 @@ compiler.tree.combinators ;
 [ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
 [ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
 
-\ detect-loops must-infer
+\ analyze-recursive must-infer
 
 : label-is-loop? ( nodes word -- ? )
     [
@@ -38,22 +38,22 @@ compiler.tree.combinators ;
     dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
                           
 [ t ] [
-    [ loop-test-1 ] build-tree detect-loops
+    [ loop-test-1 ] build-tree analyze-recursive
     \ loop-test-1 label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ loop-test-1 1 2 3 ] build-tree detect-loops
+    [ loop-test-1 1 2 3 ] build-tree analyze-recursive
     \ loop-test-1 label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ [ loop-test-1 ] each ] build-tree detect-loops
+    [ [ loop-test-1 ] each ] build-tree analyze-recursive
     \ loop-test-1 label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ [ loop-test-1 ] each ] build-tree detect-loops
+    [ [ loop-test-1 ] each ] build-tree analyze-recursive
     \ (each-integer) label-is-loop?
 ] unit-test
 
@@ -61,7 +61,7 @@ compiler.tree.combinators ;
     dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
 
 [ t ] [
-    [ loop-test-2 ] build-tree detect-loops
+    [ loop-test-2 ] build-tree analyze-recursive
     \ loop-test-2 label-is-not-loop?
 ] unit-test
 
@@ -69,7 +69,7 @@ compiler.tree.combinators ;
     dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
 
 [ t ] [
-    [ loop-test-3 ] build-tree detect-loops
+    [ loop-test-3 ] build-tree analyze-recursive
     \ loop-test-3 label-is-not-loop?
 ] unit-test
 
@@ -81,7 +81,7 @@ compiler.tree.combinators ;
     ] if ; inline recursive
 
 [ f ] [
-    [ [ [ ] map ] map ] build-tree detect-loops
+    [ [ [ ] map ] map ] build-tree analyze-recursive
     [
         dup #recursive? [ label>> loop?>> not ] [ drop f ] if
     ] contains-node?
@@ -98,22 +98,22 @@ DEFER: a
     blah [ b ] [ a ] if ; inline recursive
 
 [ t ] [
-    [ a ] build-tree detect-loops
+    [ a ] build-tree analyze-recursive
     \ a label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ a ] build-tree detect-loops
+    [ a ] build-tree analyze-recursive
     \ b label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ b ] build-tree detect-loops
+    [ b ] build-tree analyze-recursive
     \ a label-is-loop?
 ] unit-test
 
 [ t ] [
-    [ a ] build-tree detect-loops
+    [ a ] build-tree analyze-recursive
     \ b label-is-loop?
 ] unit-test
 
@@ -126,12 +126,12 @@ DEFER: a'
     blah [ b' ] [ a' ] if ; inline recursive
 
 [ f ] [
-    [ a' ] build-tree detect-loops
+    [ a' ] build-tree analyze-recursive
     \ a' label-is-loop?
 ] unit-test
 
 [ f ] [
-    [ b' ] build-tree detect-loops
+    [ b' ] build-tree analyze-recursive
     \ b' label-is-loop?
 ] unit-test
 
@@ -140,11 +140,11 @@ DEFER: a'
 ! sound.
 
 [ t ] [
-    [ b' ] build-tree detect-loops
+    [ b' ] build-tree analyze-recursive
     \ a' label-is-loop?
 ] unit-test
 
 [ f ] [
-    [ a' ] build-tree detect-loops
+    [ a' ] build-tree analyze-recursive
     \ b' label-is-loop?
 ] unit-test

basis/compiler/tree/recursive/recursive.factor

@@ -1,14 +1,27 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences namespaces assocs accessors fry
-compiler.tree deques search-deques ;
-IN: compiler.tree.loop.detection
+USING: kernel assocs namespaces accessors sequences deques
+search-deques compiler.tree compiler.tree.combinators ;
+IN: compiler.tree.recursive
+
+! Collect label info
+GENERIC: collect-label-info ( node -- )
+
+M: #return-recursive collect-label-info
+    dup label>> (>>return) ;
+
+M: #call-recursive collect-label-info
+    dup label>> calls>> push ;
+
+M: #recursive collect-label-info
+    label>> V{ } clone >>calls drop ;
+
+M: node collect-label-info drop ;
 
 ! A loop is a #recursive which only tail calls itself, and those
 ! 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 ;
 
@@ -84,5 +97,6 @@ M: node collect-loop-info* 2drop ;
         ] [ drop ] if
     ] slurp-deque ;
 
-: detect-loops ( nodes -- nodes )
+: analyze-recursive ( nodes -- nodes )
+    dup [ collect-label-info ] each-node
     dup collect-loop-info disqualify-loops ;

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -1,16 +1,18 @@
 IN: compiler.tree.tuple-unboxing.tests
 USING: tools.test compiler.tree.tuple-unboxing compiler.tree
-compiler.tree.builder compiler.tree.normalization
-compiler.tree.propagation compiler.tree.cleanup
-compiler.tree.escape-analysis compiler.tree.tuple-unboxing
-compiler.tree.checker compiler.tree.def-use kernel accessors
-sequences math math.private sorting math.order binary-search
-sequences.private slots.private ;
+compiler.tree.builder compiler.tree.recursive
+compiler.tree.normalization compiler.tree.propagation
+compiler.tree.cleanup compiler.tree.escape-analysis
+compiler.tree.tuple-unboxing compiler.tree.checker
+compiler.tree.def-use kernel accessors sequences math
+math.private sorting math.order binary-search sequences.private
+slots.private ;
 
 \ unbox-tuples must-infer
 
 : test-unboxing ( quot -- )
     build-tree
+    analyze-recursive
     normalize
     propagate
     cleanup