fix flaw in node-clone; cleanups

library/inference/dataflow.factor

@@ -236,9 +236,16 @@ DEFER: subst-value
         dup #call? [ node-history push ] [ 2drop ] ifte
     ] each-node-with ;
 
+: (clone-node) ( node -- node )
+    clone
+    dup node-in-d clone over set-node-in-d
+    dup node-in-r clone over set-node-in-r
+    dup node-out-d clone over set-node-out-d
+    dup node-out-r clone over set-node-out-r ;
+
 : clone-node ( node -- node )
     dup [
-        clone
+        (clone-node)
         dup node-children [ clone-node ] map over set-node-children
         dup node-successor clone-node over set-node-successor
     ] when ;

library/inference/inline-methods.factor

@@ -55,9 +55,11 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
     dup solve-recursion ;
 
 : inline-method ( node -- node )
-    dup method-dataflow [
+    #! We set the #call node's param to f so that it gets killed
-        >r node-param r> remember-node
+    #! later.
-    ] 2keep [ subst-node ] keep ;
+    dup method-dataflow
+    [ >r node-param r> remember-node ] 2keep
+    [ subst-node ] keep ;
 
 : related? ( actual testing -- ? )
     #! If actual is a subset of testing or if the two classes
@@ -74,4 +76,4 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
 : optimize-predicate ( #call -- node )
     dup node-param "predicating" word-prop >r
     dup dup node-in-d node-classes* first r> class<
-    unit inline-literals ;
+    1vector inline-literals ;

library/inference/kill-literals.factor

@@ -15,8 +15,15 @@ GENERIC: can-kill* ( literal node -- ? )
     #! Return false if the literal appears in any node in the
     #! list.
     dup [
-        2dup can-kill*
+        2dup can-kill* [
-        [ node-successor can-kill? ] [ 2drop f ] ifte
+            2dup node-children [ can-kill? ] all-with? [
+                node-successor can-kill?
+            ] [
+                2drop f
+            ] ifte
+        ] [
+            2drop f
+        ] ifte
     ] [
         2drop t
     ] ifte ;
@@ -47,15 +54,13 @@ M: node can-kill* ( literal node -- ? ) uses-value? not ;
 M: #push literals* ( node -- )
     node-out-d % ;
 
-M: #push can-kill* ( literal node -- ? )
+M: #push can-kill* ( literal node -- ? ) 2drop t ;
-    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 -- ? )
+M: #drop can-kill* ( literal node -- ? ) 2drop t ;
-    2drop t ;
 
 ! #call
 : (kill-shuffle) ( word -- map )
@@ -101,49 +106,10 @@ M: #call kill-node* ( literals node -- )
     [ kill-shuffle ] [ 2drop ] ifte ;
 
 ! #call-label
-M: #call-label can-kill* ( literal node -- ? )
+M: #call-label can-kill* ( literal node -- ? ) 2drop t ;
-     2drop t ;
-
-! #label
-M: #label can-kill* ( literal node -- ? )
-    node-children first can-kill? ;
-
-! #ifte
-SYMBOL: branch-returns
-
-: branch-values ( branches -- )
-    [ last-node node-in-d ] map
-    unify-lengths flip branch-returns set ;
-
-: can-kill-branches? ( literal node -- ? )
-    #! Check if the literal appears in either branch. This
-    #! assumes that the last element of each branch is a #values
-    #! node.
-    2dup uses-value? [
-        2drop f
-    ] [
-        [
-            node-children dup branch-values
-            [ can-kill? ] all-with?
-        ] with-scope
-    ] ifte ;
-
-M: #ifte can-kill* ( literal node -- ? )
-    can-kill-branches? ;
-
-! #dispatch
-M: #dispatch can-kill* ( literal node -- ? )
-    can-kill-branches? ;
 
 ! #values
-M: #values can-kill* ( literal node -- ? )
+M: #values can-kill* ( literal node -- ? ) 2drop t ;
-    dupd uses-value? [
-        branch-returns get
-        [ memq? ] subset-with
-        [ [ eq? ] every? ] all?
-    ] [
-        drop t
-    ] ifte ;
 
 ! #merge
 M: #merge can-kill* ( literal node -- ? ) 2drop t ;

library/inference/optimizer.factor

@@ -70,14 +70,13 @@ M: #ifte optimize-node* ( node -- node )
     dup static-branch?
     [ literal-value 0 1 ? static-branch ] [ 2drop t ] ifte ;
 
-! #values/#return
+! #values
 : optimize-fold ( node -- node/t )
-    #! Optimize #return/#call or #values/#merge, resulting from
-    #! method inlining or branch folding, respectively.
     node-successor [ node-successor ] [ t ] ifte* ;
 
 M: #values optimize-node* ( node -- node/t )
     optimize-fold ;
 
+! #return
 M: #return optimize-node* ( node -- node/t )
     optimize-fold ;

library/inference/split-nodes.factor

@@ -22,11 +22,25 @@ GENERIC: split-node* ( node -- )
 
 M: node split-node* ( node -- ) drop ;
 
+: post-inline ( #return/#values #call/#merge -- )
+    dup [
+        [ >r node-in-d r> node-out-d unify-length ] keep
+        node-successor subst-values
+    ] [
+        2drop
+    ] ifte ;
+
+: subst-node ( old new -- )
+    #! The last node of 'new' becomes 'old', then values are
+    #! substituted. A subsequent optimizer phase kills the
+    #! last node of 'new' and the first node of 'old'.
+    [ last-node 2dup swap post-inline set-node-successor ] keep
+    split-node ;
+
 : split-branch ( node -- )
-    dup node-successor over node-children [
+    dup node-successor over node-children
-        [ last-node >r clone-node r> set-node-successor ] keep
+    [ >r clone-node r> subst-node ] each-with
-        split-node
+    f swap set-node-successor ;
-    ] each-with f swap set-node-successor ;
 
 M: #ifte split-node* ( node -- )
     split-branch ;
@@ -37,14 +51,6 @@ M: #dispatch split-node* ( node -- )
 M: #label split-node* ( node -- )
     node-children first split-node ;
 
-: post-inline ( #return/#values #call/#merge -- )
-    [ >r node-in-d r> node-out-d unify-length ] keep
-    node-successor subst-values ;
-
-: subst-node ( old new -- )
-    [ last-node 2dup swap post-inline set-node-successor ] keep
-    split-node ;
-
 : inline-literals ( node literals -- node )
     #! Make #push -> #return -> successor
     over drop-inputs [

library/test/compiler/optimizer.factor

@@ -12,17 +12,17 @@ USE: lists
 USE: sequences
 
 ! Some dataflow tests
-[ 3 ] [ 1 2 3 (subst-value) ] unit-test
+! [ 3 ] [ 1 2 3 (subst-value) ] unit-test
-[ 1 ] [ 1 2 2 (subst-value) ] unit-test
+! [ 1 ] [ 1 2 2 (subst-value) ] unit-test
-
+! 
-[ { "one" "one" "three" "three" } ]
+! [ { "one" "one" "three" "three" } ]
-[
+! [
-    { "one" "two" "three" } { 1 2 3 } { 1 1 3 3 }
+!     { "one" "two" "three" } { 1 2 3 } { 1 1 3 3 }
-    clone [ (subst-values) ] keep
+!     clone [ (subst-values) ] keep
-] unit-test
+! ] unit-test
-
+! 
-[ << meet f { "one" 2 3 } >> ]
+! [ << meet f { "one" 2 3 } >> ]
-[ "one" 1 << meet f { 1 2 3 } >> clone (subst-value) ] unit-test
+! [ "one" 1 << meet f { 1 2 3 } >> clone (subst-value) ] unit-test
 
 ! Literal kill tests
 : kill-set*
@@ -53,7 +53,7 @@ USE: sequences
 
 [ 3 ] [ literal-kill-test-3 ] unit-test
 
-[ { [ 3 ] [ dup ] } ] [ [ [ 3 ] [ dup ] ifte drop ] kill-set* ] unit-test
+[ { [ 3 ] [ dup ] 3 } ] [ [ [ 3 ] [ dup ] ifte drop ] kill-set* ] unit-test
 
 : literal-kill-test-4
     5 swap [ 3 ] [ dup ] ifte 2drop ; compiled
@@ -61,7 +61,7 @@ USE: sequences
 [ ] [ t literal-kill-test-4 ] unit-test
 [ ] [ f literal-kill-test-4 ] unit-test
 
-[ { [ 3 ] [ dup ] } ] [ \ literal-kill-test-4 word-def kill-set* ] unit-test
+[ { 5 [ 3 ] [ dup ] 3 } ] [ \ literal-kill-test-4 word-def kill-set* ] unit-test
 
 : literal-kill-test-5
     5 swap [ 5 ] [ dup ] ifte 2drop ; compiled
@@ -69,7 +69,7 @@ USE: sequences
 [ ] [ t literal-kill-test-5 ] unit-test
 [ ] [ f literal-kill-test-5 ] unit-test
 
-[ { [ 5 ] [ dup ] } ] [ \ literal-kill-test-5 word-def kill-set* ] unit-test
+[ { 5 [ 5 ] [ dup ] 5 } ] [ \ literal-kill-test-5 word-def kill-set* ] unit-test
 
 : literal-kill-test-6
     5 swap [ dup ] [ dup ] ifte 2drop ; compiled
@@ -164,4 +164,5 @@ TUPLE: pred-test ;
     "nom" = ; compiled
 
 [ t ] [ "nom" inline-test ] unit-test
+[ f ] [ "shayin" inline-test ] unit-test
 [ f ] [ 3 inline-test ] unit-test