Stack flow checker; various fixes

basis/compiler/generator/generator.factor

@@ -92,7 +92,7 @@ M: node generate-node drop iterate-next ;
     %jump-label ;
 
 : generate-call ( label -- next )
-    dup maybe-compile
+    ! dup maybe-compile
     end-basic-block
     dup compiling-loops get at [
         %jump-label f

basis/compiler/tree/checker/checker.factor

@@ -1,13 +1,15 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences kernel sets namespaces accessors assocs
-arrays combinators continuations columns math
+arrays combinators continuations columns math vectors
+stack-checker.branches
 compiler.tree
 compiler.tree.def-use
 compiler.tree.combinators ;
 IN: compiler.tree.checker
 
-! Check some invariants.
+! Check some invariants; this can help catch compiler bugs.
+
 ERROR: check-use-error value message ;
 
 : check-use ( value uses -- )
@@ -63,7 +65,144 @@ ERROR: check-node-error node error ;
         tri
     ] [ check-node-error ] recover ;
 
+SYMBOL: datastack
+SYMBOL: retainstack
+
+GENERIC: check-stack-flow* ( node -- )
+
+: (check-stack-flow) ( nodes -- )
+    [ check-stack-flow* ] each ;
+
+: init-stack-flow ( -- )
+    V{ } clone datastack set
+    V{ } clone retainstack set ;
+
+: check-stack-flow ( nodes -- )
+    [
+        init-stack-flow
+        (check-stack-flow)
+    ] with-scope ;
+
+: check-inputs ( seq var -- )
+    [ dup length ] dip [ swap cut* swap ] change
+    sequence= [ "Bad stack flow" throw ] unless ;
+
+: check-in-d ( node -- )
+    in-d>> datastack check-inputs ;
+
+: check-in-r ( node -- )
+    in-r>> retainstack check-inputs ;
+
+: check-outputs ( node var -- )
+    get push-all ;
+
+: check-out-d ( node -- )
+    out-d>> datastack check-outputs ;
+
+: check-out-r ( node -- )
+    out-r>> retainstack check-outputs ;
+
+M: #introduce check-stack-flow* check-out-d ;
+
+M: #push check-stack-flow* check-out-d ;
+
+M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+
+M: #shuffle check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+
+M: #>r check-stack-flow* [ check-in-d ] [ check-out-r ] bi ;
+
+M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ;
+
+: assert-datastack-empty ( -- )
+    datastack get empty? [ "Data stack not empty" throw ] unless ;
+
+: assert-retainstack-empty ( -- )
+    retainstack get empty? [ "Retain stack not empty" throw ] unless ;
+
+: must-consume-all ( -- )
+    assert-datastack-empty assert-retainstack-empty ;
+
+M: #return check-stack-flow*
+    check-in-d must-consume-all ;
+
+M: #enter-recursive check-stack-flow*
+    check-out-d ;
+
+M: #return-recursive check-stack-flow*
+    [ check-in-d ] [ check-out-d ] bi ;
+
+M: #call-recursive check-stack-flow*
+    [ check-in-d ] [ check-out-d ] bi ;
+
+: check-terminate-in-d ( #terminate -- )
+    in-d>> datastack get over length tail* sequence=
+    [ "Bad terminate data stack" throw ] unless ;
+
+: check-terminate-in-r ( #terminate -- )
+    in-r>> retainstack get over length tail* sequence=
+    [ "Bad terminate retain stack" throw ] unless ;
+
+M: #terminate check-stack-flow*
+    [ check-terminate-in-d ] [ check-terminate-in-r ] bi ;
+
+SYMBOL: branch-out
+
+: check-branch ( nodes -- stack )
+    [
+        datastack [ clone ] change
+        V{ } clone retainstack set
+        (check-stack-flow)
+        assert-retainstack-empty
+        datastack get
+    ] with-scope ;
+
+M: #branch check-stack-flow*
+    [ check-in-d ]
+    [ children>> [ check-branch ] map branch-out set ]
+    bi ;
+
+: check-phi-in ( #phi -- )
+    phi-in-d>> branch-out get [
+        over [ +bottom+ eq? ] all? [
+            2drop
+        ] [
+            over length tail* sequence= [
+                "Branch outputs don't match phi inputs"
+                throw
+            ] unless
+        ] if
+    ] 2each ;
+
+: set-phi-datastack ( #phi -- )
+    phi-in-d>> first length
+    branch-out get [ [ +bottom+ eq? ] all? not ] find nip
+    dup [ swap head* >vector ] [ 2drop V{ } clone ] if datastack set ;
+
+M: #phi check-stack-flow*
+    [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri ;
+
+M: #recursive check-stack-flow*
+    [
+        init-stack-flow
+        child>> (check-stack-flow)
+        datastack get
+    ] with-scope
+    datastack set ;
+
+M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+
+M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+
+M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+
+M: #alien-callback check-stack-flow* drop ;
+
+M: #declare check-stack-flow* drop ;
+
 : check-nodes ( nodes -- )
     compute-def-use
     check-def-use
-    [ check-node ] each-node ;
+    [ [ check-node ] each-node ]
+    [ check-stack-flow ]
+    bi ;

basis/compiler/tree/cleanup/cleanup.factor

@@ -3,6 +3,7 @@
 USING: kernel accessors sequences sequences.deep combinators fry
 classes.algebra namespaces assocs math math.private
 math.partial-dispatch classes.tuple classes.tuple.private
+stack-checker.branches
 compiler.tree
 compiler.tree.intrinsics
 compiler.tree.combinators
@@ -13,8 +14,7 @@ IN: compiler.tree.cleanup
 ! A phase run after propagation to finish the job, so to speak.
 ! Codifies speculative inlining decisions, deletes branches
 ! marked as never taken, and flattens local recursive blocks
-! that do not call themselves. Finally, if inlining inserts a
-! #terminate, we delete all nodes after that.
+! that do not call themselves.
 
 GENERIC: delete-node ( node -- )
 
@@ -117,10 +117,16 @@ M: #branch cleanup*
         [ live-branches>> live-branches set ]
     } cleave ;
 
+: eliminate-single-phi ( #phi -- node )
+    [ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
+    [ [ drop ] [ [ f swap #push ] map ] bi* ]
+    [ #copy ]
+    if ;
+
 : eliminate-phi ( #phi -- node )
     dup phi-in-d>> length {
         { 0 [ drop f ] }
-        { 1 [ [ phi-in-d>> first ] [ out-d>> ] bi #copy ] }
+        { 1 [ eliminate-single-phi ] }
         [ drop ]
     } case ;
 

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

@@ -89,7 +89,7 @@ IN: compiler.tree.dead-code.tests
 
 : non-flushable-3 ( a b -- c ) 2drop f ;
 
-[ [ [ drop drop ] [ non-flushable-3 drop ] if ] ] [
+[ [ [ 2drop ] [ non-flushable-3 drop ] if ] ] [
     [ [ flushable-1 ] [ non-flushable-3 ] if drop ] optimize-quot
 ] unit-test
 
@@ -100,3 +100,9 @@ IN: compiler.tree.dead-code.tests
 [ [ [ . ] [ drop ] if ] ] [ [ [ dup . ] [ ] if drop ] optimize-quot ] unit-test
 
 [ [ f ] ] [ [ f dup [ ] [ ] if ] optimize-quot ] unit-test
+
+[ ] [ [ over [ ] [ dup [ "X" throw ] [ "X" throw ] if ] if ] optimize-quot drop ] unit-test
+
+: boo ( a b -- c ) 2drop f ;
+
+[ [ dup 4 eq? [ nip ] [ boo ] if ] ] [ [ dup dup 4 eq? [ drop nip ] [ drop boo ] if ] optimize-quot ] unit-test

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

@@ -305,3 +305,8 @@ C: <ro-box> ro-box
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
 
 [ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [
+    [ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
+    count-unboxed-allocations
+] unit-test

basis/compiler/tree/normalization/normalization.factor

@@ -74,6 +74,46 @@ M: #recursive collect-label-info
 
 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-value ] 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' )
 
@@ -85,8 +125,11 @@ SYMBOL: introduction-stack
 : pop-introductions ( n -- values )
     introduction-stack [ swap cut* swap ] change ;
 
+: add-renamings ( old new -- )
+    rename-map get '[ , set-at ] 2each ;
+
 M: #introduce normalize*
-    out-d>> [ length pop-introductions ] keep #copy ;
+    out-d>> [ length pop-introductions ] keep add-renamings f ;
 
 SYMBOL: remaining-introductions
 
@@ -142,10 +185,10 @@ M: #enter-recursive normalize*
         bi*
     ] [ introduction-stack [ prepend ] change ] bi ;
 
-: call>return ( #call-recursive n -- nodes )
-    [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ #copy ]
+: call>return ( #call-recursive n -- #call-recursive )
+    [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ add-renamings ]
     [ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ]
-    2bi 2array ;
+    2bi ;
 
 M: #call-recursive normalize*
     dup unchanged-underneath {
@@ -157,7 +200,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
-    [ (normalize) ] [ nip #introduce ] 2bi
-    prefix ;
+    [ (normalize) ] [ nip #introduce ] 2bi prefix
+    rename-node-values ;

basis/stack-checker/branches/branches.factor

@@ -64,10 +64,13 @@ SYMBOL: quotations
 : terminated-phi ( seq -- terminated )
     terminated? branch-variable ;
 
+: terminate-branches ( seq -- )
+    [ terminated? swap at ] all? [ terminate ] when ;
+
 : compute-phi-function ( seq -- )
     [ quotation active-variable sift quotations set ]
     [ [ datastack-phi ] [ terminated-phi ] bi #phi, ]
-    [ [ terminated? swap at ] all? terminated? set ]
+    [ terminate-branches ]
     tri ;
 
 : copy-inference ( -- )