DCE work in progress

basis/compiler/compiler.factor

@@ -46,6 +46,7 @@ SYMBOL: +failed+
     ] tri ;
 
 : (compile) ( word -- )
+    USE: prettyprint dup .
     [
         H{ } clone dependencies set
 

basis/compiler/generator/generator.factor

@@ -152,6 +152,7 @@ M: #if generate-node
             %save-dispatch-xt
             %prologue-later
             [ generate-nodes ] with-node-iterator
+            %return
         ] with-generator
     ] keep ;
 

basis/compiler/generator/iterator/iterator.factor

@@ -28,14 +28,18 @@ DEFER: (tail-call?)
     [ value #phi? ] [ next (tail-call?) ] bi and ;
 
 : (tail-call?) ( cursor -- ? )
-    [ value [ #return? ] [ #terminate? ] bi or ]
+    dup [
-    [ tail-phi? ]
+        [ value [ #return? ] [ #terminate? ] bi or ]
-    bi or ;
+        [ tail-phi? ]
+        bi or
+    ] [ drop t ] if ;
 
 : tail-call? ( -- ? )
     node-stack get [
         next
-        [ (tail-call?) ]
+        dup [
-        [ value #terminate? not ]
+            [ (tail-call?) ]
-        bi and
+            [ value #terminate? not ]
+            bi and
+        ] [ drop t ] if
     ] all? ;

basis/compiler/tree/checker/checker.factor

@@ -45,7 +45,7 @@ M: #phi check-node
 
 M: #enter-recursive check-node
     [ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
-    [ [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix check-lengths ]
+    [ recursive-phi-in check-lengths ]
     bi ;
 
 M: #push check-node

basis/compiler/tree/cleanup/cleanup.factor

@@ -72,6 +72,8 @@ M: #call cleanup*
         [ ]
     } cond ;
 
+M: #declare cleanup* drop f ;
+
 GENERIC: delete-node ( node -- )
 
 M: #call-recursive delete-node

basis/compiler/tree/dataflow-analysis/backward/backward.factor

@@ -9,37 +9,40 @@ 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 ;
+    [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
 
-M: #call backward
+M: #call backward nip look-at-inputs ;
-    #! 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>>
+    [ out-d>> ] [ label>> return>> ] bi look-at-mapping ;
-    [ <reversed> nth look-at-value ] with each ;
 
-M: #>r backward nip in-d>> first look-at-value ;
+M: #>r backward [ out-r>> ] [ in-d>> ] bi look-at-mapping ;
 
-M: #r> backward nip in-r>> first look-at-value ;
+M: #r> backward [ out-d>> ] [ in-r>> ] bi look-at-mapping ;
 
 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-d>> ] [ phi-in-d>> ] bi look-at-phi ]
-    [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
+    [ [ out-r>> ] [ phi-in-r>> ] bi look-at-phi ]
     2bi ;
 
-M: #alien-invoke backward
+M: #enter-recursive backward
-    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+    [ out-d>> ] [ recursive-phi-in flip ] bi look-at-phi ;
 
-M: #alien-indirect backward
+: return-recursive-phi-in ( #return-recursive -- phi-in )
-    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
+
+M: #return-recursive backward
+    [ out-d>> ] [ return-recursive-phi-in flip ] bi look-at-phi ;
+
+M: #alien-invoke backward nip look-at-inputs ;
+
+M: #alien-indirect backward nip look-at-inputs ;
 
 M: node backward 2drop ;
 

basis/compiler/tree/dataflow-analysis/dataflow-analysis.factor

@@ -15,9 +15,10 @@ SYMBOL: work-list
 
 : look-at-inputs ( node -- ) in-d>> look-at-values ;
 
-: look-at-outputs ( node -- ) out-d>> look-at-values ;
+: look-at-mapping ( value inputs outputs -- )
+    [ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
 
-: look-at-corresponding ( value inputs outputs -- )
+: look-at-phi ( value inputs outputs -- )
     [ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
 
 : init-dfa ( -- )

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

@@ -1,13 +1,15 @@
 USING: namespaces assocs sequences compiler.tree.builder
 compiler.tree.dead-code compiler.tree.def-use compiler.tree
-compiler.tree.combinators tools.test kernel math
+compiler.tree.combinators compiler.tree.debugger
-stack-checker.state accessors combinators ;
+compiler.tree.normalization tools.test
+kernel math stack-checker.state accessors combinators io ;
 IN: compiler.tree.dead-code.tests
 
 \ remove-dead-code must-infer
 
 : count-live-values ( quot -- n )
     build-tree
+    normalize
     compute-def-use
     remove-dead-code
     0 swap [
@@ -51,3 +53,13 @@ IN: compiler.tree.dead-code.tests
 [ 2 ] [ [ [ 1 ] [ 2 ] compose call ] count-live-values ] unit-test
 
 [ 0 ] [ [ [ 1 ] [ 2 ] compose call + drop ] count-live-values ] unit-test
+
+: optimize-quot ( quot -- quot' )
+    build-tree normalize compute-def-use remove-dead-code
+    nodes>quot ;
+
+[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test
+
+[ [ read 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test
+
+[ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test

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

@@ -1,7 +1,8 @@
 ! 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
+kernel sequences words sets arrays
+stack-checker.state stack-checker.inlining
 compiler.tree
 compiler.tree.combinators
 compiler.tree.dataflow-analysis
@@ -12,25 +13,19 @@ IN: compiler.tree.dead-code
 ! outputs are unused using backward DFA.
 GENERIC: mark-live-values ( node -- )
 
-M: #introduce mark-live-values
-    value>> look-at-value ;
-
 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 ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
+    [ drop ] [ look-at-inputs ] if ;
 
-M: #alien-invoke mark-live-values
+M: #alien-invoke mark-live-values look-at-inputs ;
-    [ look-at-inputs ] [ look-at-outputs ] bi ;
 
-M: #alien-indirect mark-live-values
+M: #alien-indirect mark-live-values look-at-inputs ;
-    [ look-at-inputs ] [ look-at-outputs ] bi ;
 
-M: #return mark-live-values
+M: #return mark-live-values look-at-inputs ;
-    look-at-inputs ;
 
 M: node mark-live-values drop ;
 
@@ -38,70 +33,80 @@ SYMBOL: live-values
 
 : live-value? ( value -- ? ) live-values get at ;
 
-: compute-live-values ( node -- )
+GENERIC: remove-dead-code* ( node -- node' )
-    [ mark-live-values ] backward-dfa live-values set ;
 
-GENERIC: remove-dead-values* ( node -- )
+M: #introduce remove-dead-code*
-
+    dup value>> live-value? [
-M: #>r remove-dead-values*
+        dup value>> 1array #drop 2array
-    dup out-r>> first live-value? [ { } >>out-r ] unless
+    ] unless ;
-    dup in-d>> first live-value? [ { } >>in-d ] unless
-    drop ;
-
-M: #r> remove-dead-values*
-    dup out-d>> first live-value? [ { } >>out-d ] unless
-    dup in-r>> first live-value? [ { } >>in-r ] unless
-    drop ;
-
-M: #push remove-dead-values*
-    dup out-d>> first live-value? [ { } >>out-d ] unless
-    drop ;
-
-: filter-corresponding-values ( in out -- in' out' )
-    zip live-values get '[ drop _ , key? ] assoc-filter unzip ;
 
 : filter-live ( values -- values' )
     [ live-value? ] filter ;
 
-M: #call remove-dead-values*
+M: #>r remove-dead-code*
+    [ filter-live ] change-out-r
+    [ filter-live ] change-in-d
+    dup in-d>> empty? [ drop f ] when ;
+
+M: #r> remove-dead-code*
+    [ filter-live ] change-out-d
+    [ filter-live ] change-in-r
+    dup in-r>> empty? [ drop f ] when ;
+
+M: #push remove-dead-code*
+    dup out-d>> first live-value? [ drop f ] unless ;
+
+: dead-flushable-call? ( #call -- ? )
+    [ word>> "flushable" word-prop ]
+    [ out-d>> [ live-value? not ] all? ] bi and ;
+
+: remove-flushable-call ( #call -- node )
+    in-d>> #drop remove-dead-code* ;
+
+: some-outputs-dead? ( #call -- ? )
+    out-d>> [ live-value? not ] contains? ;
+
+: remove-dead-outputs ( #call -- nodes )
+    [ out-d>> ] [ [ [ <value> ] replicate ] change-out-d ] bi
+    [ nip ] [ out-d>> swap #copy remove-dead-code* ] 2bi
+    2array ;
+
+M: #call remove-dead-code*
+    dup dead-flushable-call? [
+        remove-flushable-call
+    ] [
+        dup some-outputs-dead? [
+            remove-dead-outputs
+        ] when
+    ] if ;
+
+M: #recursive remove-dead-code*
+    [ filter-live ] change-in-d ;
+
+M: #call-recursive remove-dead-code*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d ;
+
+M: #enter-recursive remove-dead-code*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d ;
+
+M: #return-recursive remove-dead-code*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d ;
+
+M: #shuffle remove-dead-code*
     [ filter-live ] change-in-d
     [ filter-live ] change-out-d
-    drop ;
+    dup in-d>> empty? [ drop f ] when ;
 
-M: #recursive remove-dead-values*
+M: #copy remove-dead-code*
-    [ filter-live ] change-in-d
-    drop ;
-
-M: #call-recursive remove-dead-values*
-    [ filter-live ] change-in-d
-    [ filter-live ] change-out-d
-    drop ;
-
-M: #enter-recursive remove-dead-values*
-    [ filter-live ] change-in-d
-    [ filter-live ] change-out-d
-    drop ;
-
-M: #return-recursive remove-dead-values*
-    [ filter-live ] change-in-d
-    [ filter-live ] change-out-d
-    drop ;
-
-M: #shuffle remove-dead-values*
-    [ filter-live ] change-in-d
-    [ filter-live ] change-out-d
-    drop ;
-
-M: #declare remove-dead-values*
-    [ [ drop live-value? ] assoc-filter ] change-declaration
-    drop ;
-
-M: #copy remove-dead-values*
-    dup
     [ in-d>> ] [ out-d>> ] bi
-    filter-corresponding-values
+    2dup swap zip #shuffle
-    [ >>in-d ] [ >>out-d ] bi*
+    remove-dead-code* ;
-    drop ;
+
+: filter-corresponding-values ( in out -- in' out' )
+    zip live-values get '[ drop _ , key? ] assoc-filter unzip ;
 
 : remove-dead-phi-d ( #phi -- #phi )
     dup
@@ -115,44 +120,13 @@ M: #copy remove-dead-values*
     filter-corresponding-values
     [ >>phi-in-r ] [ >>out-r ] bi* ;
 
-M: #phi remove-dead-values*
+M: #phi remove-dead-code*
     remove-dead-phi-d
-    remove-dead-phi-r
+    remove-dead-phi-r ;
-    drop ;
 
-M: node remove-dead-values* drop ;
+M: node remove-dead-code* ;
-
-: remove-dead-values ( nodes -- )
-    [ remove-dead-values* ] each-node ;
-
-GENERIC: remove-dead-nodes* ( node -- node/f )
-
-: prune-if-empty ( node seq -- node/f )
-    empty? [ drop f ] when ; inline
-
-: 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? [ in-d>> #drop ] unless ;
-
-M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
-
-M: #push remove-dead-nodes* dup out-d>> prune-if-empty ;
-
-M: #>r remove-dead-nodes* dup in-d>> prune-if-empty ;
-
-M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
-
-M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
-
-M: node remove-dead-nodes* ;
-
-: remove-dead-nodes ( nodes -- nodes' )
-    [ remove-dead-nodes* ] map-nodes ;
 
 : remove-dead-code ( node -- newnode )
-    [ compute-live-values ]
+    [ [ mark-live-values ] backward-dfa live-values set ]
-    [ remove-dead-values ]
+    [ [ remove-dead-code* ] map-nodes ]
-    [ remove-dead-nodes ]
+    bi ;
-    tri ;

basis/compiler/tree/debugger/debugger.factor

@@ -46,13 +46,13 @@ MATCH-VARS: ?a ?b ?c ;
         { _ f }
     } match-choose ;
 
-TUPLE: shuffle effect ;
+TUPLE: shuffle-node effect ;
-
-M: shuffle pprint* effect>> effect>string text ;
 
+M: shuffle-node pprint* effect>> effect>string text ;
+ 
 M: #shuffle node>quot
     shuffle-effect dup pretty-shuffle
-    [ % ] [ shuffle boa , ] ?if ;
+    [ % ] [ shuffle-node boa , ] ?if ;
 
 : pushed-literals ( node -- seq )
     dup out-d>> [ node-value-info literal>> literalize ] with map ;
@@ -78,9 +78,15 @@ M: #if node>quot
 M: #dispatch node>quot
     children>> [ nodes>quot ] map , \ dispatch , ;
 
-M: #>r node>quot in-d>> length \ >r <repetition> % ;
+M: #>r node>quot
+    [ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi
+    <repetition> % ;
 
-M: #r> node>quot out-d>> length \ r> <repetition> % ;
+DEFER: rdrop
+
+M: #r> node>quot
+    [ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
+    <repetition> % ;
 
 M: node node>quot drop ;
 

basis/compiler/tree/escape-analysis/allocations/allocations.factor

@@ -57,7 +57,7 @@ SYMBOL: +escaping+
     <value> dup introduce-value ;
 
 : merge-values ( in-values out-value -- )
-    escaping-values get '[ , , equate ] each ;
+    escaping-values get equate-all-with ;
 
 : merge-slots ( values -- value )
     <slot-value> [ merge-values ] keep ;

basis/compiler/tree/escape-analysis/recursive/recursive.factor

@@ -27,7 +27,7 @@ IN: compiler.tree.escape-analysis.recursive
     out-d>> [ allocation ] map ;
 
 : recursive-stacks ( #enter-recursive -- stacks )
-    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix
+    recursive-phi-in
     escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
     flip ;
 

basis/compiler/tree/escape-analysis/simple/simple.factor

@@ -11,8 +11,6 @@ compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.simple
 
-M: #declare escape-analysis* drop ;
-
 M: #terminate escape-analysis* drop ;
 
 M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;

basis/compiler/tree/intrinsics/intrinsics.factor

@@ -4,8 +4,7 @@ USING: kernel classes.tuple classes.tuple.private math arrays
 byte-arrays words stack-checker.known-words ;
 IN: compiler.tree.intrinsics
 
-: <immutable-tuple-boa> ( ... class -- tuple )
+: <immutable-tuple-boa> ( ... class -- tuple ) <tuple-boa> ;
-    "BUG: missing <immutable-tuple-boa> intrinsic" throw ;
 
 : (tuple) ( layout -- tuple )
     "BUG: missing (tuple) intrinsic" throw ;

basis/compiler/tree/tree.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs kernel math namespaces parser
+USING: fry arrays generic assocs kernel math namespaces parser
 sequences words vectors math.intervals effects classes
 accessors combinators stack-checker.state stack-checker.visitor ;
 IN: compiler.tree
@@ -179,9 +179,12 @@ M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
 
 : shuffle-effect ( #shuffle -- effect )
     [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
-    [ at ] curry map
+    '[ , at ] map
     <effect> ;
 
+: recursive-phi-in ( #enter-recursive -- seq )
+    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
+
 M: vector child-visitor V{ } clone ;
 M: vector #introduce, #introduce node, ;
 M: vector #call, #call node, ;