compiler.cfg.*: better way to store the block height

It is stored as a height-state instance on the height slot of the
basic-block. It will make better analysis possible because you see how
much the height increased or decreased in the block.

basis/compiler/cfg/cfg-docs.factor

@@ -1,7 +1,7 @@
 USING: compiler.cfg.instructions compiler.cfg.rpo
-compiler.cfg.stack-frame compiler.tree cpu.x86.assembler.operands
+compiler.cfg.stack-frame compiler.cfg.stacks.local compiler.tree
-help.markup help.syntax kernel math namespaces sequences vectors words
+cpu.x86.assembler.operands help.markup help.syntax kernel math
-;
+namespaces sequences vectors words ;
 IN: compiler.cfg
 
 HELP: basic-block
@@ -29,12 +29,8 @@ HELP: basic-block
         { "The first and the last block in a cfg and all blocks containing " { $link ##call } " instructions are kill blocks. Kill blocks can't be optimized so they are omitted from certain optimization steps." }
     }
     {
-        { $slot "ds-height" }
+        { $slot "height" }
-        "The datastacks height at the entry of the block. Used during cfg construction."
+        "Block's height as a " { $link height-state } ". What the heights of the block was at entry and how much they were increased in the block."
-    }
-    {
-        { $slot "rs-height" }
-        "The retainstacks height at the entry of the block. Used during cfg construction."
     }
     {
         { $slot "replaces" }

basis/compiler/cfg/cfg.factor

@@ -10,7 +10,7 @@ TUPLE: basic-block < identity-tuple
     { successors vector }
     { predecessors vector }
     { kill-block? boolean }
-    ds-height rs-height
+    height
     replaces
     peeks
     kills ;

basis/compiler/cfg/intrinsics/simd/simd-tests.factor

@@ -49,10 +49,10 @@ IN: compiler.cfg.intrinsics.simd.tests
 
 : test-compiler-env ( -- x )
     H{ } clone
-    T{ basic-block } 0 >>ds-height 0 >>rs-height
+    T{ basic-block } 0 0 0 0 height-state boa >>height
     \ basic-block pick set-at
 
-    initial-height-state \ height-state pick set-at
+    0 0 0 0 height-state boa \ height-state pick set-at
     HS{ } clone \ local-peek-set pick set-at
     H{ } clone \ replaces pick set-at
     H{ } <biassoc> \ locs>vregs pick set-at ;

basis/compiler/cfg/stacks/finalize/finalize-tests.factor

@@ -12,14 +12,3 @@ IN: compiler.cfg.stacks.finalize.tests
     [ successors>> first instructions>> first ]
     [ predecessors>> first instructions>> first ] bi*
 ] unit-test
-
-{
-    T{ ds-loc f 4 }
-    T{ rs-loc f 5 }
-} [
-    begin-stack-analysis
-    3 4 T{ basic-block }
-    [ record-stack-heights ]
-    [ D: 1 swap local-loc>global ]
-    [ R: 1 swap local-loc>global ] tri
-] unit-test

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -18,7 +18,7 @@ IN: compiler.cfg.stacks.finalize
 
 : each-insertion ( ... set bb quot: ( ... vreg loc -- ... ) -- ... )
     [ members ] 2dip
-    '[ [ loc>vreg ] [ _ local-loc>global ] bi @ ] each ; inline
+    '[ [ loc>vreg ] [ _ height>> local-loc>global ] bi @ ] each ; inline
 
 ERROR: bad-peek dst loc ;
 

basis/compiler/cfg/stacks/local/local-docs.factor

@@ -3,6 +3,10 @@ compiler.cfg.registers compiler.cfg.stacks hash-sets hashtables
 help.markup help.syntax kernel math sequences ;
 IN: compiler.cfg.stacks.local
 
+HELP: begin-local-analysis
+{ $values { "basic-block" basic-block } }
+{ $description "Begins the local analysis of the block. The height slot of the block is initialized with the resulting height of the last block." } ;
+
 HELP: emit-insns
 { $values { "replaces" sequence } { "state" sequence } }
 { $description "Insert height and stack changes prior to the last instruction." } ;
@@ -87,10 +91,6 @@ HELP: peek-loc
 { $values { "loc" loc } { "vreg" "virtual register" } }
 { $description "Retrieves the virtual register at the given stack location. If no register has been stored at that location, then a new vreg is returned." } ;
 
-HELP: record-stack-heights
-{ $values { "ds-height" number } { "rs-height" number } { "bb" basic-block } }
-{ $description "Sets the data and retain stack heights in relation to the cfg of this basic block." } ;
-
 HELP: replace-loc
 { $values { "vreg" "virtual register" } { "loc" loc } }
 { $description "Registers that the absolute stack location " { $snippet "loc" } " should be overwritten with the contents of the virtual register." }
@@ -101,13 +101,15 @@ HELP: replaces
 { $see-also replace-loc } ;
 
 ARTICLE: "compiler.cfg.stacks.local" "Local stack analysis"
-"Local stack analysis. For each " { $link basic-block } " in the " { $link cfg } ", three sets containing stack locations are built:"
+"For each " { $link basic-block } " in the " { $link cfg } ", local stack analysis is performed. The analysis is started right after the block is created with " { $link begin-local-analysis } " and finished with " { $link end-local-analysis } ", when the construction of the block is complete. During the analysis, three sets containing stack locations are built:"
 { $list
   { { $slot "peeks" } " all stack locations that the block reads before writing" }
   { { $slot "replaces" } " all stack locations that the block writes" }
   { { $slot "kills" } " all stack locations which become unavailable after the block ends because of the stack height being decremented. For example, if the block contains " { $link drop } ", then D: 0 will be contained in kills because that stack location will not be live anymore." }
 }
-"This is done while constructing the CFG."
+"This is done while constructing the CFG. These sets are then used by the " { $link end-stack-analysis } " word to emit optimal sequences of " { $link ##peek } " and " { $link ##replace } " instructions to the cfg."
+$nl
+"For example, the code [ dup dup dup ] will only execute ##peek once, instead of three time which a 'non-lazy' method would."
 $nl
 "Words for reading the stack state:"
 { $subsections

basis/compiler/cfg/stacks/local/local-tests.factor

@@ -13,23 +13,31 @@ IN: compiler.cfg.stacks.local.tests
     HS{ }
 } [
     V{ } 137 insns>block
-    [ 0 0 rot record-stack-heights ]
     [ [ "eh" , end-local-analysis ] V{ } make drop ]
-    [ [ peeks>> ] [ replaces>> ] [ kills>> ] tri ] tri
+    [ [ peeks>> ] [ replaces>> ] [ kills>> ] tri ] bi
 ] cfg-unit-test
 
 {
     HS{ D: 3 }
 } [
     V{ } 137 insns>block
-    [ 0 0 rot record-stack-heights ]
     [ [ 3 D: 3 replace-loc "eh" , end-local-analysis ] V{ } make drop ]
-    [ replaces>> ] tri
+    [ replaces>> ] bi
 ] cfg-unit-test
 
 ! local-loc>global
 { D: 6 } [
-    D: 3 <basic-block> 3 >>ds-height local-loc>global
+    D: 3 3 0 0 0 height-state boa
+    local-loc>global
+] unit-test
+
+{
+    D: 4
+    R: 5
+} [
+    3 4 0 0 height-state boa
+    [ D: 1 swap local-loc>global ]
+    [ R: 1 swap local-loc>global ] bi
 ] unit-test
 
 ! kill-locations

basis/compiler/cfg/stacks/local/local.factor

@@ -19,8 +19,8 @@ TUPLE: height-state ds-begin rs-begin ds-inc rs-inc ;
 : global-loc>local ( loc height-state -- loc' )
     [ clone dup >loc< ] dip swap [ ds-height ] [ rs-height ] if - >>n ;
 
-: local-loc>global ( loc bb -- loc' )
+: local-loc>global ( loc height-state -- loc' )
-    [ clone dup >loc< ] dip swap [ ds-height>> ] [ rs-height>> ] if + >>n ;
+    [ clone dup >loc< ] dip swap [ ds-begin>> ] [ rs-begin>> ] if + >>n ;
 
 : inc-stack ( loc -- )
     >loc< height-state get swap
@@ -55,11 +55,7 @@ SYMBOLS: locs>vregs local-peek-set replaces ;
     [ ] [ dup local-peek-set get adjoin loc>vreg ] ?if ;
 
 : replace-loc ( vreg loc -- )
-    height-state get global-loc>local
+    height-state get global-loc>local replaces get set-at ;
-    replaces get set-at ;
-
-: record-stack-heights ( ds-height rs-height bb -- )
-    [ rs-height<< ] keep ds-height<< ;
 
 : kill-locations ( begin inc -- seq )
     0 min neg iota [ swap - ] with map ;
@@ -74,8 +70,8 @@ SYMBOLS: locs>vregs local-peek-set replaces ;
     local-kill-set ;
 
 : begin-local-analysis ( basic-block -- )
-    height-state get reset-incs
+    height-state [ clone ] change
-    height-state get [ ds-begin>> ] [ rs-begin>> ] bi rot record-stack-heights
+    height-state get [ reset-incs ] keep >>height drop
     HS{ } clone local-peek-set namespaces:set
     H{ } clone replaces namespaces:set ;