compiler.cfg.dcn: flesh out rewrite pass

basis/compiler/cfg/dcn/dcn-tests.factor

@@ -108,13 +108,13 @@ V{
 
 [ f ] [ D 0 0 get avail-out key? ] unit-test
 
-[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test
+[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test
 
-[ { } ] [ 1 get 2 get inserting-peeks ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
 
-[ { } ] [ 0 get 1 get inserting-replaces ] unit-test
+[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test
 
-[ { D 1 } ] [ 1 get 2 get inserting-replaces ] unit-test
+[ { D 2 } ] [ 1 get 2 get inserting-replaces keys ] unit-test
 
 V{
     T{ ##prologue }
@@ -136,8 +136,8 @@ V{
 [ ] [ test-global-dcn ] unit-test
 
 [ t ] [ D 1 2 get peek-in key? ] unit-test
-[ { D 1 } ] [ 0 get 1 get inserting-peeks ] unit-test
+[ { D 1 } ] [ 0 get 1 get inserting-peeks keys ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
 
 V{
     T{ ##prologue }
@@ -179,16 +179,21 @@ V{
 
 [ ] [ test-global-dcn ] unit-test
 
-[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test
+[ f ] [ D 0 1 get avail-out key? ] unit-test
-[ { } ] [ 0 get 1 get inserting-replaces ] unit-test
+[ f ] [ D 1 1 get avail-out key? ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks ] unit-test
+[ t ] [ D 0 4 get peek-in key? ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces ] unit-test
+[ t ] [ D 1 4 get peek-in key? ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks ] unit-test
+
-[ { } ] [ 1 get 3 get inserting-replaces ] unit-test
+[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test
-[ { D 1 } ] [ 2 get 4 get inserting-peeks ] unit-test
+[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test
-[ { } ] [ 2 get 4 get inserting-replaces ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks ] unit-test
+[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test
-[ { D 0 } ] [ 4 get 5 get inserting-replaces ] unit-test
+[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test
+[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test
+[ { D 1 } ] [ 1 get 4 get inserting-peeks keys ] unit-test
+[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test
+[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test
+[ { D 1 } ] [ 4 get 5 get inserting-replaces keys ] unit-test
 
 [ t ] [ D 0 1 get peek-out key? ] unit-test
 [ f ] [ D 1 1 get peek-out key? ] unit-test
@@ -243,16 +248,16 @@ V{
 [ t ] [ D 1 2 get peek-in key? ] unit-test
 [ f ] [ D 1 3 get peek-in key? ] unit-test
 
-[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test
+[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test
-[ { } ] [ 0 get 1 get inserting-replaces ] unit-test
+[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test
-[ { D 1 } ] [ 1 get 2 get inserting-peeks ] unit-test
+[ { D 1 } ] [ 1 get 2 get inserting-peeks keys ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces ] unit-test
+[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test
-[ { D 2 } ] [ 1 get 3 get inserting-peeks ] unit-test
+[ { D 2 } ] [ 1 get 3 get inserting-peeks keys ] unit-test
-[ { } ] [ 1 get 3 get inserting-replaces ] unit-test
+[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks ] unit-test
+[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test
-[ { } ] [ 2 get 4 get inserting-replaces ] unit-test
+[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test
-[ { } ] [ 3 get 4 get inserting-replaces ] unit-test
+[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test
-[ { D 1 } ] [ 4 get 5 get inserting-replaces ] unit-test
+[ { D 0 } ] [ 4 get 5 get inserting-replaces keys ] unit-test
 
 V{
     T{ ##prologue }
@@ -294,11 +299,11 @@ V{
 [ f ] [ D 1 3 get avail-out key? ] unit-test
 [ f ] [ D 1 4 get avail-in key? ] unit-test
 
-[ { D 1 } ] [ 0 get 1 get inserting-peeks ] unit-test
+[ { D 1 } ] [ 0 get 1 get inserting-peeks keys ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks ] unit-test
+[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test
-[ { } ] [ 2 get 4 get inserting-peeks ] unit-test
+[ { } ] [ 2 get 4 get inserting-peeks keys ] unit-test
-[ { D 1 } ] [ 3 get 4 get inserting-peeks ] unit-test
+[ { D 0 } ] [ 3 get 4 get inserting-peeks keys ] unit-test
 
 V{
     T{ ##prologue }
@@ -322,10 +327,10 @@ V{ T{ ##branch } } 3 test-bb
 
 [ t ] [ D 0 1 get avail-out key? ] unit-test
 
-[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test
+[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks ] unit-test
+[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test
-[ { } ] [ 3 get 1 get inserting-peeks ] unit-test
+[ { } ] [ 3 get 1 get inserting-peeks keys ] unit-test
 
 V{
     T{ ##prologue }
@@ -369,13 +374,13 @@ V{
 
 [ ] [ test-global-dcn ] unit-test
 
-[ { } ] [ 0 get 1 get inserting-peeks ] unit-test
+[ { } ] [ 0 get 1 get inserting-peeks keys ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks ] unit-test
+[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test
-[ { D 0 } ] [ 2 get 4 get inserting-peeks ] unit-test
+[ { D 0 } ] [ 2 get 4 get inserting-peeks keys ] unit-test
-[ { D 0 } ] [ 1 get 3 get inserting-peeks ] unit-test
+[ { D 0 } ] [ 1 get 3 get inserting-peeks keys ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks ] unit-test
+[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test
-[ { } ] [ 5 get 6 get inserting-peeks ] unit-test
+[ { } ] [ 5 get 6 get inserting-peeks keys ] unit-test
 
 V{
     T{ ##prologue }
@@ -414,13 +419,87 @@ V{
 
 [ ] [ test-global-dcn ] unit-test
 
-[ { } ] [ 1 get 2 get inserting-peeks ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces ] unit-test
+[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test
-[ { D 0 } ] [ 1 get 3 get inserting-peeks ] unit-test
+[ { D 0 } ] [ 1 get 3 get inserting-peeks keys ] unit-test
-[ { } ] [ 1 get 3 get inserting-replaces ] unit-test
+[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test
-[ { } ] [ 2 get 4 get inserting-peeks ] unit-test
+[ { } ] [ 2 get 4 get inserting-peeks keys ] unit-test
-[ { D 0 } ] [ 2 get 4 get inserting-replaces ] unit-test
+[ { D 0 } ] [ 2 get 4 get inserting-replaces keys ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks ] unit-test
+[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test
-[ { } ] [ 3 get 4 get inserting-replaces ] unit-test
+[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks ] unit-test
+[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test
-[ { } ] [ 4 get 5 get inserting-replaces ] unit-test
+[ { } ] [ 4 get 5 get inserting-replaces keys ] unit-test
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##replace f V int-regs 1 D 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##replace f V int-regs 2 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##branch }
+} 4 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 5 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+
+[ ] [ test-global-dcn ] unit-test
+
+[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test
+
+[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test
+
+[ { D 0 } ] [ 4 get 5 get inserting-replaces keys ] unit-test
+
+! Dead replace elimination
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##replace f V int-regs 1 D 0 }
+    T{ ##replace f V int-regs 0 D 1 }
+} 1 test-bb
+
+V{
+    T{ ##inc-d f -2 }
+} 2 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 3 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 1vector >>successors drop
+2 get 3 get 1vector >>successors drop
+
+[ ] [ test-global-dcn ] unit-test
+
+[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test
+[ { } ] [ 2 get 3 get inserting-replaces keys ] unit-test

basis/compiler/cfg/dcn/dcn.factor

@@ -1,6 +1,11 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: ;
+USING: combinators
+compiler.cfg
+compiler.cfg.dcn.height
+compiler.cfg.dcn.local
+compiler.cfg.dcn.global
+compiler.cfg.dcn.rewrite ;
 IN: compiler.cfg.dcn
 
 ! "DeConcatenatizatioN" -- dataflow analysis to recover registers
@@ -27,4 +32,13 @@ IN: compiler.cfg.dcn
 ! On every edge [pred --> b], insert a peek for each location in
 ! P_in(b) - (P_out(pred) \/ A_out(pred))
 
-! Locations are height-normalized.
+! Locations are height-normalized.
+
+: deconcatenatize ( cfg -- cfg' )
+    {
+        [ compute-heights ]
+        [ compute-local-sets ]
+        [ compute-global-sets ]
+        [ rewrite ]
+        [ cfg-changed ]
+    } cleave ;

basis/compiler/cfg/dcn/height/height.factor

@@ -53,6 +53,16 @@ M: ##inc-r rs-height-change n>> ;
 : compute-rs-height ( bb -- )
     in-rs-heights out-rs-heights [ rs-height-change ] compute-height ;
 
+GENERIC# translate-loc 1 ( loc bb -- loc' )
+
+M: ds-loc translate-loc [ n>> ] [ in-ds-heights get at ] bi* - <ds-loc> ;
+M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - <ds-loc> ;
+
+GENERIC# untranslate-loc 1 ( loc bb -- loc' )
+
+M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + <ds-loc> ;
+M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + <ds-loc> ;
+
 PRIVATE>
 
 : compute-heights ( cfg -- )
@@ -65,18 +75,8 @@ PRIVATE>
         [ compute-ds-height ] bi
     ] each-basic-block ;
 
-GENERIC# translate-in-loc 1 ( loc bb -- loc' )
+: translate-locs ( assoc bb -- assoc' )
+    '[ [ _ translate-loc ] dip ] assoc-map ;
 
-M: ds-loc translate-in-loc [ n>> ] [ in-ds-heights get at ] bi* - <ds-loc> ;
+: untranslate-locs ( assoc bb -- assoc' )
-M: rs-loc translate-in-loc [ n>> ] [ in-rs-heights get at ] bi* - <ds-loc> ;
+    '[ [ _ untranslate-loc ] dip ] assoc-map ;
-
-GENERIC# translate-out-loc 1 ( loc bb -- loc' )
-
-M: ds-loc translate-out-loc [ n>> ] [ out-ds-heights get at ] bi* + <ds-loc> ;
-M: rs-loc translate-out-loc [ n>> ] [ out-rs-heights get at ] bi* + <ds-loc> ;
-
-: translate-in-set ( assoc bb -- assoc' )
-    '[ [ _ translate-in-loc ] dip ] assoc-map ;
-
-: translate-out-set ( assoc bb -- assoc' )
-    '[ [ _ translate-out-loc ] dip ] assoc-map ;

basis/compiler/cfg/dcn/local/local.factor

@@ -82,8 +82,8 @@ SYMBOLS: peeks replaces ;
 
 : visit-block ( bb -- )
     [ local-analysis ]
-    [ [ reads-locations get ] dip [ translate-in-set ] keep peeks get set-at ]
+    [ [ reads-locations get ] dip [ translate-locs ] keep peeks get set-at ]
-    [ [ writes-locations get ] dip [ translate-in-set ] keep replaces get set-at ]
+    [ [ writes-locations get ] dip [ translate-locs ] keep replaces get set-at ]
     tri ;
 
 PRIVATE>

basis/compiler/cfg/dcn/rewrite/rewrite.factor

@@ -1,10 +1,67 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs kernel compiler.cfg.dcn.global ;
+USING: namespaces assocs kernel fry accessors sequences make math
+combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.dcn.local
+compiler.cfg.dcn.global compiler.cfg.dcn.height ;
 IN: compiler.cfg.dcn.rewrite
 
-: inserting-peeks ( from to -- seq )
+! This pass inserts peeks, replaces, and copies. All stack locations
-    peek-in swap [ peek-out ] [ avail-out ] bi assoc-union assoc-diff keys ;
+! are loaded to canonical vregs, with a 1-1 mapping from location to
+! vreg. SSA is reconstructed afterwards.
 
-: inserting-replaces ( from to -- seq )
+: inserting-peeks ( from to -- assoc )
-    [ replace-out ] [ kill-in ] bi* assoc-diff keys ;
+    [
+        peek-in swap [ peek-out ] [ avail-out ] bi
+        assoc-union assoc-diff
+    ] keep untranslate-locs ;
+
+: inserting-replaces ( from to -- assoc )
+    [
+        [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
+        assoc-union assoc-diff
+    ] keep
+    untranslate-locs
+    [ drop n>> 0 >= ] assoc-filter ;
+
+SYMBOL: locs>vregs
+
+: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
+
+: each-insertion ( assoc quot: ( vreg loc -- ) -- )
+    '[ drop [ loc>vreg ] keep @ ] assoc-each ; inline
+
+: visit-edge ( from to -- )
+    2dup [
+        [ inserting-peeks [ ##peek ] each-insertion ]
+        [ inserting-replaces [ ##replace ] each-insertion ] 2bi
+    ] V{ } make
+    [ 2drop ] [ <simple-block> insert-basic-block ] if-empty ;
+
+: visit-edges ( bb -- )
+    [ predecessors>> ] keep '[ _ visit-edge ] each ;
+
+: insert-in-copies ( bb -- )
+    peek [ swap loc>vreg ##copy ] assoc-each ;
+
+: insert-out-copies ( bb -- )
+    replace [ swap loc>vreg swap ##copy ] assoc-each ;
+
+: rewrite-instructions ( bb -- )
+    [
+        [
+            {
+                [ insert-in-copies ]
+                [ instructions>> but-last-slice % ]
+                [ insert-out-copies ]
+                [ instructions>> last , ]
+            } cleave
+        ] V{ } make
+    ] keep (>>instructions) ;
+
+: visit-block ( bb -- )
+    [ visit-edges ] [ rewrite-instructions ] bi ;
+
+: rewrite ( cfg -- )
+    H{ } clone locs>vregs set
+    [ visit-block ] each-basic-block ;