fixes

library/compiler/linearizer.factor

@@ -46,8 +46,20 @@ M: #label linearize* ( node -- )
         dup <label> [ %return-to , simple-label ] keep %label ,
     ] ifte linearize-next ;
 
+: tail-call? ( node -- ? )
+    #! A #call to some other label or word, followed by a
+    #! #return from a simple label is not allowed to be
+    #! tail-call-optimized; indeed, that #return will not be
+    #! generated at all.
+    dup node-successor dup #return? [
+        swap node-param swap node-param
+        dup simple-labels get memq? not >r eq? r> or
+    ] [
+        2drop f
+    ] ifte ;
+
 : ?tail-call ( node caller jumper -- next )
-    >r >r dup node-successor #return? [
+    >r >r dup tail-call? [
         node-param r> drop r> execute ,
     ] [
         dup node-param r> execute , r> drop linearize-next
@@ -104,6 +116,4 @@ M: #dispatch linearize* ( vtable -- )
 M: #return linearize* ( node -- )
     #! Simple label returns do not count, since simple labels do
     #! not push a stack frame on the C stack.
-    dup node-param simple-labels get memq? [
+    node-param simple-labels get memq? [ %return , ] unless ;
-        f %return ,
-    ] unless drop ;

library/compiler/vops.factor

@@ -75,7 +75,7 @@ C: %label make-vop ;
 ! simplifier.
 TUPLE: %return ;
 C: %return make-vop ;
-: %return ( label) label-vop <%return> ;
+: %return empty-vop <%return> ;
 
 TUPLE: %return-to ;
 C: %return-to make-vop ;

library/inference/optimizer.factor

@@ -63,7 +63,10 @@ M: #shuffle optimize-node*  ( node -- node/t )
     dup node-successor dup #shuffle? [
         compose-shuffle-nodes
     ] [
-        drop [ node-values empty? ] prune-if
+        drop [
+            dup node-in-d over node-out-d =
+            >r dup node-in-r swap node-out-r = r> and
+        ] prune-if
     ] ifte ;
 
 ! #ifte

library/inference/print-dataflow.factor

@@ -57,7 +57,8 @@ M: #dispatch node>quot ( ? node -- )
     [ "#dispatch" comment, ] 2keep
     node-children [ swap dataflow>quot ] map-with , \ dispatch , ;
 
-M: #return node>quot ( ? node -- ) "#return" comment, ;
+M: #return node>quot ( ? node -- )
+    dup node-param unparse "#return " swap append comment, ;
 
 M: #values node>quot ( ? node -- ) "#values" comment, ;