fix inference hang

CHANGES.html

@@ -32,7 +32,15 @@
 <li>The matrices library has been greatly simplified. Matrices are now represented as vectors of vectors, and matrix words have been moved to the <code>math</code> vocabulary.</li>
 <li>More descriptive "out of bounds" errors.</li>
 <li>New <code>make-hash ( quot -- namespace )</code> combinator executes quotation in a new namespace, which is then pushed on the stack.</li>
-<li>The <code>&lt;namespace&gt;</code> word is gone. It would create a hashtable with a default capacity. Now, just write <code>{{ }} clone</code>.
+<li>The <code>&lt;namespace&gt;</code> word is gone. It would create a hashtable with a default capacity. Now, just write <code>{{ }} clone</code>.</li>
+<li>Sequence construction words changed:
+<pre>
+make-list    ==&gt; [ ] make
+make-vector  ==&gt; { } make
+make-string  ==&gt; "" make
+make-rstring ==&gt; "" make reverse
+make-sbuf    ==&gt; SBUF" " make
+</pre></li>
 </ul>
 
 </li>

TODO.FACTOR.txt

@@ -1,6 +1,6 @@
 - reader syntax for arrays, byte arrays, displaced aliens
-- fix infer hang
 - out of memory error when printing global namespace
+- decompile is broken
 
 + ui:
 

library/inference/call-optimizers.factor

@@ -34,11 +34,7 @@ sequences vectors words ;
 : partial-eval ( #call -- node )
     dup literal-in-d over node-param
     [ with-datastack ] [
-        [
-            3drop t
-        ] [
-            inline-literals
-        ] ifte
+        [ 3drop t ] [ inline-literals ] ifte
     ] catch ;
 
 : flip-branches ( #ifte -- )

library/inference/dataflow.factor

@@ -164,10 +164,18 @@ SYMBOL: current-node
 : last-node ( node -- last )
     dup node-successor [ last-node ] [ ] ?ifte ;
 
+: penultimate-node ( node -- penultimate )
+    dup node-successor dup [
+        dup node-successor
+        [ nip penultimate-node ] [ drop ] ifte
+    ] [
+        2drop f
+    ] ifte ;
+
 : drop-inputs ( node -- #drop )
     node-in-d clone in-d-node <#drop> ;
 
-: each-node ( node quot -- )
+: each-node ( node quot -- | quot: node -- )
     over [
         [ call ] 2keep swap
         [ node-children [ swap each-node ] each-with ] 2keep
@@ -179,6 +187,26 @@ SYMBOL: current-node
 : each-node-with ( obj node quot -- | quot: obj node -- )
     swap [ with ] each-node 2drop ; inline
 
+: all-nodes? ( node quot -- ? | quot: node -- ? )
+    over [
+        [ call ] 2keep rot [
+            [
+                swap node-children [ swap all-nodes? ] all-with?
+            ] 2keep rot [
+                >r node-successor r> all-nodes?
+            ] [
+                2drop f
+            ] ifte
+        ] [
+            2drop f
+        ] ifte
+    ] [
+        2drop t
+    ] ifte ; inline
+
+: all-nodes-with? ( obj node quot -- ? | quot: obj node -- ? )
+    swap [ with rot ] all-nodes? 2nip ; inline
+
 SYMBOL: substituted
 
 DEFER: subst-value

library/inference/kill-literals.factor

@@ -9,28 +9,13 @@ GENERIC: literals* ( node -- )
 : literals ( node -- seq )
     [ [ literals* ] each-node ] { } make ;
 
-GENERIC: can-kill* ( literal node -- ? )
-
-: can-kill? ( literal node -- ? )
-    #! Return false if the literal appears in any node in the
-    #! list.
-    dup [
-        2dup can-kill* [
-            2dup node-children [ can-kill? ] all-with? [
-                node-successor can-kill?
-            ] [
-                2drop f
-            ] ifte
-        ] [
-            2drop f
-        ] ifte
-    ] [
-        2drop t
-    ] ifte ;
+GENERIC: can-kill? ( literal node -- ? )
 
 : kill-set ( node -- list )
     #! Push a list of literals that may be killed in the IR.
-    dup literals [ swap can-kill? ] subset-with ;
+    dup literals [
+        swap [ can-kill? ] all-nodes-with?
+    ] subset-with ;
 
 : remove-values ( values node -- )
     2dup [ node-in-d seq-diff ] keep set-node-in-d
@@ -48,19 +33,19 @@ M: node kill-node* ( literals node -- ) 2drop ;
 ! Generic nodes
 M: node literals* ( node -- ) drop ;
 
-M: node can-kill* ( literal node -- ? ) uses-value? not ;
+M: node can-kill? ( literal node -- ? ) uses-value? not ;
 
 ! #push
 M: #push literals* ( node -- )
     node-out-d % ;
 
-M: #push can-kill* ( literal node -- ? ) 2drop t ;
+M: #push can-kill? ( literal node -- ? ) 2drop t ;
 
 M: #push kill-node* ( literals node -- )
     [ node-out-d seq-diff ] keep set-node-out-d ;
 
 ! #drop
-M: #drop can-kill* ( literal node -- ? ) 2drop t ;
+M: #drop can-kill? ( literal node -- ? ) 2drop t ;
 
 ! #call
 : (kill-shuffle) ( word -- map )
@@ -84,8 +69,8 @@ M: #drop can-kill* ( literal node -- ? ) 2drop t ;
         [[ r> {{ }} ]]
     }} hash ;
 
-M: #call can-kill* ( literal node -- ? )
-    dup node-param (kill-shuffle) >r delegate can-kill* r> or ;
+M: #call can-kill? ( literal node -- ? )
+    dup node-param (kill-shuffle) >r delegate can-kill? r> or ;
 
 : kill-mask ( killing node -- mask )
     dup node-param \ r> = [ node-in-r ] [ node-in-d ] ifte
@@ -106,13 +91,13 @@ M: #call kill-node* ( literals node -- )
     [ kill-shuffle ] [ 2drop ] ifte ;
 
 ! #call-label
-M: #call-label can-kill* ( literal node -- ? ) 2drop t ;
+M: #call-label can-kill? ( literal node -- ? ) 2drop t ;
 
 ! #values
-M: #values can-kill* ( literal node -- ? ) 2drop t ;
+M: #values can-kill? ( literal node -- ? ) 2drop t ;
 
 ! #merge
-M: #merge can-kill* ( literal node -- ? ) 2drop t ;
+M: #merge can-kill? ( literal node -- ? ) 2drop t ;
 
 ! #entry
-M: #entry can-kill* ( literal node -- ? ) 2drop t ;
+M: #entry can-kill? ( literal node -- ? ) 2drop t ;

library/inference/optimizer.factor

@@ -80,3 +80,22 @@ M: #values optimize-node* ( node -- node/t )
 ! #return
 M: #return optimize-node* ( node -- node/t )
     optimize-fold ;
+
+! #label
+GENERIC: calls-label? ( label node -- ? )
+
+M: node calls-label? 2drop f ;
+
+M: #call-label calls-label? node-param eq? ;
+
+M: #label optimize-node* ( node -- node/t )
+    dup node-param over node-children first calls-label? [
+        drop t
+    ] [
+        dup node-children first dup node-successor [
+            dup penultimate-node rot
+            node-successor swap set-node-successor
+        ] [
+            drop node-successor
+        ] ifte
+    ] ifte ;

library/inference/words.factor

@@ -25,9 +25,6 @@ hashtables parser prettyprint ;
     " was already attempted, and failed" append3
     inference-error ;
 
-: recursive? ( word -- ? )
-    f swap dup word-def [ = or ] tree-each-with ;
-
 : with-block ( word [[ label quot ]] quot -- block-node )
     #! Execute a quotation with the word on the stack, and add
     #! its dataflow contribution to a new #label node in the IR.
@@ -40,16 +37,6 @@ hashtables parser prettyprint ;
         #entry node,  word-def infer-quot  #return node,
     ] with-block ;
 
-: inline-compound ( word -- )
-    #! Infer the stack effect of a compound word in the current
-    #! inferencer instance. If the word in question is recursive
-    #! we infer its stack effect inside a new block.
-    dup recursive? [
-        inline-block node,
-    ] [
-        word-def infer-quot
-    ] ifte ;
-
 : infer-compound ( word base-case -- effect )
     #! Infer a word's stack effect in a separate inferencer
     #! instance.
@@ -137,11 +124,8 @@ M: compound apply-object ( word -- )
     dup recursive-state get assoc [
         recursive-word
     ] [
-        dup "inline" word-prop [
-            inline-compound
-        ] [
-            apply-default
-        ] ifte
+        dup "inline" word-prop
+        [ inline-block node, ] [ apply-default ] ifte
     ] ifte* ;
 
 : infer-shuffle ( word -- )

library/test/inference.factor

@@ -151,7 +151,7 @@ M: real iterate drop ;
 
 DEFER: agent
 : smith 1 + agent ; inline
-: agent dup 0 = [ [ swap call ] 2keep [ smith ] 2keep ] when ; inline
+: agent dup 0 = [ [ swap call ] 2keep smith ] when ; inline
 [ [ [ ] [ object object ] ] ]
 [ [ [ drop ] 0 agent ] infer ] unit-test