Fix problem with terminating branches; normalize always pushes #introduce to the front

unfinished/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
+USING: fry kernel accessors sequences sequences.deep arrays
 compiler.tree ;
 IN: compiler.tree.combinators
 
@@ -44,3 +44,9 @@ IN: compiler.tree.combinators
 
 : select-children ( seq flags -- seq' )
     [ [ drop f ] unless ] 2map ;
+
+: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
+
+: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
+
+: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline

unfinished/compiler/tree/normalization/normalization.factor

@@ -9,8 +9,9 @@ IN: compiler.tree.normalization
 ! fix up some oddities in the tree output by the stack checker:
 !
 ! - We rewrite the code is that #introduce nodes only appear
-! at the top level, and not inside #recursive. This enables more
-! accurate type inference for 'row polymorphic' combinators.
+! at the beginning of a program, never having #introduce follow
+! any other type of node or appear inside a #branch or
+! #recursive. This simplifies some types of analysis.
 !
 ! - We collect #return-recursive and #call-recursive nodes and
 ! store them in the #recursive's label slot.
@@ -46,6 +47,10 @@ M: #branch count-introductions*
     [ count-introductions ] map supremum
     introductions [ + ] change ;
 
+M: #recursive count-introductions*
+    [ label>> ] [ child>> count-introductions ] bi
+    >>introductions drop ;
+
 M: node count-introductions* drop ;
 
 ! Collect label info
@@ -58,18 +63,16 @@ M: #call-recursive collect-label-info
     dup label>> calls>> push ;
 
 M: #recursive collect-label-info
-    [ label>> V{ } clone >>calls ]
-    [ child>> count-introductions ]
-    bi >>introductions drop ;
+    label>> V{ } clone >>calls drop ;
 
 M: node collect-label-info drop ;
 
 ! Eliminate introductions
 SYMBOL: introduction-stack
 
-: fixup-enter-recursive ( recursive -- )
+: fixup-enter-recursive ( introductions recursive -- )
     [ child>> first ] [ in-d>> ] bi >>in-d
-    [ introduction-stack get prepend ] change-out-d
+    [ append ] change-out-d
     drop ;
 
 GENERIC: eliminate-introductions* ( node -- node' )
@@ -93,23 +96,37 @@ M: #branch eliminate-introductions*
     [ [ length ] map infimum introduction-stack [ swap head ] change ]
     bi ;
 
+: eliminate-phi-introductions ( introductions seq terminated -- seq' )
+    [ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ;
+
 M: #phi eliminate-introductions*
-    remaining-introductions get swap
-    [ flip [ over length tail append ] 2map flip ] change-phi-in-d ;
+    remaining-introductions get swap dup terminated>>
+    '[ , eliminate-phi-introductions ] change-phi-in-d ;
 
 M: node eliminate-introductions* ;
 
-: eliminate-introductions ( recursive n -- )
-    make-values introduction-stack [
-        [ fixup-enter-recursive ]
-        [ child>> [ eliminate-introductions* ] change-each ] bi
+: eliminate-introductions ( nodes introductions -- nodes )
+    introduction-stack [
+        [ eliminate-introductions* ] map
     ] with-variable ;
 
+: eliminate-toplevel-introductions ( nodes -- nodes' )
+    dup count-introductions make-values
+    [ nip [ #introduce ] map ] [ eliminate-introductions ] 2bi
+    append ;
+
+: eliminate-recursive-introductions ( recursive n -- )
+    make-values
+    [ swap fixup-enter-recursive ]
+    [ '[ , eliminate-introductions ] change-child drop ]
+    2bi ;
+
 ! Normalize
 GENERIC: normalize* ( node -- node' )
 
 M: #recursive normalize*
-    dup dup label>> introductions>> eliminate-introductions ;
+    dup dup label>> introductions>>
+    eliminate-recursive-introductions ;
 
 : unchanged-underneath ( #call-recursive -- n )
     [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
@@ -123,6 +140,6 @@ M: #call-recursive normalize*
 M: node normalize* ;
 
 : normalize ( nodes -- nodes' )
-    [ [ collect-label-info ] each-node ]
-    [ [ normalize* ] map-nodes ]
-    bi ;
+    dup [ collect-label-info ] each-node
+    eliminate-toplevel-introductions
+    [ normalize* ] map-nodes ;

unfinished/compiler/tree/tree.factor

@@ -87,10 +87,11 @@ TUPLE: #dispatch < #branch ;
 : #dispatch ( n branches -- node )
     \ #dispatch new-branch ;
 
-TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r ;
+TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r terminated ;
 
-: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out -- node )
+: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- node )
     \ #phi new
+        swap >>terminated
         swap >>out-r
         swap >>phi-in-r
         swap >>out-d

unfinished/stack-checker/branches/branches.factor

@@ -58,9 +58,17 @@ SYMBOL: quotations
     unify-branches
     [ drop ] [ ] [ dup >vector meta-r set ] tri* ;
 
+: terminated-phi ( seq -- terminated )
+    terminated? branch-variable ;
+
 : compute-phi-function ( seq -- )
     [ quotation active-variable sift quotations set ]
-    [ [ datastack-phi ] [ retainstack-phi ] bi #phi, ]
+    [
+        [ datastack-phi ]
+        [ retainstack-phi ]
+        [ terminated-phi ]
+        tri #phi,
+    ]
     [ [ terminated? swap at ] all? terminated? set ]
     tri ;
 

unfinished/stack-checker/visitor/dummy/dummy.factor

@@ -17,7 +17,7 @@ M: f #return-recursive, 3drop ;
 M: f #terminate, drop ;
 M: f #if, 3drop ;
 M: f #dispatch, 2drop ;
-M: f #phi, 2drop 2drop ;
+M: f #phi, drop drop drop drop drop ;
 M: f #declare, drop ;
 M: f #recursive, 2drop 2drop ;
 M: f #copy, 2drop ;

unfinished/stack-checker/visitor/visitor.factor

@@ -20,7 +20,7 @@ HOOK: #r>, stack-visitor ( inputs outputs -- )
 HOOK: #terminate, stack-visitor ( stack -- )
 HOOK: #if, stack-visitor ( ? true false -- )
 HOOK: #dispatch, stack-visitor ( n branches -- )
-HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
+HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- )
 HOOK: #declare, stack-visitor ( declaration -- )
 HOOK: #return, stack-visitor ( stack -- )
 HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )