starting recursive value inference; add hack to (uncrossref) so that it does not decompile alien words

TODO.FACTOR.txt

@@ -56,6 +56,8 @@
 
 + compiler:
 
+- changing a word to be 'inline' after it was already defined doesn't
+  work properly
 - inference needs to be more robust with heavily recursive code
 - powerpc: float ffi parameters
 - fix fixnum<< and /i overflow on PowerPC

library/alien/compiler.factor

@@ -151,3 +151,13 @@ M: alien-node linearize-node* ( node -- )
 global [
     "libraries" get [ <namespace> "libraries" set ] unless
 ] bind
+
+M: compound (uncrossref)
+    dup word-def \ alien-invoke swap member? [
+        drop
+    ] [
+        dup f "infer-effect" set-word-prop
+        dup f "base-case" set-word-prop
+        dup f "no-effect" set-word-prop
+        decompile
+    ] ifte ;

library/compiler/compiler.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 IN: compiler
 USING: compiler-backend compiler-frontend errors inference
-kernel lists math namespaces prettyprint io words ;
+io kernel lists math namespaces prettyprint words ;
 
 : supported-cpu? ( -- ? )
     cpu "unknown" = not ;
@@ -58,11 +58,5 @@ M: compound (compile) ( word -- )
         drop
     ] ifte ;
 
-M: compound (uncrossref)
-    dup f "infer-effect" set-word-prop
-    dup f "base-case" set-word-prop
-    dup f "no-effect" set-word-prop
-    decompile ;
-
 : recompile ( word -- )
     dup decompile compile ;

library/compiler/linearizer.factor

@@ -6,8 +6,11 @@ kernel-internals math namespaces prettyprint sequences
 strings words ;
 
 GENERIC: linearize-node* ( node -- )
+
 M: f linearize-node* ( f -- ) drop ;
 
+M: node linearize-node* ( node -- ) drop ;
+
 : linearize-node ( node -- )
     [
         dup linearize-node* node-successor linearize-node
@@ -101,11 +104,5 @@ M: #dispatch linearize-node* ( vtable -- )
     #! take in case the top of stack has that type.
     node-children dispatch-head dupd dispatch-body %label , ;
 
-M: #values linearize-node* ( node -- )
-    drop ;
-
-M: #merge linearize-node* ( node -- )
-    drop ;
-
 M: #return linearize-node* ( node -- )
     drop  f %return , ;

library/inference/branches.factor

@@ -10,7 +10,18 @@ namespaces prettyprint sequences strings vectors words ;
     dup max-length swap
     [ [ required-inputs ] keep append ] map-with ;
 
-: unify-results ( seq -- value )
+: flatten-values ( seq -- seq )
+    [
+        [
+            dup meet? [
+                meet-values [ unique, ] each
+            ] [
+                unique,
+            ] ifte
+        ] each
+    ] make-vector ;
+
+: unify-values ( seq -- value )
     #! If all values in list are equal, return the value.
     #! Otherwise, unify.
     dup [ eq? ] every? [ first ] [ <meet> ] ifte ;
@@ -18,7 +29,7 @@ namespaces prettyprint sequences strings vectors words ;
 : unify-stacks ( seq -- stack )
     #! Replace differing literals in stacks with unknown
     #! results.
-    unify-lengths flip [ unify-results ] map ;
+    unify-lengths flip [ flatten-values unify-values ] map ;
 
 : balanced? ( in out -- ? )
     [ swap length swap length - ] 2map [ = ] every? ;

library/inference/dataflow.factor

@@ -31,6 +31,14 @@ TUPLE: #simple-label ;
 C: #simple-label make-node ;
 : #simple-label ( label -- node ) param-node <#simple-label> ;
 
+TUPLE: #entry ;
+C: #entry make-node ;
+: #entry ( -- node ) meta-d get clone in-d-node <#entry> ;
+
+TUPLE: #split ;
+C: #split make-node ;
+: #split ( stack -- node ) in-d-node <#split> ;
+
 TUPLE: #call ;
 C: #call make-node ;
 : #call ( word -- node ) param-node <#call> ;
@@ -124,7 +132,8 @@ SYMBOL: current-node
 
 : penultimate-node ( node -- penultimate )
     dup node-successor dup [
-        dup node-successor [ nip penultimate-node ] [ drop ] ifte
+        dup node-successor
+        [ nip penultimate-node ] [ drop ] ifte
     ] [
         2drop f
     ] ifte ;
@@ -134,3 +143,15 @@ SYMBOL: current-node
 
 ! Recursive state. An alist, mapping words to labels.
 SYMBOL: recursive-state
+
+: each-node ( node quot -- )
+    over [
+        [ call ] 2keep swap
+        [ node-children [ swap each-node ] each-with ] 2keep
+        node-successor swap each-node
+    ] [
+        2drop
+    ] ifte ; inline
+
+: each-node-with ( obj node quot -- | quot: obj node -- )
+    swap [ with ] each-node 2drop ; inline

library/inference/optimizer.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: #<unknown> generic hashtables inference kernel lists
+USING: generic hashtables inference kernel lists
 matrices namespaces sequences vectors ;
 
 ! We use the recursive-state variable here, to track nested
@@ -10,11 +10,8 @@ matrices namespaces sequences vectors ;
 
 GENERIC: literals* ( node -- )
 
-: literals, ( node -- )
+: literals ( node -- seq )
-    [ dup literals* node-successor literals, ] when* ;
+    [ [ literals* ] each-node ] make-vector ;
-
-: literals ( node -- list )
-    [ literals, ] make-list ;
 
 GENERIC: can-kill* ( literal node -- ? )
 
@@ -32,7 +29,7 @@ GENERIC: can-kill* ( literal node -- ? )
     #! Push a list of literals that may be killed in the IR.
     dup literals [ swap can-kill? ] subset-with ;
 
-: remove-value ( value node -- )
+: remove-values ( values node -- )
     2dup [ node-in-d seq-diff ] keep set-node-in-d
     2dup [ node-out-d seq-diff ] keep set-node-out-d
     2dup [ node-in-r seq-diff ] keep set-node-in-r
@@ -42,20 +39,8 @@ GENERIC: kill-node* ( literals node -- )
 
 M: node kill-node* ( literals node -- ) 2drop ;
 
-DEFER: kill-node
-
-: kill-children ( literals node -- )
-    node-children [ kill-node ] each-with ;
-
 : kill-node ( literals node -- )
-    dup [
+    [ 2dup kill-node* remove-values ] each-node-with ;
-        2dup kill-children
-        2dup kill-node*
-        2dup remove-value
-        node-successor kill-node
-    ] [
-        2drop
-    ] ifte ;
 
 GENERIC: optimize-node* ( node -- node )
 
@@ -68,11 +53,6 @@ M: node optimize-children ( node -- )
         node-children [ optimize-node swap >r or r> ] map
     ] keep set-node-children ;
 
-: optimize-label ( node -- node )
-    dup node-param recursive-state [ cons ] change
-    delegate optimize-children
-    recursive-state [ cdr ] change ;
-
 : keep-optimizing ( node -- node ? )
     dup optimize-node* dup t =
     [ drop f ] [ nip keep-optimizing t or ] ifte ;
@@ -100,17 +80,9 @@ M: node optimize-children ( node -- )
     inline
 
 ! Generic nodes
-M: node literals* ( node -- )
+M: node literals* ( node -- ) drop ;
-    node-children [ literals, ] each ;
 
-M: f can-kill* ( literal node -- ? )
+M: node can-kill* ( literal node -- ? ) uses-value? not ;
-    2drop t ;
-
-M: node can-kill* ( literal node -- ? )
-    uses-value? not ;
-
-M: node kill-node* ( literals node -- )
-    2drop ;
 
 M: f optimize-node* drop t ;
 
@@ -198,6 +170,11 @@ M: #label can-kill* ( literal node -- ? )
 M: #simple-label can-kill* ( literal node -- ? )
     node-children first can-kill? ;
 
+: optimize-label ( node -- node )
+    dup node-param recursive-state [ cons ] change
+    delegate optimize-children
+    recursive-state [ cdr ] change ;
+
 M: #label optimize-children optimize-label ;
 
 M: #simple-label optimize-children optimize-label ;

library/inference/print-dataflow.factor

@@ -41,13 +41,12 @@ M: #drop node>quot ( ? node -- )
 
 DEFER: dataflow>quot
 
-M: #call node>quot ( ? node -- )
+: #call>quot ( ? node -- )
     dup node-param , dup effect-str comment, ;
 
-M: #call-label node>quot ( ? node -- )
+M: #call node>quot ( ? node -- ) #call>quot ;
-    #! Even if the flag is off, we still output the annotation.
+
-    >r drop t r>
+M: #call-label node>quot ( ? node -- ) #call>quot ;
-    "#call-label: " over node-param word-name append comment, ;
 
 M: #label node>quot ( ? node -- )
     [ "#label: " over node-param word-name append comment, ] 2keep
@@ -70,6 +69,10 @@ M: #values node>quot ( ? node -- ) "#values" comment, ;
 
 M: #merge node>quot ( ? node -- ) "#merge" comment, ;
 
+M: #entry node>quot ( ? node -- ) "#entry" comment, ;
+
+M: #split node>quot ( ? node -- ) "#split" comment, ;
+
 : (dataflow>quot) ( ? node -- )
     dup [
         2dup node>quot node-successor (dataflow>quot)

library/inference/recursive-values.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: inference
+USING: kernel namespaces prettyprint sequences vectors ;
+
+! Technical detail: need to figure out which values survive
+! inner recursions in #labels.
+
+GENERIC: collect-recursion* ( label node -- )
+
+M: node collect-recursion* ( label node -- ) 2drop ;
+
+M: #call-label collect-recursion* ( label node -- )
+    tuck node-param = [ node-in-d , ] [ drop ] ifte ;
+
+: collect-recursion ( label node -- seq )
+    #! Collect the input stacks of all #call-label nodes that
+    #! call given label.
+    [ [ collect-recursion* ] each-node-with ] make-vector ;
+
+: first-child ( child node -- )
+    [ node-children first over set-node-successor 1vector ] keep
+    set-node-children ;
+
+M: #label optimize-node* ( node -- node/t )
+    dup dup node-param over collect-recursion >r
+    node-children first node-in-d r> swap add
+    unify-stacks #split swap first-child t ;
+
+M: #split optimize-node* ( node -- node/t )
+    node-successor ;

library/inference/words.factor

@@ -39,7 +39,7 @@ hashtables parser prettyprint ;
 
 : inline-block ( word -- node-block )
     gensym over word-def cons [
-        inhibit-parital  word-def infer-quot
+        #entry node,  inhibit-parital  word-def infer-quot
     ] with-block ;
 
 : inline-compound ( word -- )
@@ -99,8 +99,10 @@ M: symbol apply-object ( word -- )
 
 : (base-case) ( word label -- )
     over "inline" word-prop [
+        meta-d get clone >r
         over inline-block drop
-        [ #call-label ] [ #call ] ?ifte node,
+        [ #call-label ] [ #call ] ?ifte
+        r> over set-node-in-d node,
     ] [
         drop dup t infer-compound "base-case" set-word-prop
     ] ifte ;