Inferencce refactoring for more reliable stack height recording

TODO.FACTOR.txt

@@ -1,5 +1,12 @@
 + 0.85:
 
+- words:
+  - S+left: reload
+  - S+right: inspect
+
+- links:
+  - same deal
+
 - UI dataflow visualizer:
   - spacing is weird
   - #label, #if mess up height

library/compiler/alien/alien-callback.factor

@@ -22,12 +22,11 @@ M: alien-callback-error summary
 "infer-effect" set-word-prop
 
 \ alien-callback [
-    empty-node <alien-callback>
+    empty-node <alien-callback> dup node,
     pop-literal nip over set-alien-callback-quot
     pop-literal nip over set-alien-callback-parameters
     pop-literal nip over set-alien-callback-return
     gensym over set-alien-callback-xt
-    dup node,
     callback-bottom
 ] "infer" set-word-prop
 

library/compiler/alien/alien-indirect.factor

@@ -19,11 +19,10 @@ M: alien-indirect-error summary
 "infer-effect" set-word-prop
 
 \ alien-indirect [
-    empty-node <alien-indirect>
+    empty-node <alien-indirect> dup node,
     pop-literal nip over set-alien-indirect-abi
     pop-literal nip over set-alien-indirect-parameters
-    pop-literal nip over set-alien-indirect-return
-    node,
+    pop-literal nip swap set-alien-indirect-return
 ] "infer" set-word-prop
 
 : generate-indirect-cleanup ( node -- )

library/compiler/alien/alien-invoke.factor

@@ -28,14 +28,13 @@ M: alien-invoke-error summary
 "infer-effect" set-word-prop
 
 \ alien-invoke [
-    empty-node <alien-invoke>
+    empty-node <alien-invoke> dup node,
     pop-literal nip over set-alien-invoke-parameters
     pop-literal nip over set-alien-invoke-function
     pop-literal nip over set-alien-invoke-library
     pop-literal nip over set-alien-invoke-return
     dup alien-invoke-dlsym dlsym drop
-    dup alien-invoke-stack
-    node,
+    alien-invoke-stack
 ] "infer" set-word-prop
 
 : unbox-parameter ( stack# type -- )

library/compiler/inference/branches.factor

@@ -81,5 +81,6 @@ TUPLE: unbalanced-branches-error in out ;
     [ infer-branch ] map dup unify-effects unify-dataflow ;
 
 : infer-branches ( branches node -- )
-    [ >r (infer-branches) r> set-node-children ] keep
-    node, #merge node, ;
+    dup node,
+    >r (infer-branches) r> set-node-children
+    #merge node, ;

library/compiler/inference/dataflow.factor

@@ -17,13 +17,25 @@ SYMBOL: meta-r
 : peek-r meta-r get peek ;
 
 TUPLE: node param shuffle
+d-height r-height
 classes literals history
 successor children ;
 
 M: node equal? eq? ;
 
+: d-height ( -- n ) meta-d get length d-in get - ; inline
+
+: r-height ( -- n ) meta-r get length ;
+
+: record-height ( node -- )
+    d-height over set-node-d-height
+    r-height swap set-node-r-height ;
+
 : make-node ( param in-d out-d in-r out-r node -- node )
-    [ >r swapd <shuffle> f f f f f <node> r> set-delegate ] keep ;
+    [
+        >r swapd <shuffle> f f f f f f f <node> r>
+        set-delegate
+    ] keep ;
 
 : node-in-d  node-shuffle shuffle-in-d  ;
 : node-in-r  node-shuffle shuffle-in-r  ;
@@ -68,7 +80,7 @@ C: #call-label make-node ;
 
 TUPLE: #push ;
 C: #push make-node ;
-: #push ( -- node ) peek-d 1array out-node <#push> ;
+: #push ( -- node ) empty-node <#push> ;
 : >#push< ( node -- seq ) node-out-d [ value-literal ] map ;
 
 TUPLE: #shuffle ;
@@ -118,6 +130,7 @@ SYMBOL: dataflow-graph
 SYMBOL: current-node
 
 : node, ( node -- )
+    dup record-height
     dataflow-graph get [
         dup current-node [ set-node-successor ] change
     ] [

library/compiler/inference/inference.factor

@@ -56,7 +56,9 @@ SYMBOL: recorded
 GENERIC: apply-object
 
 : apply-literal ( obj -- )
-    <value> push-d #push node, ;
+    #push dup node,
+    swap <value> push-d
+    1 d-tail swap set-node-out-d ;
 
 M: object apply-object apply-literal ;
 

library/compiler/inference/stack.factor

@@ -15,11 +15,10 @@ sequences words parser ;
     node-outputs ;
 
 : infer-shuffle ( shuffle -- )
-    #shuffle
+    #shuffle dup node,
     2dup infer-shuffle-inputs
     over shuffle-stacks
-    tuck infer-shuffle-outputs
-    node, ;
+    infer-shuffle-outputs ;
 
 : shuffle>effect ( shuffle -- effect )
     dup shuffle-in-d swap shuffle-out-d <effect> ;

library/compiler/inference/words.factor

@@ -25,11 +25,11 @@ IN: inference
 
 : consume/produce ( word effect -- )
     meta-d get clone >r
-    swap make-call-node
+    swap make-call-node dup node,
     over effect-in length over consume-values
     over effect-out length over produce-values
-    r> over #call-label? [ over set-node-in-d ] [ drop ] if
-    node, effect-terminated? [ terminate ] when ;
+    r> over #call-label? [ swap set-node-in-d ] [ 2drop ] if
+    effect-terminated? [ terminate ] when ;
 
 TUPLE: no-effect word ;