Fix another bug; cleanup phase too eager to remove #phi nodes

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

@@ -0,0 +1,4 @@
+IN: compiler.tree.checker.tests
+USING: compiler.tree.checker tools.test ;
+
+\ check-nodes must-infer

basis/compiler/tree/checker/checker.factor

@@ -67,6 +67,7 @@ ERROR: check-node-error node error ;
 
 SYMBOL: datastack
 SYMBOL: retainstack
+SYMBOL: terminated?
 
 GENERIC: check-stack-flow* ( node -- )
 
@@ -120,11 +121,8 @@ M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ;
 : 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 ;
+    check-in-d assert-datastack-empty assert-retainstack-empty ;
 
 M: #enter-recursive check-stack-flow*
     check-out-d ;
@@ -144,7 +142,9 @@ M: #call-recursive check-stack-flow*
     [ "Bad terminate retain stack" throw ] unless ;
 
 M: #terminate check-stack-flow*
-    [ check-terminate-in-d ] [ check-terminate-in-r ] bi ;
+    terminated? on
+    [ check-terminate-in-d ]
+    [ check-terminate-in-r ] bi ;
 
 SYMBOL: branch-out
 
@@ -154,7 +154,7 @@ SYMBOL: branch-out
         V{ } clone retainstack set
         (check-stack-flow)
         assert-retainstack-empty
-        datastack get
+        terminated? get f datastack get ?
     ] with-scope ;
 
 M: #branch check-stack-flow*
@@ -176,7 +176,7 @@ M: #branch check-stack-flow*
 
 : set-phi-datastack ( #phi -- )
     phi-in-d>> first length
-    branch-out get [ [ +bottom+ eq? ] all? not ] find nip
+    branch-out get [ ] find nip
     dup [ swap head* >vector ] [ 2drop V{ } clone ] if datastack set ;
 
 M: #phi check-stack-flow*

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

@@ -4,16 +4,18 @@ math.private math generic words quotations alien alien.c-types
 strings sbufs sequences.private slots.private combinators
 definitions system layouts vectors math.partial-dispatch
 math.order math.functions accessors hashtables classes assocs
-io.encodings.utf8 io.encodings.ascii io.encodings fry
+io.encodings.utf8 io.encodings.ascii io.encodings fry slots
+sorting.private
 compiler.tree
 compiler.tree.combinators
 compiler.tree.cleanup
 compiler.tree.builder
 compiler.tree.normalization
-compiler.tree.propagation ;
+compiler.tree.propagation
+compiler.tree.checker ;
 
 : cleaned-up-tree ( quot -- nodes )
-    build-tree normalize propagate cleanup ;
+    build-tree normalize propagate cleanup dup check-nodes ;
 
 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
 
@@ -430,3 +432,14 @@ cell-bits 32 = [
         { integer } declare [ 0 >= ] map
     ] { >= fixnum>= } inlined?
 ] unit-test
+
+[ ] [
+    [
+        4 pick array-capacity?
+        [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
+    ] cleaned-up-tree drop
+] unit-test
+
+[ ] [
+    [ { merge } declare accum>> 0 >>length ] cleaned-up-tree drop
+] unit-test

basis/compiler/tree/cleanup/cleanup.factor

@@ -124,7 +124,7 @@ M: #branch cleanup*
     if ;
 
 : eliminate-phi ( #phi -- node )
-    dup phi-in-d>> length {
+    live-branches get sift length {
         { 0 [ drop f ] }
         { 1 [ eliminate-single-phi ] }
         [ drop ]
@@ -133,8 +133,9 @@ M: #branch cleanup*
 M: #phi cleanup*
     #! Remove #phi function inputs which no longer exist.
     live-branches get
-    [ '[ , select-children sift ] change-phi-in-d ]
+    [ '[ , sift-children ] change-phi-in-d ]
-    [ '[ , select-children sift ] change-phi-info-d ] bi
+    [ '[ , sift-children ] change-phi-info-d ]
+    [ '[ , sift-children ] change-terminated ] tri
     eliminate-phi
     live-branches off ;
 

basis/compiler/tree/combinators/combinators.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry kernel accessors sequences sequences.deep arrays
+USING: assocs fry kernel accessors sequences sequences.deep arrays
 stack-checker.inlining namespaces compiler.tree ;
 IN: compiler.tree.combinators
 
@@ -45,6 +45,9 @@ IN: compiler.tree.combinators
 : select-children ( seq flags -- seq' )
     [ [ drop f ] unless ] 2map ;
 
+: sift-children ( seq flags -- seq' )
+    zip [ nip ] assoc-filter keys ;
+
 : (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
 
 : 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline