compiler.cfg.dcn: Implement height tracking

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

@@ -23,18 +23,20 @@ compiler.cfg.dcn.rewrite ;
         T{ ##copy f V int-regs 1 V int-regs 0 }
         T{ ##copy f V int-regs 3 V int-regs 2 }
         T{ ##copy f V int-regs 5 V int-regs 4 }
+        T{ ##inc-d f -1 }
     }
 ] [
     V{
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 0 }
-        T{ ##peek f V int-regs 2 D 1 }
-        T{ ##peek f V int-regs 3 D 1 }
-        T{ ##replace f V int-regs 2 D 1 }
-        T{ ##replace f V int-regs 4 D 2 }
-        T{ ##peek f V int-regs 5 D 2 }
-        T{ ##replace f V int-regs 5 D 2 }
-        T{ ##replace f V int-regs 6 D 0 }
+        T{ ##inc-d f -1 }
+        T{ ##peek f V int-regs 2 D 0 }
+        T{ ##peek f V int-regs 3 D 0 }
+        T{ ##replace f V int-regs 2 D 0 }
+        T{ ##replace f V int-regs 4 D 1 }
+        T{ ##peek f V int-regs 5 D 1 }
+        T{ ##replace f V int-regs 5 D 1 }
+        T{ ##replace f V int-regs 6 D -1 }
     } test-local-dcn
 ] unit-test
 
@@ -79,8 +81,9 @@ V{
 } 0 test-bb
 
 V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##replace f V int-regs 1 D 1 }
+    T{ ##inc-d f 1 }
+    T{ ##peek f V int-regs 0 D 1 }
+    T{ ##replace f V int-regs 1 D 2 }
 } 1 test-bb
 
 V{
@@ -117,12 +120,36 @@ V{
     T{ ##branch }
 } 0 test-bb
 
+V{
+    T{ ##peek f V int-regs 0 D 1 }
+} 1 test-bb
+
+V{
+    T{ ##inc-d f -1 }
+    T{ ##peek f V int-regs 0 D 0 }
+} 2 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 1vector >>successors drop
+
+[ ] [ 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
+[ { } ] [ 1 get 2 get inserting-peeks ] unit-test
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
 V{
     T{ ##branch }
 } 1 test-bb
 
 V{
-    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##inc-d f 1 }
+    T{ ##peek f V int-regs 0 D 1 }
     T{ ##branch }
 } 2 test-bb
 
@@ -134,7 +161,8 @@ V{
 V{
     T{ ##peek f V int-regs 1 D 0 }
     T{ ##peek f V int-regs 2 D 1 }
-    T{ ##replace f V int-regs 2 D 0 }
+    T{ ##inc-d f 1 }
+    T{ ##replace f V int-regs 2 D 1 }
     T{ ##branch }
 } 4 test-bb
 
@@ -180,17 +208,19 @@ V{
 
 V{
     T{ ##peek f V int-regs 1 D 1 }
+    T{ ##inc-d f -1 }
     T{ ##branch }
 } 2 test-bb
 
 V{
     T{ ##replace f V int-regs 2 D 1 }
-    T{ ##peek f V int-regs 4 D 2 }
+    T{ ##inc-d f -1 }
+    T{ ##peek f V int-regs 4 D 1 }
     T{ ##branch }
 } 3 test-bb
 
 V{
-    T{ ##replace f V int-regs 3 D 1 }
+    T{ ##replace f V int-regs 3 D 0 }
     T{ ##branch }
 } 4 test-bb
 
@@ -229,16 +259,17 @@ V{
 } 0 test-bb
 
 V{
-    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##peek f V int-regs 0 D 1 }
     T{ ##branch }
 } 1 test-bb
 
 V{
+    T{ ##inc-d f -1 }
     T{ ##branch }
 } 2 test-bb
 
 V{
-    T{ ##call f drop }
+    T{ ##call f drop -1 }
     T{ ##branch }
 } 3 test-bb
 
@@ -257,16 +288,16 @@ V{
 
 [ ] [ test-global-dcn ] unit-test
 
-[ t ] [ D 0 2 get avail-out key? ] unit-test
-[ f ] [ D 0 3 get peek-out key? ] unit-test
-[ f ] [ D 0 3 get avail-out key? ] unit-test
-[ f ] [ D 0 4 get avail-in key? ] unit-test
+[ t ] [ D 1 2 get avail-out key? ] unit-test
+[ f ] [ D 1 3 get peek-out key? ] unit-test
+[ f ] [ D 1 3 get avail-out key? ] unit-test
+[ f ] [ D 1 4 get avail-in key? ] unit-test
 
-[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test
+[ { D 1 } ] [ 0 get 1 get inserting-peeks ] unit-test
 [ { } ] [ 1 get 2 get inserting-peeks ] unit-test
 [ { } ] [ 1 get 3 get inserting-peeks ] unit-test
 [ { } ] [ 2 get 4 get inserting-peeks ] unit-test
-[ { D 0 } ] [ 3 get 4 get inserting-peeks ] unit-test
+[ { D 1 } ] [ 3 get 4 get inserting-peeks ] unit-test
 
 V{
     T{ ##prologue }

basis/compiler/cfg/dcn/global/global.factor

@@ -2,17 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs deques dlists fry kernel namespaces sequences
 combinators combinators.short-circuit compiler.cfg.instructions
-compiler.cfg.dcn.local compiler.cfg.rpo compiler.cfg ;
+compiler.cfg.dcn.local compiler.cfg.rpo compiler.cfg.utilities
+compiler.cfg ;
 IN: compiler.cfg.dcn.global
 
 <PRIVATE
 
-PREDICATE: kill-block < basic-block
-    instructions>> {
-        [ length 2 = ]
-        [ first kill-vreg-insn? ]
-    } 1&& ;
-
 : assoc-refine ( seq -- assoc )
     [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
 

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

@@ -19,7 +19,7 @@ M: ##inc-d ds-height-change n>> ;
 
 M: ##call ds-height-change height>> ;
 
-: alien-node-height ( node -- )
+: alien-node-height ( node -- n )
     params>> [ out-d>> length ] [ in-d>> length ] bi - ;
 
 M: ##alien-invoke ds-height-change alien-node-height ;
@@ -67,13 +67,13 @@ PRIVATE>
 
 GENERIC# translate-in-loc 1 ( loc bb -- loc' )
 
-M: ds-loc translate-in-loc n>> in-ds-heights get at + <ds-loc> ;
-M: rs-loc translate-in-loc n>> in-rs-heights get at + <ds-loc> ;
+M: ds-loc translate-in-loc [ n>> ] [ in-ds-heights get at ] bi* - <ds-loc> ;
+M: rs-loc translate-in-loc [ n>> ] [ in-rs-heights get at ] bi* - <ds-loc> ;
 
 GENERIC# translate-out-loc 1 ( loc bb -- loc' )
 
-M: ds-loc translate-out-loc n>> out-ds-heights get at + <ds-loc> ;
-M: rs-loc translate-out-loc n>> out-rs-heights get at + <ds-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 ;

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

@@ -1,9 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel make
-namespaces sequences
-compiler.cfg.rpo
-compiler.cfg.instructions ;
+USING: accessors assocs kernel make namespaces sequences math
+compiler.cfg.rpo compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.dcn.height ;
 IN: compiler.cfg.dcn.local
 
 <PRIVATE
@@ -20,15 +19,29 @@ SYMBOLS: reads-locations writes-locations ;
     dup writes-locations get at
     [ ] [ reads-locations get at ] ?if ;
 
+SYMBOL: ds-height
+
+SYMBOL: rs-height
+
+GENERIC: translate-loc ( loc -- loc' )
+
+M: ds-loc translate-loc n>> ds-height get - <ds-loc> ;
+
+M: rs-loc translate-loc n>> rs-height get - <rs-loc> ;
+
 GENERIC: visit ( insn -- )
 
 M: insn visit , ;
 
+M: ##inc-d visit n>> ds-height [ + ] change ;
+
+M: ##inc-r visit n>> rs-height [ + ] change ;
+
 M: ##peek visit
     ! If location is in a register already, copy existing
     ! register to destination. Otherwise, associate the
     ! location with the register.
-    [ dst>> ] [ loc>> ] bi dup loc>vreg
+    [ dst>> ] [ loc>> translate-loc ] bi dup loc>vreg
     [ [ record-copy ] [ ##copy ] 2bi ]
     [ reads-locations get set-at ]
     ?if ;
@@ -36,7 +49,7 @@ M: ##peek visit
 M: ##replace visit
     ! If location already contains the same value, do nothing.
     ! Otherwise, associate the location with the register.
-    [ src>> resolve-copy ] [ loc>> ] bi 2dup loc>vreg =
+    [ src>> resolve-copy ] [ loc>> translate-loc ] bi 2dup loc>vreg =
     [ 2drop ] [ writes-locations get set-at ] if ;
 
 M: ##copy visit
@@ -44,22 +57,33 @@ M: ##copy visit
     ! on input to dcn pass, but in the future it might.
     [ dst>> ] [ src>> resolve-copy ] bi record-copy ;
 
+: insert-height-changes ( -- )
+    ds-height get dup 0 = [ drop ] [ ##inc-d ] if
+    rs-height get dup 0 = [ drop ] [ ##inc-r ] if ;
+
 : local-analysis ( bb -- )
     ! Removes all ##peek and ##replace from the basic block.
     ! Conceptually, moves all ##peeks to the start
     ! (reads-locations assoc) and all ##replaces to the end
     ! (writes-locations assoc).
+    0 ds-height set
+    0 rs-height set
     H{ } clone copies set
     H{ } clone reads-locations set
     H{ } clone writes-locations set
-    [ [ [ visit ] each ] V{ } make ] change-instructions drop ;
+    [
+        [
+            [ visit ] each
+            insert-height-changes
+        ] V{ } make
+    ] change-instructions drop ;
 
 SYMBOLS: peeks replaces ;
 
 : visit-block ( bb -- )
     [ local-analysis ]
-    [ [ reads-locations get ] dip peeks get set-at ]
-    [ [ writes-locations get ] dip replaces get set-at ]
+    [ [ reads-locations get ] dip [ translate-in-set ] keep peeks get set-at ]
+    [ [ writes-locations get ] dip [ translate-in-set ] keep replaces get set-at ]
     tri ;
 
 PRIVATE>

basis/compiler/cfg/utilities/utilities.factor

@@ -51,6 +51,12 @@ IN: compiler.cfg.utilities
     begin-basic-block
     basic-block get '[ [ _ swap successors>> push ] when* ] each ;
 
+PREDICATE: kill-block < basic-block
+    instructions>> {
+        [ length 2 = ]
+        [ first kill-vreg-insn? ]
+    } 1&& ;
+
 : back-edge? ( from to -- ? )
     [ number>> ] bi@ >= ;