Working on sparse conditional constant propagation and untupling

unfinished/compiler/frontend/frontend-tests.factor

@@ -1,6 +0,0 @@
-IN: compiler.frontend.tests
-USING: compiler.frontend tools.test ;
-
-\ dataflow must-infer
-\ dataflow-with must-infer
-\ word-dataflow must-infer

unfinished/compiler/frontend/frontend.factor

@@ -1,79 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors quotations kernel sequences namespaces assocs
-words generic generic.standard generic.standard.engines arrays
-kernel.private combinators vectors stack-checker
-stack-checker.state stack-checker.visitor stack-checker.errors
-stack-checker.backend compiler.tree.builder ;
-IN: compiler.frontend
-
-: with-dataflow ( quot -- dataflow )
-    [ tree-builder new dataflow-visitor set ] prepose
-    with-infer first>> ; inline
-
-GENERIC# dataflow-with 1 ( quot stack -- dataflow )
-
-M: callable dataflow-with
-    #! Not safe to call from inference transforms.
-    [
-        >vector meta-d set
-        f infer-quot
-    ] with-dataflow nip ;
-
-: dataflow ( quot -- dataflow ) f dataflow-with ;
-
-: (make-specializer) ( class picker -- quot )
-    swap "predicate" word-prop append ;
-
-: make-specializer ( classes -- quot )
-    dup length <reversed>
-    [ (picker) 2array ] 2map
-    [ drop object eq? not ] assoc-filter
-    dup empty? [ drop [ t ] ] [
-        [ (make-specializer) ] { } assoc>map
-        unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
-    ] if ;
-
-: specializer-cases ( quot word -- default alist )
-    dup [ array? ] all? [ 1array ] unless [
-        [ make-specializer ] keep
-        '[ , declare ] pick append
-    ] { } map>assoc ;
-
-: method-declaration ( method -- quot )
-    dup "method-generic" word-prop dispatch# object <array>
-    swap "method-class" word-prop prefix ;
-
-: specialize-method ( quot method -- quot' )
-    method-declaration '[ , declare ] prepend ;
-
-: specialize-quot ( quot specializer -- quot' )
-    specializer-cases alist>quot ;
-
-: standard-method? ( method -- ? )
-    dup method-body? [
-        "method-generic" word-prop standard-generic?
-    ] [ drop f ] if ;
-
-: specialized-def ( word -- quot )
-    dup def>> swap {
-        { [ dup standard-method? ] [ specialize-method ] }
-        {
-            [ dup "specializer" word-prop ]
-            [ "specializer" word-prop specialize-quot ]
-        }
-        [ drop ]
-    } cond ;
-
-: word-dataflow ( word -- effect dataflow )
-    [
-        [
-            dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
-            dup "no-compile" word-prop [ cannot-infer-effect ] when
-            dup specialized-def over dup 2array 1array infer-quot
-            finish-word
-        ] maybe-cannot-infer
-    ] with-dataflow ;
-
-: specialized-length ( specializer -- n )
-    dup [ array? ] all? [ first ] when length ;

unfinished/compiler/tree/builder/builder-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax sequences quotations words 
 compiler.tree stack-checker.errors ;
-IN: compiler.frontend
+IN: compiler.tree.builder
 
 ARTICLE: "specializers" "Word specializers"
 "The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
@@ -22,15 +22,15 @@ $nl
 "The specialized version of a word which will be compiled by the compiler can be inspected:"
 { $subsection specialized-def } ;
 
-HELP: dataflow
+HELP: build-tree
 { $values { "quot" quotation } { "dataflow" node } }
-{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation." }
+{ $description "Attempts to construct tree SSA IR from a quotation." }
 { $notes "This is the first stage of the compiler." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
 
-HELP: dataflow-with
+HELP: build-tree-with
 { $values { "quot" quotation } { "stack" sequence } { "dataflow" node } }
-{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." }
+{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
 
 HELP: specialized-def

unfinished/compiler/tree/builder/builder-tests.factor

@@ -0,0 +1,6 @@
+IN: compiler.tree.builder.tests
+USING: compiler.tree.builder tools.test ;
+
+\ build-tree must-infer
+\ build-tree-with must-infer
+\ build-tree-from-word must-infer

unfinished/compiler/tree/builder/builder.factor

@@ -1,32 +1,79 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel sequences compiler.tree
+USING: fry accessors quotations kernel sequences namespaces assocs
-stack-checker.visitor ;
+words generic generic.standard generic.standard.engines arrays
+kernel.private combinators vectors stack-checker
+stack-checker.state stack-checker.visitor stack-checker.errors
+stack-checker.backend compiler.tree ;
 IN: compiler.tree.builder
 
-TUPLE: tree-builder first last ;
+: with-tree-builder ( quot -- dataflow )
+    [ node-list new stack-visitor set ] prepose
+    with-infer first>> ; inline
 
-: node, ( node -- )
+GENERIC# build-tree-with 1 ( quot stack -- dataflow )
-    dataflow-visitor get swap
-    over last>>
-    [ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
-    [ [ >>first ] [ >>last ] bi drop ]
-    if ;
 
-M: tree-builder child-visitor tree-builder new ;
+M: callable build-tree-with
-M: tree-builder #introduce, #introduce node, ;
+    #! Not safe to call from inference transforms.
-M: tree-builder #call, #call node, ;
+    [
-M: tree-builder #call-recursive, #call-recursive node, ;
+        >vector meta-d set
-M: tree-builder #push, #push node, ;
+        f infer-quot
-M: tree-builder #shuffle, #shuffle node, ;
+    ] with-tree-builder nip ;
-M: tree-builder #drop, #drop node, ;
+
-M: tree-builder #>r, #>r node, ;
+: build-tree ( quot -- dataflow ) f build-tree-with ;
-M: tree-builder #r>, #r> node, ;
+
-M: tree-builder #return, #return node, ;
+: (make-specializer) ( class picker -- quot )
-M: tree-builder #terminate, #terminate node, ;
+    swap "predicate" word-prop append ;
-M: tree-builder #if, [ first>> ] bi@ #if node, ;
+
-M: tree-builder #dispatch, [ first>> ] map #dispatch node, ;
+: make-specializer ( classes -- quot )
-M: tree-builder #phi, #phi node, ;
+    dup length <reversed>
-M: tree-builder #declare, #declare node, ;
+    [ (picker) 2array ] 2map
-M: tree-builder #recursive, first>> #recursive node, ;
+    [ drop object eq? not ] assoc-filter
-M: tree-builder #copy, #copy node, ;
+    dup empty? [ drop [ t ] ] [
+        [ (make-specializer) ] { } assoc>map
+        unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+    ] if ;
+
+: specializer-cases ( quot word -- default alist )
+    dup [ array? ] all? [ 1array ] unless [
+        [ make-specializer ] keep
+        '[ , declare ] pick append
+    ] { } map>assoc ;
+
+: method-declaration ( method -- quot )
+    dup "method-generic" word-prop dispatch# object <array>
+    swap "method-class" word-prop prefix ;
+
+: specialize-method ( quot method -- quot' )
+    method-declaration '[ , declare ] prepend ;
+
+: specialize-quot ( quot specializer -- quot' )
+    specializer-cases alist>quot ;
+
+: standard-method? ( method -- ? )
+    dup method-body? [
+        "method-generic" word-prop standard-generic?
+    ] [ drop f ] if ;
+
+: specialized-def ( word -- quot )
+    dup def>> swap {
+        { [ dup standard-method? ] [ specialize-method ] }
+        {
+            [ dup "specializer" word-prop ]
+            [ "specializer" word-prop specialize-quot ]
+        }
+        [ drop ]
+    } cond ;
+
+: build-tree-from-word ( word -- effect dataflow )
+    [
+        [
+            dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
+            dup "no-compile" word-prop [ cannot-infer-effect ] when
+            dup specialized-def over dup 2array 1array infer-quot
+            finish-word
+        ] maybe-cannot-infer
+    ] with-tree-builder ;
+
+: specialized-length ( specializer -- n )
+    dup [ array? ] all? [ first ] when length ;

unfinished/compiler/tree/co

@@ -0,0 +1 @@
+

unfinished/compiler/tree/combinators/combinators-tests.factor

@@ -1,9 +1,9 @@
 IN: compiler.tree.combinators.tests
-USING: compiler.tree.combinators compiler.frontend tools.test
+USING: compiler.tree.combinators compiler.tree.builder tools.test
 kernel ;
 
-[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
+[ ] [ [ 1 ] build-tree [ ] transform-nodes drop ] unit-test
-[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
+[ ] [ [ 1 2 3 ] build-tree [ ] transform-nodes drop ] unit-test
 
 { 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
 

unfinished/compiler/tree/combinators/combinators.factor

@@ -5,18 +5,6 @@ sequences words vectors math.intervals effects classes
 accessors combinators compiler.tree ;
 IN: compiler.tree.combinators
 
-: node-exists? ( node quot -- ? )
-    over [
-        2dup 2slip rot [
-            2drop t
-        ] [
-            [ [ children>> ] [ successor>> ] bi suffix ] dip
-            '[ , node-exists? ] contains?
-        ] if
-    ] [
-        2drop f
-    ] if ; inline
-
 SYMBOL: node-stack
 
 : >node ( node -- ) node-stack get push ;
@@ -34,8 +22,8 @@ SYMBOL: node-stack
 
 : (each-node) ( quot -- next )
     node@ [ swap call ] 2keep
-    node-children [
+    children>> [
-        [
+        first>> [
             [ (each-node) ] keep swap
         ] iterate-nodes
     ] each drop
@@ -52,15 +40,7 @@ SYMBOL: node-stack
     ] with-node-iterator ; inline
 
 : map-children ( node quot -- )
-    over [
+    [ children>> ] dip '[ , change-first drop ] each ; inline
-        over children>> [
-            '[ , map ] change-children drop
-        ] [
-            2drop
-        ] if
-    ] [
-        2drop
-    ] if ; inline
 
 : (transform-nodes) ( prev node quot -- )
     dup >r call dup [

unfinished/compiler/tree/comparisons/comparisons.factor

@@ -0,0 +1,50 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.order math.intervals assocs combinators ;
+IN: compiler.tree.comparisons
+
+! Some utilities for working with comparison operations.
+
+: comparison-ops { < > <= >= } ;
+
+: generic-comparison-ops { before? after? before=? after=? } ;
+
+: assumption ( i1 i2 op -- i3 )
+    {
+        { \ <  [ assume< ] }
+        { \ >  [ assume> ] }
+        { \ <= [ assume<= ] }
+        { \ >= [ assume>= ] }
+    } case ;
+
+: interval-comparison ( i1 i2 op -- result )
+    {
+        { \ <  [ interval< ] }
+        { \ >  [ interval> ] }
+        { \ <= [ interval<= ] }
+        { \ >= [ interval>= ] }
+    } case ;
+
+: swap-comparison ( op -- op' )
+    {
+        { < > }
+        { > < }
+        { <= >= }
+        { >= <= }
+    } at ;
+
+: negate-comparison ( op -- op' )
+    {
+        { < >= }
+        { > <= }
+        { <= > }
+        { >= < }
+    } at ;
+
+: specific-comparison ( op -- op' )
+    {
+        { before? < }
+        { after? > }
+        { before=? <= }
+        { after=? >= }
+    } at ;

unfinished/compiler/tree/copy-equiv/copy-equiv.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces disjoint-sets sequences assocs
+kernel accessors fry
+compiler.tree compiler.tree.def-use compiler.tree.combinators ;
+IN: compiler.tree.copy-equiv
+
+! Disjoint set of copy equivalence
+SYMBOL: copies
+
+: is-copy-of ( val copy -- ) copies get equate ;
+
+: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
+
+: resolve-copy ( copy -- val ) copies get representative ;
+
+: introduce-value ( val -- ) copies get add-atom ;
+
+GENERIC: compute-copy-equiv* ( node -- )
+
+M: #shuffle compute-copy-equiv*
+    [ out-d>> dup ] [ mapping>> ] bi
+    '[ , at ] map swap are-copies-of ;
+
+M: #>r compute-copy-equiv*
+    [ in-d>> ] [ out-r>> ] bi are-copies-of ;
+
+M: #r> compute-copy-equiv*
+    [ in-r>> ] [ out-d>> ] bi are-copies-of ;
+
+M: #copy compute-copy-equiv*
+    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
+
+M: node compute-copy-equiv* drop ;
+
+: compute-copy-equiv ( node -- node )
+    <disjoint-set> copies set
+    dup [
+        [ node-defs-values [ introduce-value ] each ]
+        [ compute-copy-equiv* ]
+        bi
+    ] each-node ;

unfinished/compiler/tree/dead-code/dead-code-tests.factor

@@ -1,4 +1,4 @@
-USING: namespaces assocs sequences compiler.frontend
+USING: namespaces assocs sequences compiler.tree.builder
 compiler.tree.dead-code compiler.tree.def-use compiler.tree
 compiler.tree.combinators tools.test kernel math
 stack-checker.state accessors ;
@@ -7,7 +7,7 @@ IN: compiler.tree.dead-code.tests
 \ remove-dead-code must-infer
 
 : count-live-values ( quot -- n )
-    dataflow
+    build-tree
     compute-def-use
     remove-dead-code
     compute-def-use

unfinished/compiler/tree/dead-code/dead-code.factor

@@ -1,106 +1,44 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors namespaces assocs dequeues search-dequeues
-kernel sequences words sets stack-checker.inlining compiler.tree
+kernel sequences words sets stack-checker.inlining
-compiler.tree.combinators compiler.tree.def-use ;
+compiler.tree
+compiler.tree.dfa
+compiler.tree.dfa.backward
+compiler.tree.combinators ;
 IN: compiler.tree.dead-code
 
 ! Dead code elimination: remove #push and flushable #call whose
-! outputs are unused.
+! outputs are unused using backward DFA.
-
-SYMBOL: live-values
-SYMBOL: work-list
-
-: live-value? ( value -- ? )
-    live-values get at ;
-
-: look-at-value ( values -- )
-    work-list get push-front ;
-
-: look-at-values ( values -- )
-    work-list get '[ , push-front ] each ;
-
 GENERIC: mark-live-values ( node -- )
 
-: look-at-inputs ( node -- ) in-d>> look-at-values ;
-
-: look-at-outputs ( node -- ) out-d>> look-at-values ;
-
-M: #introduce mark-live-values look-at-outputs ;
-
 M: #if mark-live-values look-at-inputs ;
 
 M: #dispatch mark-live-values look-at-inputs ;
 
 M: #call mark-live-values
-    dup word>> "flushable" word-prop [ drop ] [
+    dup word>> "flushable" word-prop
-        [ look-at-inputs ]
+    [ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
-        [ look-at-outputs ]
-        bi
-    ] if ;
 
 M: #return mark-live-values
     #! Values returned by local #recursive functions can be
     #! killed if they're unused.
-    dup label>>
+    dup label>> [ drop ] [ look-at-inputs ] if ;
-    [ drop ] [ look-at-inputs ] if ;
 
 M: node mark-live-values drop ;
 
-GENERIC: propagate* ( value node -- )
+SYMBOL: live-values
 
-M: #copy propagate*
+: live-value? ( value -- ? ) live-values get at ;
-    #! If the output of a copy is live, then the corresponding
-    #! input is live also.
-    [ out-d>> index ] keep in-d>> nth look-at-value ;
-
-M: #call propagate*
-    #! If any of the outputs of a call are live, then all
-    #! inputs and outputs must be live.
-    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
-
-M: #call-recursive propagate*
-    #! If the output of a copy is live, then the corresponding
-    #! inputs to #return nodes are live also.
-    [ out-d>> <reversed> index ] keep label>> returns>>
-    [ <reversed> nth look-at-value ] with each ;
-
-M: #>r propagate* nip in-d>> first look-at-value ;
-
-M: #r> propagate* nip in-r>> first look-at-value ;
-
-M: #shuffle propagate* mapping>> at look-at-value ;
-
-: look-at-corresponding ( value inputs outputs -- )
-    [ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
-
-M: #phi propagate*
-    #! If any of the outputs of a #phi are live, then the
-    #! corresponding inputs are live too.
-    [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
-    [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
-    2bi ;
-
-M: node propagate* 2drop ;
-
-: propogate-liveness ( value -- )
-    live-values get 2dup key? [
-        2drop
-    ] [
-        dupd conjoin
-        dup defined-by propagate*
-    ] if ;
 
 : compute-live-values ( node -- )
-    #! We add f initially because #phi nodes can have f in their
+    [ mark-live-values ] backward-dfa live-values set ;
-    #! inputs.
-    <hashed-dlist> work-list set
-    H{ { f f } } clone live-values set
-    [ mark-live-values ] each-node
-    work-list get [ propogate-liveness ] slurp-dequeue ;
 
 GENERIC: remove-dead-values* ( node -- )
 
+M: #introduce remove-dead-values*
+    [ [ live-value? ] filter ] change-values drop ;
+
 M: #>r remove-dead-values*
     dup out-r>> first live-value? [ { } >>out-r ] unless
     dup in-d>> first live-value? [ { } >>in-d ] unless
@@ -118,13 +56,6 @@ M: #push remove-dead-values*
 : filter-corresponding-values ( in out -- in' out' )
     zip live-values get '[ drop _ , key? ] assoc-filter unzip ;
 
-: remove-dead-copies ( node -- )
-    dup
-    [ in-d>> ] [ out-d>> ] bi
-    filter-corresponding-values
-    [ >>in-d ] [ >>out-d ] bi*
-    drop ;
-
 : filter-live ( values -- values' )
     [ live-value? ] filter ;
 
@@ -133,9 +64,16 @@ M: #shuffle remove-dead-values*
     [ filter-live ] change-out-d
     drop ;
 
-M: #declare remove-dead-values* remove-dead-copies ;
+M: #declare remove-dead-values*
+    [ [ drop live-value? ] assoc-filter ] change-declaration
+    drop ;
 
-M: #copy remove-dead-values* remove-dead-copies ;
+M: #copy remove-dead-values*
+    dup
+    [ in-d>> ] [ out-d>> ] bi
+    filter-corresponding-values
+    [ >>in-d ] [ >>out-d ] bi*
+    drop ;
 
 : remove-dead-phi-d ( #phi -- #phi )
     dup
@@ -156,46 +94,54 @@ M: #phi remove-dead-values*
 
 M: node remove-dead-values* drop ;
 
+M: f remove-dead-values* drop ;
+
 GENERIC: remove-dead-nodes* ( node -- newnode/t )
 
+: prune-if-empty ( node seq -- successor/t )
+    empty? [ successor>> ] [ drop t ] if ; inline
+
+M: #introduce remove-dead-nodes* dup values>> prune-if-empty ;
+
 : live-call? ( #call -- ? )
     out-d>> [ live-value? ] contains? ;
 
+M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ;
+
 M: #call remove-dead-nodes*
     dup live-call? [ drop t ] [
         [ in-d>> #drop ] [ successor>> ] bi >>successor
     ] if ;
 
-: prune-if ( node quot -- successor/t )
+M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
-    over >r call [ r> successor>> ] [ r> drop t ] if ;
-    inline
 
-M: #shuffle remove-dead-nodes* 
+M: #push remove-dead-nodes* dup out-d>> prune-if-empty ;
-    [ in-d>> empty? ] prune-if ;
 
-M: #push remove-dead-nodes*
+M: #>r remove-dead-nodes* dup in-d>> prune-if-empty ;
-    [ out-d>> empty? ] prune-if ;
 
-M: #>r remove-dead-nodes*
+M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
-    [ in-d>> empty? ] prune-if ;
 
-M: #r> remove-dead-nodes*
+M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
-    [ in-r>> empty? ] prune-if ;
+
+: (remove-dead-code) ( node -- newnode )
+    [
+        dup remove-dead-values*
+        dup remove-dead-nodes* dup t eq?
+        [ drop ] [ nip (remove-dead-code) ] if
+    ] transform-nodes ;
+
+M: #if remove-dead-nodes*
+    [ (remove-dead-code) ] map-children t ;
+
+M: #dispatch remove-dead-nodes*
+    [ (remove-dead-code) ] map-children t ;
+
+M: #recursive remove-dead-nodes*
+    [ (remove-dead-code) ] change-child drop t ;
 
 M: node remove-dead-nodes* drop t ;
 
-: (remove-dead-code) ( node -- newnode )
+M: f remove-dead-nodes* drop t ;
-    dup [
-        dup remove-dead-values*
-        dup remove-dead-nodes* dup t eq? [
-            drop dup [ (remove-dead-code) ] map-children
-        ] [
-            nip (remove-dead-code)
-        ] if
-    ] when ;
 
 : remove-dead-code ( node -- newnode )
-    [
+    [ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;
-        [ compute-live-values ]
-        [ [ (remove-dead-code) ] transform-nodes ] bi
-    ] with-scope ;

unfinished/compiler/tree/def-use/def-use-tests.factor

@@ -1,13 +1,13 @@
 USING: accessors namespaces assocs kernel sequences math
 tools.test words sets combinators.short-circuit
-stack-checker.state compiler.tree compiler.frontend
+stack-checker.state compiler.tree compiler.tree.builder
 compiler.tree.def-use arrays kernel.private ;
 IN: compiler.tree.def-use.tests
 
 \ compute-def-use must-infer
 
 [ t ] [
-    [ 1 2 3 ] dataflow compute-def-use drop
+    [ 1 2 3 ] build-tree compute-def-use drop
     def-use get {
         [ assoc-size 3 = ]
         [ values [ uses>> [ #return? ] all? ] all? ]
@@ -29,5 +29,5 @@ IN: compiler.tree.def-use.tests
     [ [ 1 ] [ call 2 ] curry call + ]
     [ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
 } [
-    [ ] swap [ dataflow compute-def-use drop ] curry unit-test
+    [ ] swap [ build-tree compute-def-use drop ] curry unit-test
 ] each

unfinished/compiler/tree/def-use/def-use.factor

@@ -28,6 +28,8 @@ TUPLE: definition value node uses ;
 
 GENERIC: node-uses-values ( node -- values )
 
+M: #declare node-uses-values declaration>> keys ;
+
 M: #phi node-uses-values
     [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi
     append sift prune ;

unfinished/compiler/tree/dfa/backward/backward.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.dfa.backward
+USING: accessors sequences assocs kernel compiler.tree
+compiler.tree.dfa ;
+
+GENERIC: backward ( value node -- )
+
+M: #copy backward
+    #! If the output of a copy is live, then the corresponding
+    #! input is live also.
+    [ out-d>> index ] keep in-d>> nth look-at-value ;
+
+M: #call backward
+    #! If any of the outputs of a call are live, then all
+    #! inputs and outputs must be live.
+    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #call-recursive backward
+    #! If the output of a copy is live, then the corresponding
+    #! inputs to #return nodes are live also.
+    [ out-d>> <reversed> index ] keep label>> returns>>
+    [ <reversed> nth look-at-value ] with each ;
+
+M: #>r backward nip in-d>> first look-at-value ;
+
+M: #r> backward nip in-r>> first look-at-value ;
+
+M: #shuffle backward mapping>> at look-at-value ;
+
+M: #phi backward
+    #! If any of the outputs of a #phi are live, then the
+    #! corresponding inputs are live too.
+    [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
+    [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
+    2bi ;
+
+M: node backward 2drop ;
+
+: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline

unfinished/compiler/tree/dfa/dfa.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors namespaces assocs dequeues search-dequeues
+kernel sequences words sets stack-checker.inlining compiler.tree
+compiler.tree.def-use compiler.tree.combinators ;
+IN: compiler.tree.dfa
+
+! Dataflow analysis
+SYMBOL: work-list
+
+: look-at-value ( values -- )
+    work-list get push-front ;
+
+: look-at-values ( values -- )
+    work-list get '[ , push-front ] each ;
+
+: look-at-inputs ( node -- ) in-d>> look-at-values ;
+
+: look-at-outputs ( node -- ) out-d>> look-at-values ;
+
+: look-at-corresponding ( value inputs outputs -- )
+    [ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
+
+: init-dfa ( -- )
+    #! We add f initially because #phi nodes can have f in their
+    #! inputs.
+    <hashed-dlist> work-list set ;
+
+: iterate-dfa ( value assoc quot -- )
+    2over key? [
+        3drop
+    ] [
+        [ dupd conjoin dup defined-by ] dip call
+    ] if ; inline
+
+: dfa ( node mark-quot iterate-quot -- assoc )
+    init-dfa
+    [ each-node ] dip
+    work-list get H{ { f f } } clone
+    [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline

unfinished/compiler/tree/propagation/branches/branches.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry kernel sequences assocs accessors namespaces
-math.intervals arrays classes.algebra
+math.intervals arrays classes.algebra locals
 compiler.tree
 compiler.tree.def-use
 compiler.tree.propagation.info
@@ -14,19 +14,28 @@ IN: compiler.tree.propagation.branches
 GENERIC: child-constraints ( node -- seq )
 
 M: #if child-constraints
-    in-d>> first
+    in-d>> first [ =t ] [ =f ] bi 2array ;
-    [ <true-constraint> ] [ <false-constraint> ] bi
-    2array ;
 
 M: #dispatch child-constraints drop f ;
 
+GENERIC: live-children ( #branch -- children )
+
+M: #if live-children
+    [ children>> ] [ in-d>> first value-info possible-boolean-values ] bi
+    [ t swap memq? [ first ] [ drop f ] if ]
+    [ f swap memq? [ second ] [ drop f ] if ]
+    2bi 2array ;
+
+M: #dispatch live-children
+    children>> ;
+
 : infer-children ( node -- assocs )
-    [ children>> ] [ child-constraints ] bi [
+    [ live-children ] [ child-constraints ] bi [
         [
             value-infos [ clone ] change
             constraints [ clone ] change
             assume
-            (propagate)
+            [ first>> (propagate) ] when*
         ] H{ } make-assoc
     ] 2map ;
 
@@ -37,13 +46,23 @@ M: #dispatch child-constraints drop f ;
     [ swap (merge-value-infos) ] dip set-value-infos ;
 
 : propagate-branch-phi ( results #phi -- )
-    [ nip node-defs-values [ introduce-value ] each ]
     [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
     [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
-    2tri ;
+    2bi ;
+
+:: branch-phi-constraints ( x #phi -- )
+    #phi [ out-d>> ] [ phi-in-d>> ] bi [
+        first2 2dup and [ USE: prettyprint
+            [ [ =t x =t /\ ] [ =t x =f /\ ] bi* \/ swap t--> dup  . assume ]
+            [ [ =f x =t /\ ] [ =f x =f /\ ] bi* \/ swap f--> dup  . assume ]
+            3bi
+        ] [ 3drop ] if
+    ] 2each ;
 
 : merge-children ( results node -- )
-    successor>> propagate-branch-phi ;
+    [ successor>> propagate-branch-phi ]
+    [ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ]
+    bi ;
 
 M: #branch propagate-around
     [ infer-children ] [ merge-children ] [ annotate-node ] tri ;

unfinished/compiler/tree/propagation/constraints/constraints.factor

@@ -2,7 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs math math.intervals kernel accessors
 sequences namespaces disjoint-sets classes classes.algebra
-combinators words compiler.tree compiler.tree.propagation.info ;
+combinators words
+compiler.tree compiler.tree.propagation.info
+compiler.tree.copy-equiv ;
 IN: compiler.tree.propagation.constraints
 
 ! A constraint is a statement about a value.
@@ -12,12 +14,12 @@ SYMBOL: constraints
 
 GENERIC: assume ( constraint -- )
 GENERIC: satisfied? ( constraint -- ? )
+GENERIC: satisfiable? ( constraint -- ? )
 
 ! Boolean constraints
 TUPLE: true-constraint value ;
 
-: <true-constraint> ( value -- constriant )
+: =t ( value -- constriant ) resolve-copy true-constraint boa ;
-    resolve-copy true-constraint boa ;
 
 M: true-constraint assume
     [ constraints get at [ assume ] when* ]
@@ -27,10 +29,12 @@ M: true-constraint assume
 M: true-constraint satisfied?
     value>> value-info class>> \ f class-not class<= ;
 
+M: true-constraint satisfiable?
+    value>> value-info class>> \ f class-not classes-intersect? ;
+
 TUPLE: false-constraint value ;
 
-: <false-constraint> ( value -- constriant )
+: =f ( value -- constriant ) resolve-copy false-constraint boa ;
-    resolve-copy false-constraint boa ;
 
 M: false-constraint assume
     [ constraints get at [ assume ] when* ]
@@ -40,10 +44,13 @@ M: false-constraint assume
 M: false-constraint satisfied?
     value>> value-info class>> \ f class<= ;
 
+M: false-constraint satisfiable?
+    value>> value-info class>> \ f classes-intersect? ;
+
 ! Class constraints
 TUPLE: class-constraint value class ;
 
-: <class-constraint> ( value class -- constraint )
+: is-instance-of ( value class -- constraint )
     [ resolve-copy ] dip class-constraint boa ;
 
 M: class-constraint assume
@@ -52,7 +59,7 @@ M: class-constraint assume
 ! Interval constraints
 TUPLE: interval-constraint value interval ;
 
-: <interval-constraint> ( value interval -- constraint )
+: is-in-interval ( value interval -- constraint )
     [ resolve-copy ] dip interval-constraint boa ;
 
 M: interval-constraint assume
@@ -61,7 +68,7 @@ M: interval-constraint assume
 ! Literal constraints
 TUPLE: literal-constraint value literal ;
 
-: <literal-constraint> ( value literal -- constraint )
+: is-equal-to ( value literal -- constraint )
     [ resolve-copy ] dip literal-constraint boa ;
 
 M: literal-constraint assume
@@ -70,29 +77,48 @@ M: literal-constraint assume
 ! Implication constraints
 TUPLE: implication p q ;
 
-C: <implication> implication
+C: --> implication
 
 M: implication assume
     [ q>> ] [ p>> ] bi
     [ constraints get set-at ]
     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
 
+M: implication satisfiable?
+    [ q>> satisfiable? ] [ p>> satisfiable? not ] bi or ;
+
 ! Conjunction constraints
 TUPLE: conjunction p q ;
 
-C: <conjunction> conjunction
+C: /\ conjunction
 
 M: conjunction assume [ p>> assume ] [ q>> assume ] bi ;
 
+M: conjunction satisfiable?
+    [ p>> satisfiable? ] [ q>> satisfiable? ] bi and ;
+
+! Disjunction constraints
+TUPLE: disjunction p q ;
+
+C: \/ disjunction
+
+M: disjunction assume
+    {
+        { [ dup p>> satisfiable? not ] [ q>> assume ] }
+        { [ dup q>> satisfiable? not ] [ p>> assume ] }
+        [ drop ]
+    } cond ;
+
+M: disjunction satisfiable?
+    [ p>> satisfiable? ] [ q>> satisfiable? ] bi or ;
+
 ! No-op
 M: f assume drop ;
 
 ! Utilities
-: if-true ( constraint boolean-value -- constraint' )
+: t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
-   <true-constraint> swap <implication> ;
 
-: if-false ( constraint boolean-value -- constraint' )
+: f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
-    <false-constraint> swap <implication> ;
 
 : <conditional> ( true-constr false-constr boolean-value -- constraint )
-    tuck [ if-true ] [ if-false ] 2bi* <conjunction> ;
+    tuck [ t--> ] [ f--> ] 2bi* /\ ;

unfinished/compiler/tree/propagation/info/info-tests.factor

@@ -2,6 +2,8 @@ USING: accessors math math.intervals sequences classes.algebra
 math kernel tools.test compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.info.tests
 
+[ f ] [ 0.0 -0.0 eql? ] unit-test
+
 [ t ] [
     number <class-info>
     sequence <class-info>
@@ -49,7 +51,7 @@ IN: compiler.tree.propagation.info.tests
     value-info-intersect >literal<
 ] unit-test
 
-[ T{ value-info f fixnum empty-interval f f } ] [
+[ T{ value-info f null empty-interval f f } ] [
     fixnum -10 0 [a,b] <class/interval-info>
     fixnum 19 29 [a,b] <class/interval-info>
     value-info-intersect

unfinished/compiler/tree/propagation/info/info.factor

@@ -1,26 +1,19 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs classes classes.algebra kernel accessors math
-math.intervals namespaces disjoint-sets sequences words
+math.intervals namespaces sequences words combinators arrays
-combinators ;
+compiler.tree.copy-equiv ;
 IN: compiler.tree.propagation.info
 
 SYMBOL: +interval+
 
 GENERIC: eql? ( obj1 obj2 -- ? )
 M: object eql? eq? ;
-M: number eql? [ [ class ] bi@ = ] [ number= ] 2bi and ;
+M: fixnum eql? eq? ;
-
+M: bignum eql? over bignum? [ = ] [ 2drop f ] if ;
-! Disjoint set of copy equivalence
+M: ratio eql? over ratio? [ = ] [ 2drop f ] if ;
-SYMBOL: copies
+M: float eql? over float? [ [ double>bits ] bi@ = ] [ 2drop f ] if ;
-
+M: complex eql? over complex? [ = ] [ 2drop f ] if ;
-: is-copy-of ( val copy -- ) copies get equate ;
-
-: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
-
-: resolve-copy ( copy -- val ) copies get representative ;
-
-: introduce-value ( val -- ) copies get add-atom ;
 
 ! Value info represents a set of objects. Don't mutate value infos
 ! you receive, always construct new ones. We don't declare the
@@ -36,16 +29,18 @@ literal? ;
     [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
 
 : interval>literal ( class interval -- literal literal? )
+    #! If interval has zero length and the class is sufficiently
+    #! precise, we can turn it into a literal
     dup empty-interval eq? [
         2drop f f
     ] [
         dup from>> first {
             { [ over interval-length 0 > ] [ 3drop f f ] }
-            { [ over from>> second not ] [ 3drop f f ] }
-            { [ over to>> second not ] [ 3drop f f ] }
-            { [ pick fixnum class<= ] [ 2nip >fixnum t ] }
             { [ pick bignum class<= ] [ 2nip >bignum t ] }
-            { [ pick float class<= ] [ 2nip >float t ] }
+            { [ pick integer class<= ] [ 2nip >fixnum t ] }
+            { [ pick float class<= ] [
+                2nip dup zero? [ drop f f ] [ >float t ] if
+            ] }
             [ 3drop f f ]
         } cond
     ] if ;
@@ -53,13 +48,13 @@ literal? ;
 : <value-info> ( class interval literal literal? -- info )
     [
         2nip
-        [ class ]
+        [ class ] [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ] [ ] tri
-        [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ]
+        t
-        [ ]
-        tri t
     ] [
         drop
-        over null class<= [ drop empty-interval f f ] [
+        2dup [ null class<= ] [ empty-interval eq? ] bi* or [
+            2drop null empty-interval f f
+        ] [
             over integer class<= [ integral-closure ] when
             2dup interval>literal
         ] if
@@ -70,13 +65,14 @@ literal? ;
     f f <value-info> ; foldable
 
 : <class-info> ( class -- info )
-    [-inf,inf] <class/interval-info> ; foldable
+    dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
+    <class/interval-info> ; foldable
 
 : <interval-info> ( interval -- info )
     real swap <class/interval-info> ; foldable
 
 : <literal-info> ( literal -- info )
-    f [-inf,inf] rot t <value-info> ; foldable
+    f f rot t <value-info> ; foldable
 
 : >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ;
 
@@ -122,3 +118,15 @@ SYMBOL: value-infos
 
 : value-literal ( value -- obj ? )
     value-info >literal< ;
+
+: possible-boolean-values ( info -- values )
+    dup literal?>> [
+        literal>> 1array
+    ] [
+        class>> {
+            { [ dup null class<= ] [ { } ] }
+            { [ dup \ f class-not class<= ] [ { t } ] }
+            { [ dup \ f class<= ] [ { f } ] }
+            [ { t f } ]
+        } cond nip
+    ] if ;

unfinished/compiler/tree/propagation/known-words/known-words.factor

@@ -1,23 +1,15 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel effects accessors math math.private math.libm
-math.partial-dispatch math.intervals math.parser layouts words
+math.partial-dispatch math.intervals math.parser math.order
-sequences sequences.private arrays assocs classes
+layouts words sequences sequences.private arrays assocs classes
 classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private
 compiler.tree.propagation.info compiler.tree.propagation.nodes
-compiler.tree.propagation.constraints ;
+compiler.tree.propagation.constraints
+compiler.tree.comparisons ;
 IN: compiler.tree.propagation.known-words
 
-\ and [
-    [ [ <true-constraint> ] bi@ <conjunction> ] dip if-true
-] +constraints+ set-word-prop
-
-\ not [
-    [ [ <false-constraint> ] [ <true-constraint> ] bi ] dip
-    <conditional>
-] +constraints+ set-word-prop
-
 \ fixnum
 most-negative-fixnum most-positive-fixnum [a,b]
 +interval+ set-word-prop
@@ -88,7 +80,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
     ] if ;
 
 : binary-op-interval ( info1 info2 quot -- newinterval )
-    [ [ interval>> ] bi@ 2dup and ] dip [ 2drop f ] if ; inline
+    [ [ interval>> ] bi@ ] dip call ; inline
 
 : won't-overflow? ( class interval -- ? )
     [ fixnum class<= ] [ fixnum fits? ] bi* and ;
@@ -148,36 +140,12 @@ most-negative-fixnum most-positive-fixnum [a,b]
 \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
 \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
 
-: assume-interval ( i1 i2 op -- i3 )
-    {
-        { \ < [ assume< ] }
-        { \ > [ assume> ] }
-        { \ <= [ assume<= ] }
-        { \ >= [ assume>= ] }
-    } case ;
-
-: swap-comparison ( op -- op' )
-    {
-        { < > }
-        { > < }
-        { <= >= }
-        { >= <= }
-    } at ;
-
-: negate-comparison ( op -- op' )
-    {
-        { < >= }
-        { > <= }
-        { <= > }
-        { >= < }
-    } at ;
-
 :: (comparison-constraints) ( in1 in2 op -- constraint )
     [let | i1 [ in1 value-info interval>> ]
            i2 [ in2 value-info interval>> ] |
-       in1 i1 i2 op assume-interval <interval-constraint>
+       in1 i1 i2 op assumption is-in-interval
-       in2 i2 i1 op swap-comparison assume-interval <interval-constraint>
+       in2 i2 i1 op swap-comparison assumption is-in-interval
-       <conjunction>
+       /\
     ] ;
 
 : comparison-constraints ( in1 in2 out op -- constraint )
@@ -187,10 +155,35 @@ most-negative-fixnum most-positive-fixnum [a,b]
         3bi
     ] dip <conditional> ;
 
-: comparison-op ( word op -- )
+: define-comparison-constraints ( word op -- )
     '[ , comparison-constraints ] +constraints+ set-word-prop ;
 
-{ < > <= >= } [ dup [ comparison-op ] curry each-derived-op ] each
+comparison-ops
+[ dup '[ , define-comparison-constraints ] each-derived-op ] each
+
+generic-comparison-ops [
+    dup specific-comparison
+    '[ , , define-comparison-constraints ] each-derived-op
+] each
+
+! Remove redundant comparisons
+: fold-comparison ( info1 info2 word -- info )
+    [ [ interval>> ] bi@ ] dip interval-comparison {
+        { incomparable [ object <class-info> ] }
+        { t [ t <literal-info> ] }
+        { f [ f <literal-info> ] }
+    } case ;
+
+comparison-ops [
+    [
+        dup '[ , fold-comparison ] +outputs+ set-word-prop
+    ] each-derived-op
+] each
+
+generic-comparison-ops [
+    dup specific-comparison
+    '[ , fold-comparison ] +outputs+ set-word-prop
+] each
 
 {
     { >fixnum fixnum }

unfinished/compiler/tree/propagation/nodes/nodes.factor

@@ -16,9 +16,6 @@ GENERIC: propagate-around ( node -- )
 
 : (propagate) ( node -- )
     [
-        [ node-defs-values [ introduce-value ] each ]
+        [ propagate-around ] [ successor>> ] bi
-        [ propagate-around ]
-        [ successor>> ]
-        tri
         (propagate)
     ] when* ;

unfinished/compiler/tree/propagation/propagation-tests.factor

@@ -1,5 +1,6 @@
-USING: kernel compiler.frontend compiler.tree
+USING: kernel compiler.tree.builder compiler.tree
-compiler.tree.propagation tools.test math math.order
+compiler.tree.propagation compiler.tree.copy-equiv
+compiler.tree.def-use tools.test math math.order
 accessors sequences arrays kernel.private vectors
 alien.accessors alien.c-types ;
 IN: compiler.tree.propagation.tests
@@ -8,7 +9,11 @@ IN: compiler.tree.propagation.tests
 \ propagate/node must-infer
 
 : final-info ( quot -- seq )
-    dataflow propagate last-node node-input-infos ;
+    build-tree
+    compute-def-use
+    compute-copy-equiv
+    propagate
+    last-node node-input-infos ;
 
 : final-classes ( quot -- seq )
     final-info [ class>> ] map ;
@@ -116,7 +121,7 @@ IN: compiler.tree.propagation.tests
 
 [ V{ 9 } ] [
     [
-        >fixnum
+        123 bitand
         dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if
     ] final-literals
 ] unit-test
@@ -143,3 +148,52 @@ IN: compiler.tree.propagation.tests
         255 min 0 max
     ] final-classes
 ] unit-test
+
+[ V{ fixnum } ] [
+    [ 0 dup 10 > [ 2 * ] when ] final-classes
+] unit-test
+
+[ V{ f } ] [
+    [ [ 0.0 ] [ -0.0 ] if ] final-literals
+] unit-test
+
+[ V{ 1.5 } ] [
+    [ /f 1.5 min 1.5 max ] final-literals
+] unit-test
+
+[ V{ 1.5 } ] [
+    [
+        /f
+        dup 1.5 <= [ dup 1.5 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+    ] final-literals
+] unit-test
+
+[ V{ 1.5 } ] [
+    [
+        /f
+        dup 1.5 <= [ dup 10 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+    ] final-literals
+] unit-test
+
+[ V{ f } ] [
+    [
+        /f
+        dup 0.0 < [ dup 0.0 > [ drop 0.0 ] unless ] [ drop 0.0 ] if
+    ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 0 dup 10 > [ 100 * ] when ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 0 dup 10 > [ drop "foo" ] when ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare 3 3 - + ] final-classes
+] unit-test
+
+[ V{ t } ] [
+    [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
+] unit-test

unfinished/compiler/tree/propagation/propagation.factor

@@ -1,7 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences namespaces hashtables
-disjoint-sets
 compiler.tree
 compiler.tree.def-use
 compiler.tree.propagation.info
@@ -17,7 +16,6 @@ IN: compiler.tree.propagation
     [
         H{ } clone constraints set
         >hashtable value-infos set
-        <disjoint-set> copies set
         (propagate)
     ] with-scope ;
 

unfinished/compiler/tree/propagation/recursive/recursive.factor

@@ -8,6 +8,12 @@ compiler.tree.propagation.simple
 compiler.tree.propagation.branches ;
 IN: compiler.tree.propagation.recursive
 
+! What if we reach a fixed point for the phi but not for the
+! #call-label output?
+
+! We need to compute scalar evolution so that sccp doesn't
+! evaluate loops
+
 : (merge-value-infos) ( inputs -- infos )
     [ [ value-info ] map value-infos-union ] map ;
 
@@ -22,11 +28,9 @@ IN: compiler.tree.propagation.recursive
 
 M: #recursive propagate-around ( #recursive -- )
     dup
-    [ children>> (propagate) ]
+    node-child
-    [ node-child propagate-recursive-phi ] bi
+    [ first>> (propagate) ] [ propagate-recursive-phi ] bi
     [ drop ] [ propagate-around ] if ;
 
 M: #call-recursive propagate-before ( #call-label -- )
-    #! What if we reach a fixed point for the phi but not for the
-    #! #call-label output?
     [ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;

unfinished/compiler/tree/propagation/simple/simple.factor

@@ -3,6 +3,7 @@
 USING: fry accessors kernel sequences assocs words namespaces
 classes.algebra combinators classes continuations
 compiler.tree
+compiler.tree.def-use
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.constraints ;
@@ -25,29 +26,12 @@ M: #push propagate-before
     [ set-value-info ] 2each ;
 
 M: #declare propagate-before
-    [ [ in-d>> ] [ out-d>> ] bi are-copies-of ]
+    declaration>> [ <class-info> swap refine-value-info ] assoc-each ;
-    [
-        [ declaration>> class-infos ] [ out-d>> ] bi
-        refine-value-infos
-    ] bi ;
-
-M: #shuffle propagate-before
-    [ out-d>> dup ] [ mapping>> ] bi
-    '[ , at ] map swap are-copies-of ;
-
-M: #>r propagate-before
-    [ in-d>> ] [ out-r>> ] bi are-copies-of ;
-
-M: #r> propagate-before
-    [ in-r>> ] [ out-d>> ] bi are-copies-of ;
-
-M: #copy propagate-before
-    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
 
 : predicate-constraints ( value class boolean-value -- constraint )
-    [ [ <class-constraint> ] dip if-true ]
+    [ [ is-instance-of ] dip t--> ]
-    [ [ class-not <class-constraint> ] dip if-false ]
+    [ [ class-not is-instance-of ] dip f--> ]
-    3bi <conjunction> ;
+    3bi /\ ;
 
 : custom-constraints ( #call quot -- )
     [ [ in-d>> ] [ out-d>> ] bi append ] dip
@@ -63,6 +47,24 @@ M: #copy propagate-before
         ] [ drop ] if
     ] if* ;
 
+: call-outputs-quot ( node -- infos )
+    [ in-d>> [ value-info ] map ]
+    [ word>> +outputs+ word-prop ]
+    bi with-datastack ;
+
+: foldable-call? ( #call -- ? )
+    dup word>> "foldable" word-prop [
+        in-d>> [ value-info literal?>> ] all?
+    ] [
+        drop f
+    ] if ;
+
+: fold-call ( #call -- infos )
+    [ in-d>> [ value-info literal>> ] map ]
+    [ word>> [ execute ] curry ]
+    bi with-datastack
+    [ <literal-info> ] map ;
+
 : default-output-value-infos ( node -- infos )
     dup word>> "default-output-classes" word-prop [
         class-infos
@@ -70,12 +72,12 @@ M: #copy propagate-before
         out-d>> length object <class-info> <repetition>
     ] ?if ;
 
-: call-outputs-quot ( node quot -- infos )
-    [ in-d>> [ value-info ] map ] dip with-datastack ;
-
 : output-value-infos ( node -- infos )
-    dup word>> +outputs+ word-prop
+    {
-    [ call-outputs-quot ] [ default-output-value-infos ] if* ;
+        { [ dup foldable-call? ] [ fold-call ] }
+        { [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
+        [ default-output-value-infos ]
+    } cond ;
 
 M: #call propagate-before
     [ [ output-value-infos ] [ out-d>> ] bi set-value-infos ]
@@ -94,7 +96,10 @@ M: #call propagate-after
 M: node propagate-after drop ;
 
 : annotate-node ( node -- )
-    dup node-values [ dup value-info ] H{ } map>assoc >>info drop ;
+    dup
+    [ node-defs-values ] [ node-uses-values ] bi append
+    [ dup value-info ] H{ } map>assoc
+    >>info drop ;
 
 M: node propagate-around
     [ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;

unfinished/compiler/tree/tree.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic assocs kernel math namespaces parser
 sequences words vectors math.intervals effects classes
-accessors combinators stack-checker.state ;
+accessors combinators stack-checker.state stack-checker.visitor ;
 IN: compiler.tree
 
 ! High-level tree SSA form.
@@ -16,20 +16,12 @@ IN: compiler.tree
 ! case of a #phi node, the sequence of sequences in the phi-in-r
 ! and phi-in-d slots.
 ! 3) A value is never used in the same node where it is defined.
-
 TUPLE: node < identity-tuple
 in-d out-d in-r out-r info
-history successor children ;
+successor children ;
 
 M: node hashcode* drop node hashcode* ;
 
-: node-shuffle ( node -- shuffle )
-    [ in-d>> ] [ out-d>> ] bi <effect> ;
-
-: node-values ( node -- values )
-    { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
-    4array concat ;
-
 : node-child ( node -- child ) children>> first ;
 
 : last-node ( node -- last )
@@ -57,7 +49,7 @@ TUPLE: #introduce < node values ;
 : #introduce ( values -- node )
     \ #introduce new swap >>values ;
 
-TUPLE: #call < node word ;
+TUPLE: #call < node word history ;
 
 : #call ( inputs outputs word -- node )
     \ #call new
@@ -137,11 +129,9 @@ TUPLE: #phi < node phi-in-d phi-in-r ;
 
 TUPLE: #declare < node declaration ;
 
-: #declare ( inputs outputs declaration -- node )
+: #declare ( declaration -- node )
     \ #declare new
-        swap >>declaration
+        swap >>declaration ;
-        swap >>out-d
-        swap >>in-d ;
 
 TUPLE: #return < node label ;
 
@@ -172,3 +162,30 @@ DEFER: #tail?
 PREDICATE: #tail-phi < #phi successor>> #tail? ;
 
 UNION: #tail POSTPONE: f #return #tail-phi #terminate ;
+
+TUPLE: node-list first last ;
+
+: node, ( node -- )
+    stack-visitor get swap
+    over last>>
+    [ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
+    [ [ >>first ] [ >>last ] bi drop ]
+    if ;
+
+M: node-list child-visitor node-list new ;
+M: node-list #introduce, #introduce node, ;
+M: node-list #call, #call node, ;
+M: node-list #call-recursive, #call-recursive node, ;
+M: node-list #push, #push node, ;
+M: node-list #shuffle, #shuffle node, ;
+M: node-list #drop, #drop node, ;
+M: node-list #>r, #>r node, ;
+M: node-list #r>, #r> node, ;
+M: node-list #return, #return node, ;
+M: node-list #terminate, #terminate node, ;
+M: node-list #if, #if node, ;
+M: node-list #dispatch, #dispatch node, ;
+M: node-list #phi, #phi node, ;
+M: node-list #declare, #declare node, ;
+M: node-list #recursive, #recursive node, ;
+M: node-list #copy, #copy node, ;

unfinished/compiler/tree/untupling/untupling-tests.factor

@@ -0,0 +1,50 @@
+IN: compiler.tree.untupling.tests
+USING: assocs math kernel quotations.private slots.private
+compiler.tree.builder
+compiler.tree.def-use
+compiler.tree.copy-equiv
+compiler.tree.untupling
+tools.test ;
+
+: check-untupling ( quot -- sizes )
+    build-tree
+    compute-copy-equiv
+    compute-def-use
+    compute-untupling
+    values ;
+
+[ { } ] [ [ 1 [ + ] curry ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry drop ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry 3 slot ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry 3 slot drop ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry uncurry ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
+
+[ { } ] [ [ [ 1 [ + ] curry ] [ [ ] ] if ] check-untupling ] unit-test
+
+[ { 2 2 } ] [
+    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if uncurry ] check-untupling
+] unit-test
+
+[ { } ] [
+    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if ] check-untupling
+] unit-test
+
+[ { 2 2 2 } ] [
+    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if uncurry ] check-untupling
+] unit-test
+
+[ { 2 2 } ] [
+    [ [ 1 [ + ] curry 4 ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if uncurry ] if ] check-untupling
+] unit-test
+
+[ { } ] [
+    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if ] check-untupling
+] unit-test

unfinished/compiler/tree/untupling/untupling.factor

@@ -0,0 +1,59 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors slots.private kernel namespaces disjoint-sets
+math sequences assocs classes.tuple.private combinators fry sets
+compiler.tree compiler.tree.combinators compiler.tree.copy-equiv
+compiler.tree.dfa compiler.tree.dfa.backward ;
+IN: compiler.tree.untupling
+
+SYMBOL: escaping-values
+
+: mark-escaping-values ( node -- )
+    in-d>> escaping-values get '[ resolve-copy , conjoin ] each ;
+
+SYMBOL: untupling-candidates
+
+: untupling-candidate ( #call class -- )
+    #! 1- for delegate
+    size>> 1- swap out-d>> first resolve-copy
+    untupling-candidates get set-at ;
+
+GENERIC: compute-untupling* ( node -- )
+
+M: #call compute-untupling*
+    dup word>> {
+        { \ <tuple-boa> [ dup in-d>> peek untupling-candidate ] }
+        { \ curry [ \ curry tuple-layout untupling-candidate ] }
+        { \ compose [ \ compose tuple-layout untupling-candidate ] }
+        { \ slot [ drop ] }
+        [ drop mark-escaping-values ]
+    } case ;
+
+M: #return compute-untupling*
+    dup label>> [ drop ] [ mark-escaping-values ] if ;
+
+M: node compute-untupling* drop ;
+
+GENERIC: check-consistency* ( node -- )
+
+: check-value-consistency ( out-value in-values -- )
+    swap escaping-values get key? [
+        escaping-values get '[ , conjoin ] each
+    ] [
+        untupling-candidates get 2dup '[ , at ] map all-equal?
+        [ 2drop ] [ '[ , delete-at ] each ] if
+    ] if ;
+
+M: #phi check-consistency*
+    [ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ]
+    [ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ]
+    bi ;
+
+M: node check-consistency* drop ;
+
+: compute-untupling ( node -- assoc )
+    H{ } clone escaping-values set
+    H{ } clone untupling-candidates set
+    [ [ compute-untupling* ] each-node ]
+    [ [ check-consistency* ] each-node ] bi
+    untupling-candidates get escaping-values get assoc-diff ;

unfinished/stack-checker/backend/backend.factor

@@ -176,7 +176,7 @@ M: object apply-object push-literal ;
         [
             init-inference
             init-known-values
-            dataflow-visitor off
+            stack-visitor off
             dependencies off
             [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
             [ finish-word current-effect ]
@@ -202,10 +202,10 @@ M: object apply-object push-literal ;
             V{ } clone recorded set
             init-inference
             init-known-values
-            dataflow-visitor off
+            stack-visitor off
             call
             end-infer
             current-effect
-            dataflow-visitor get
+            stack-visitor get
         ] [ ] [ undo-infer ] cleanup
     ] with-scope ; inline

unfinished/stack-checker/branches/branches.factor

@@ -65,7 +65,7 @@ SYMBOL: quotations
 : infer-branches ( branches -- input children data )
     [ pop-d ] dip
     [ infer-branch ] map
-    [ dataflow-visitor branch-variable ] keep ;
+    [ stack-visitor branch-variable ] keep ;
 
 : (infer-if) ( branches -- )
     infer-branches [ first2 #if, ] dip compute-phi-function ;

unfinished/stack-checker/inlining/inlining.factor

@@ -81,7 +81,7 @@ SYMBOL: phi-out
 
         dup recursive-word-inputs
         meta-d get
-        dataflow-visitor get
+        stack-visitor get
     ] with-scope ;
 
 : inline-recursive-word ( word -- )

unfinished/stack-checker/known-words/known-words.factor

@@ -52,7 +52,7 @@ IN: stack-checker.known-words
 
 : infer-declare ( -- )
     pop-literal nip
-    [ length consume-d dup copy-values dup output-d ] keep
+    [ length ensure-d ] keep zip
     #declare, ;
 
 GENERIC: infer-call* ( value known -- )

unfinished/stack-checker/visitor/dummy/dummy.factor

@@ -16,7 +16,7 @@ M: f #terminate, ;
 M: f #if, 3drop ;
 M: f #dispatch, 2drop ;
 M: f #phi, 2drop 2drop ;
-M: f #declare, 3drop ;
+M: f #declare, drop ;
 M: f #recursive, drop drop drop drop drop ;
 M: f #copy, 2drop ;
 M: f #drop, drop ;

unfinished/stack-checker/visitor/visitor.factor

@@ -3,25 +3,25 @@
 USING: kernel arrays namespaces ;
 IN: stack-checker.visitor
 
-SYMBOL: dataflow-visitor
+SYMBOL: stack-visitor
 
-HOOK: child-visitor dataflow-visitor ( -- visitor )
+HOOK: child-visitor stack-visitor ( -- visitor )
 
-: nest-visitor ( -- ) child-visitor dataflow-visitor set ;
+: nest-visitor ( -- ) child-visitor stack-visitor set ;
 
-HOOK: #introduce, dataflow-visitor ( values -- )
+HOOK: #introduce, stack-visitor ( values -- )
-HOOK: #call, dataflow-visitor ( inputs outputs word -- )
+HOOK: #call, stack-visitor ( inputs outputs word -- )
-HOOK: #call-recursive, dataflow-visitor ( inputs outputs word -- )
+HOOK: #call-recursive, stack-visitor ( inputs outputs word -- )
-HOOK: #push, dataflow-visitor ( literal value -- )
+HOOK: #push, stack-visitor ( literal value -- )
-HOOK: #shuffle, dataflow-visitor ( inputs outputs mapping -- )
+HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
-HOOK: #drop, dataflow-visitor ( values -- )
+HOOK: #drop, stack-visitor ( values -- )
-HOOK: #>r, dataflow-visitor ( inputs outputs -- )
+HOOK: #>r, stack-visitor ( inputs outputs -- )
-HOOK: #r>, dataflow-visitor ( inputs outputs -- )
+HOOK: #r>, stack-visitor ( inputs outputs -- )
-HOOK: #terminate, dataflow-visitor ( -- )
+HOOK: #terminate, stack-visitor ( -- )
-HOOK: #if, dataflow-visitor ( ? true false -- )
+HOOK: #if, stack-visitor ( ? true false -- )
-HOOK: #dispatch, dataflow-visitor ( n branches -- )
+HOOK: #dispatch, stack-visitor ( n branches -- )
-HOOK: #phi, dataflow-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
+HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
-HOOK: #declare, dataflow-visitor ( inputs outputs declaration -- )
+HOOK: #declare, stack-visitor ( declaration -- )
-HOOK: #return, dataflow-visitor ( label stack -- )
+HOOK: #return, stack-visitor ( label stack -- )
-HOOK: #recursive, dataflow-visitor ( word label inputs outputs visitor -- )
+HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- )
-HOOK: #copy, dataflow-visitor ( inputs outputs -- )
+HOOK: #copy, stack-visitor ( inputs outputs -- )