compiler.cfg.stacks.local: change current-height to a two-tuple { { d emit-d } { r emit-r } } it makes the code a bit simpler

basis/compiler/cfg/builder/blocks/blocks-docs.factor

@@ -1,5 +1,5 @@
-USING: compiler.cfg compiler.tree help.markup help.syntax literals math
+USING: compiler.cfg compiler.cfg.stacks.local compiler.tree help.markup
-multiline quotations ;
+help.syntax literals math multiline quotations sequences ;
 IN: compiler.cfg.builder.blocks
 
 <<
@@ -48,8 +48,20 @@ HELP: emit-trivial-block
 { $description "Combinator that emits a trivial block, constructed by calling the supplied quotation." }
 { $examples { $unchecked-example $[ ex-emit-trivial-block ] } } ;
 
+HELP: end-branch
+{ $values { "pair/f" "two-tuple" } }
+{ $description "pair is { final-bb final-height }" } ;
+
 HELP: initial-basic-block
 { $description "Creates an initial empty " { $link basic-block } " and stores it in the basic-block dynamic variable." } ;
 
 HELP: make-kill-block
 { $description "Marks the current " { $link basic-block } " being processed as a kill block." } ;
+
+HELP: set-successors
+{ $values { "successor" basic-block } { "blocks" sequence } }
+{ $description "Set the successor of each block to " { $slot "successor" } "." } ;
+
+HELP: with-branch
+{ $values { "quot" quotation } { "pair/f" "a pair or f" } }
+{ $description "The pair is either " { $link f } " or a two-tuple containing a " { $link basic-block } " and a " { $link height-state } " two-tuple." } ;

basis/compiler/cfg/builder/blocks/blocks-tests.factor

@@ -0,0 +1,11 @@
+USING: accessors compiler.cfg compiler.cfg.builder.blocks kernel sequences
+tools.test ;
+IN: compiler.cfg.builder.blocks.tests
+
+{
+    { "succ" "succ" "succ" }
+} [
+    <basic-block> "succ" >>number 3 [ <basic-block> ] replicate
+    [ set-successors ] keep
+    [ successors>> first number>> ] map
+] unit-test

basis/compiler/cfg/builder/blocks/blocks.factor

@@ -46,29 +46,28 @@ IN: compiler.cfg.builder.blocks
         make-kill-block
     ] emit-trivial-block ;
 
-: begin-branch ( -- ) clone-current-height (begin-basic-block) ;
+: begin-branch ( -- )
+    height-state [ clone-height-state ] change
+    (begin-basic-block) ;
 
 : end-branch ( -- pair/f )
-    ! pair is { final-bb final-height }
     basic-block get dup [
         ##branch,
         end-local-analysis
-        current-height get clone 2array
+        height-state get clone-height-state 2array
     ] when ;
 
 : with-branch ( quot -- pair/f )
     [ begin-branch call end-branch ] with-scope ; inline
 
-: set-successors ( branches -- )
+: set-successors ( successor blocks -- )
-    ! Set the successor of each branch's final basic block to the
+    [ successors>> push ] with each ;
-    ! current block.
-    [ [ [ basic-block get ] dip first successors>> push ] when* ] each ;
 
 : emit-conditional ( branches -- )
     ! branches is a sequence of pairs as above
     end-basic-block
-    dup [ ] find nip dup [
+    sift [
-        second current-height set
+        dup first second height-state set
         begin-basic-block
-        set-successors
+        [ basic-block get ] dip [ first ] map set-successors
-    ] [ 2drop ] if ;
+    ] unless-empty ;

basis/compiler/cfg/builder/builder-docs.factor

@@ -8,21 +8,23 @@ STRING: ex-emit-call
 USING: compiler.cfg.builder compiler.cfg.builder.blocks compiler.cfg.stacks
 kernel make prettyprint ;
 begin-stack-analysis initial-basic-block \ dummy 3 [ emit-call ] { } make drop
-current-height basic-block [ get . ] bi@ .
+height-state basic-block [ get . ] bi@
-T{ current-height { d 3 } }
+{ { 3 0 } { 0 0 } }
 T{ basic-block
-    { id 134 }
+    { id 1903165 }
     { successors
         V{
             T{ basic-block
-                { id 135 }
+                { id 1903166 }
                 { instructions
                     V{
                         T{ ##call { word dummy } }
                         T{ ##branch }
                     }
                 }
-                { successors V{ T{ basic-block { id 136 } } } }
+                { successors
+                    V{ T{ basic-block { id 1903167 } } }
+                }
                 { kill-block? t }
             }
         }
@@ -51,7 +53,7 @@ HELP: make-input-map
 
 HELP: emit-call
 { $values { "word" word } { "height" number } }
-{ $description "Emits a call to the given word to the " { $link cfg } " being constructed. \"height\" is the number of items being added to or removed from the data stack. Side effects of the word is that it modifies the \"basic-block\" and " { $link current-height } " variables." }
+{ $description "Emits a call to the given word to the " { $link cfg } " being constructed. \"height\" is the number of items being added to or removed from the data stack. Side effects of the word is that it modifies the \"basic-block\" and " { $link height-state } " variables." }
 { $examples
   "In this example, a call to a dummy word is emitted which pushes three items onto the stack."
   { $unchecked-example $[ ex-emit-call ] }

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

@@ -2,11 +2,12 @@ USING: accessors alien alien.accessors arrays assocs byte-arrays
 combinators.short-circuit compiler.cfg compiler.cfg.builder compiler.cfg.checker
 compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.optimizer
 compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.rpo
-compiler.cfg.stacks.local compiler.tree compiler.tree.builder
+compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.utilities
-compiler.tree.optimizer compiler.cfg.representations fry hashtables kernel
+compiler.tree compiler.tree.builder compiler.tree.optimizer
-kernel.private locals make math math.partial-dispatch math.private namespaces
+compiler.cfg.representations fry hashtables kernel kernel.private locals make
-prettyprint sbufs sequences sequences.private slots.private strings
+math math.partial-dispatch math.private namespaces prettyprint sbufs sequences
-strings.private  tools.test vectors words ;
+sequences.private slots.private strings strings.private tools.test vectors
+words ;
 FROM: alien.c-types => int ;
 IN: compiler.cfg.builder.tests
 
@@ -251,8 +252,8 @@ IN: compiler.cfg.builder.tests
 {
     { T{ ##load-integer { dst 78 } { val 0 } } }
 } [
+    initial-height-state height-state set
     77 vreg-counter set-global
-    current-height new current-height set
     H{ } clone replace-mapping set
     [
         T{ #push { literal 0 } { out-d { 8537399 } } } emit-node
@@ -260,11 +261,11 @@ IN: compiler.cfg.builder.tests
 ] unit-test
 
 {
-    T{ current-height { d 1 } { emit-d 1 } }
+    { { 1 1 } { 0 0 } }
     H{ { D -1 4 } { D 0 4 } }
 } [
     0 vreg-counter set-global
-    current-height new current-height set
+    initial-height-state height-state set
     H{ } clone replace-mapping set
     4 D 0 replace-loc
     T{ #shuffle
@@ -272,7 +273,13 @@ IN: compiler.cfg.builder.tests
        { in-d V{ 4 } }
        { out-d V{ 2 3 } }
     } emit-node
-
+    height-state get
-    current-height get
     replace-mapping get
 ] unit-test
+
+{ 1 } [
+    V{ } 0 insns>block basic-block set
+    begin-stack-analysis begin-local-analysis
+    V{ } 1 insns>block [ emit-loop-call ] V{ } make drop
+    basic-block get successors>> length
+] unit-test

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

@@ -54,7 +54,7 @@ IN: compiler.cfg.intrinsics.simd.tests
     [ \ basic-block pick set-at ]
     [ 0 swap associate \ ds-heights pick set-at ]
     [ 0 swap associate \ rs-heights pick set-at ] tri
-        T{ current-height { d 0 } { r 0 } { emit-d 0 } { emit-r 0 } } \ current-height pick set-at
+    initial-height-state \ height-state pick set-at
     H{ } clone \ local-peek-set pick set-at
     H{ } clone \ replace-mapping pick set-at
     H{ } <biassoc> \ locs>vregs pick set-at
@@ -534,4 +534,3 @@ unit-test
 
 [ simple-ops-cpu 3 [ emit-simd-v+ ] test-emit ]
 [ bad-simd-intrinsic? ] must-fail-with
-

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

@@ -1,20 +1,13 @@
-USING: assocs compiler.cfg compiler.cfg.registers help.markup help.syntax math
+USING: assocs compiler.cfg compiler.cfg.instructions compiler.cfg.registers
-sequences ;
+help.markup help.syntax math sequences ;
 IN: compiler.cfg.stacks.local
 
 HELP: replace-mapping
 { $var-description "An " { $link assoc } " that maps from stack locations to virtual registers that were put on the stack." }
 { $see-also replace-loc } ;
 
-HELP: current-height
+HELP: height-state
-{ $class-description "A tuple used to keep track of the heights of the data and retain stacks in a " { $link basic-block } " The idea is that if the stack change instructions are tracked, then multiple changes can be folded into one. It has the following slots:"
+{ $var-description "A two-tuple used to keep track of the heights of the data and retain stacks in a " { $link basic-block } " The idea is that if the stack change instructions are tracked, then multiple changes can be folded into one. The first item is the datastacks current height and queued up height change. The second item is the same for the retain stack." } ;
-  { $table
-    { { $slot "d" } { "Current datastack height." } }
-    { { $slot "r" } { "Current retainstack height." } }
-    { { $slot "emit-d" } { "Queued up datastack height change." } }
-    { { $slot "emit-r" } { "Queued up retainstack height change." } }
-  }
-} ;
 
 HELP: loc>vreg
 { $values { "loc" loc } { "vreg" "virtual register" } }
@@ -26,26 +19,27 @@ HELP: replace-loc
 
 HELP: peek-loc
 { $values { "loc" loc } { "vreg" "virtaul register" } }
-{ $description "Retrieves the virtual register and the given stack location." } ;
+{ $description "Retrieves the virtual register at the given stack location." } ;
 
 HELP: translate-local-loc
-{ $values { "loc" loc } { "loc'" loc } }
+{ $values { "state" "height state" } { "loc" loc } { "loc'" loc } }
-{ $description "Translates an absolute stack location to one that is relative to the current stacks height as given in " { $link current-height } "." }
+{ $description "Translates an absolute stack location to one that is relative to the given height state." }
 { $examples
   { $example
     "USING: compiler.cfg.stacks.local compiler.cfg.registers compiler.cfg.debugger namespaces prettyprint ;"
-    "T{ current-height { d 3 } } current-height set D 7 translate-local-loc ."
+    "{ { 3 0 } { 0 0 } } D 7 translate-local-loc ."
     "D 4"
   }
-} ;
+}
+{ $see-also height-state } ;
 
-HELP: height-changes
+HELP: height-state>insns
-{ $values { "current-height" current-height } { "insns" sequence } }
+{ $values { "state" sequence } { "insns" sequence } }
-{ $description "Converts a " { $link current-height } " tuple to 0-2 stack height change instructions." }
+{ $description "Converts a " { $link height-state } " tuple to 0-2 stack height change instructions." }
 { $examples
   { $example
     "USING: compiler.cfg.stacks.local prettyprint ;"
-    "T{ current-height { emit-d 4 } { emit-r -2 } } height-changes ."
+    "{ { 0 4 } { 0 -2 } } height-state>insns ."
     "{ T{ ##inc { loc D 4 } } T{ ##inc { loc R -2 } } }"
   }
 } ;
@@ -55,7 +49,11 @@ HELP: emit-changes
 
 HELP: inc-d
 { $values { "n" number } }
-{ $description "Increases or decreases the current datastacks height." } ;
+{ $description "Increases or decreases the current datastacks height. An " { $link ##inc } " instruction will later be inserted." } ;
+
+HELP: inc-r
+{ $values { "n" number } }
+{ $description "Increases or decreases the current retainstacks height. An " { $link ##inc } " instruction will later be inserted." } ;
 
 ARTICLE: "compiler.cfg.stacks.local" "Local stack analysis"
 "Local stack analysis. We build three sets for every basic block in the CFG:"

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

@@ -1,19 +1,27 @@
 USING: accessors assocs biassocs combinators compiler.cfg
 compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks
-compiler.cfg.stacks.local compiler.cfg.utilities cpu.architecture kernel
+compiler.cfg.stacks.height compiler.cfg.stacks.local compiler.cfg.utilities
-namespaces sequences tools.test ;
+cpu.architecture namespaces kernel tools.test ;
 IN: compiler.cfg.stacks.local.tests
 
-{ T{ current-height f 3 0 3 0 } } [
+{
-    current-height new current-height [
+    { { 3 3 } { 0 0 } }
-        3 inc-d current-height get
+} [
-    ] with-variable
+    initial-height-state height-state set
+    3 inc-d height-state get
+] unit-test
+
+{
+    { { 5 3 } { 0 0 } }
+} [
+    { { 2 0 } { 0 0 } } height-state set
+    3 inc-d height-state get
 ] unit-test
 
 {
     { T{ ##inc { loc D 4 } } T{ ##inc { loc R -2 } } }
 } [
-    T{ current-height { emit-d 4 } { emit-r -2 } } height-changes
+    { { 0 4  } { 0 -2 } } height-state>insns
 ] unit-test
 
 { 30 } [
@@ -31,7 +39,7 @@ IN: compiler.cfg.stacks.local.tests
 ] unit-test
 
 { 80 } [
-    current-height new current-height set
+    initial-height-state height-state set
     H{ } clone replace-mapping set 80
     D 77 replace-loc D 77 peek-loc
 ] unit-test
@@ -41,3 +49,14 @@ IN: compiler.cfg.stacks.local.tests
     begin-stack-analysis begin-local-analysis
     compute-local-kill-set assoc-size
 ] unit-test
+
+{ H{ { R -4 R -4 } } } [
+    H{ { 77 4 } } [ ds-heights set ] [ rs-heights set ] bi
+    { { 8 0 } { 3 0 } } height-state set
+    77 basic-block set
+    compute-local-kill-set
+] unit-test
+
+{ D 2 } [
+    { { 1 2 } { 3 4 } } D 3 translate-local-loc2
+] unit-test

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

@@ -2,76 +2,88 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators compiler.cfg
 compiler.cfg.instructions compiler.cfg.parallel-copy
-compiler.cfg.registers compiler.cfg.stacks.height kernel make
+compiler.cfg.registers compiler.cfg.stacks.height
-math math.order namespaces sequences sets ;
+kernel make math math.order namespaces sequences sets ;
 FROM: namespaces => set ;
 IN: compiler.cfg.stacks.local
 
-SYMBOLS: peek-sets replace-sets kill-sets ;
+: >loc< ( loc -- n ds? )
+    [ n>> ] [ ds-loc? ] bi ;
+
+: modify-height ( state loc -- )
+    >loc< 0 1 ? rot nth [ + ] with map! drop ;
+
+: adjust ( state loc -- )
+    >loc< 0 1 ? rot nth dup first swapd + 0 rot set-nth ;
+
+: reset-emits ( state -- )
+    [ 0 1 rot set-nth ] each ;
+
+: height-state>insns ( state -- insns )
+    [ second ] map { ds-loc rs-loc } [ new swap >>n ] 2map
+    [ n>> 0 = not ] filter [ ##inc new swap >>loc ] map ;
+
+: translate-local-loc ( state loc -- loc' )
+    >loc< [ 0 1 ? rot nth first - ] keep ds-loc rs-loc ? new swap >>n ;
+
+: clone-height-state ( state -- state' )
+    [ clone ] map ;
+
+: initial-height-state ( -- state )
+    { { 0 0 } { 0 0 } } clone-height-state ;
+
+: kill-locations ( saved-height height -- seq )
+    dupd [-] iota [ swap - ] with map ;
+
+: local-kill-set ( ds-height rs-height state -- assoc )
+    first2 [ first ] bi@ swapd [ kill-locations ] 2bi@
+    [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
+    append unique ;
+
+SYMBOLS: height-state peek-sets replace-sets kill-sets ;
 
 SYMBOL: locs>vregs
 
 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
 
-TUPLE: current-height
-{ d initial: 0 }
-{ r initial: 0 }
-{ emit-d initial: 0 }
-{ emit-r initial: 0 } ;
-
 SYMBOLS: local-peek-set local-replace-set replace-mapping ;
 
-GENERIC: translate-local-loc ( loc -- loc' )
-M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
-M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
-
 : stack-changes ( replace-mapping -- insns )
     [ [ loc>vreg ] dip ] assoc-map parallel-copy ;
 
-: height-changes ( current-height -- insns )
-    [ emit-d>> <ds-loc> ] [ emit-r>> <rs-loc> ] bi 2array
-    [ n>> 0 = not ] filter [ ##inc new swap >>loc ] map ;
-
 : emit-changes ( -- )
     building get pop
     replace-mapping get stack-changes %
-    current-height get height-changes %
+    height-state get height-state>insns %
     , ;
 
-! inc-d/inc-r: these emit ##inc to change the stack height later
 : inc-d ( n -- )
-    current-height get
+    height-state get swap <ds-loc> modify-height ;
-    [ [ + ] change-emit-d drop ]
-    [ [ + ] change-d drop ]
-    2bi ;
 
 : inc-r ( n -- )
-    current-height get
+    height-state get swap <rs-loc> modify-height ;
-    [ [ + ] change-emit-r drop ]
-    [ [ + ] change-r drop ]
-    2bi ;
 
 : peek-loc ( loc -- vreg )
-    translate-local-loc
+    height-state get swap translate-local-loc
     dup replace-mapping get at
     [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
 
 : replace-loc ( vreg loc -- )
-    translate-local-loc replace-mapping get set-at ;
+    height-state get swap translate-local-loc
+    replace-mapping get set-at ;
 
 : compute-local-kill-set ( -- assoc )
-    basic-block get current-height get
+    basic-block get [ rs-heights get at ] [ ds-heights get at ] bi
-    [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
+    height-state get local-kill-set ;
-    [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ] 2bi
-    append unique ;
 
 : begin-local-analysis ( -- )
     H{ } clone local-peek-set set
     H{ } clone replace-mapping set
-    current-height get
+    height-state get
-    [ 0 >>emit-d 0 >>emit-r drop ]
+    [ reset-emits ] [
-    [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
+        first2 [ first ] bi@ basic-block get record-stack-heights
+    ] bi ;
 
 : remove-redundant-replaces ( -- )
     replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
@@ -86,9 +98,6 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
         [ [ compute-local-kill-set ] dip kill-sets get set-at ]
     } cleave ;
 
-: clone-current-height ( -- )
-    current-height [ clone ] change ;
-
 : peek-set ( bb -- assoc ) peek-sets get at ;
 : replace-set ( bb -- assoc ) replace-sets get at ;
 : kill-set ( bb -- assoc ) kill-sets get at ;

basis/compiler/cfg/stacks/map/map.factor

@@ -1,6 +1,6 @@
 USING: accessors arrays assocs combinators compiler.cfg.dataflow-analysis
-compiler.cfg.instructions compiler.cfg.linearization compiler.cfg.registers fry
+compiler.cfg.instructions compiler.cfg.linearization compiler.cfg.stacks.local
-kernel math math.order namespaces sequences ;
+compiler.cfg.registers fry kernel math math.order namespaces sequences ;
 QUALIFIED: sets
 IN: compiler.cfg.stacks.map
 
@@ -19,11 +19,8 @@ IN: compiler.cfg.stacks.map
 
 CONSTANT: initial-state { { 0 { } } { 0 { } } }
 
-: insn>location ( insn -- n ds? )
-    loc>> [ n>> ] [ ds-loc? ] bi ;
-
 : mark-location ( state insn -- state' )
-    [ first2 ] dip insn>location
+    [ first2 ] dip loc>> >loc<
     [ rot register-write swap ] [ swap register-write ] if 2array ;
 
 : fill-vacancies ( state -- state' )
@@ -32,7 +29,7 @@ CONSTANT: initial-state { { 0 { } } { 0 { } } }
 GENERIC: visit-insn ( state insn -- state' )
 
 M: ##inc visit-insn ( state insn -- state' )
-    [ first2 ] dip insn>location
+    [ first2 ] dip loc>> >loc<
     [ rot adjust-stack swap ] [ swap adjust-stack ] if 2array
     ! Negative out-of stack locations immediately becomes garbage.
     [ first2 [ 0 >= ] filter 2array ] map ;
@@ -43,7 +40,7 @@ M: ##replace visit-insn mark-location ;
 ERROR: vacant-peek insn ;
 
 : underflowable-peek? ( state peek -- ? )
-    2dup insn>location swap [ 0 1 ? swap nth ] dip classify-read
+    2dup loc>> >loc< swap [ 0 1 ? swap nth ] dip classify-read
     dup 2 = [ drop vacant-peek ] [ 2nip 1 = ] if ;
 
 M: ##peek visit-insn ( state insn -- state' )

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

@@ -8,7 +8,7 @@ HELP: ds-push
 
 HELP: begin-stack-analysis
 { $description "Initializes a set of variables related to stack analysis of Factor words." }
-{ $see-also current-height } ;
+{ $see-also height-state } ;
 
 HELP: end-stack-analysis
 { $description "Ends the stack analysis of the current cfg." } ;
@@ -26,7 +26,7 @@ HELP: ds-store
 
 HELP: rs-store
 { $values { "vregs" "a " { $link sequence } " of vregs." } }
-{ $description "Stores one or more virtual register values on the retain stack. This modifies the " { $link current-height } " dynamic variable." } ;
+{ $description "Stores one or more virtual register values on the retain stack. This modifies the " { $link height-state } " dynamic variable." } ;
 
 HELP: 2inputs
 { $values { "vreg1" "a vreg" } { "vreg2" "a vreg" } }

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

@@ -4,7 +4,7 @@ IN: compiler.cfg.stacks
 
 { H{ { D -2 4 } { D -1 3 } { D -3 5 } } } [
     {
-        ${ current-height current-height new }
+        ${ height-state initial-height-state }
         ${ replace-mapping H{ } clone }
     } [
         { 3 4 5 } ds-store replace-mapping get

basis/compiler/cfg/stacks/stacks.factor

@@ -13,7 +13,7 @@ IN: compiler.cfg.stacks
     H{ } clone peek-sets set
     H{ } clone replace-sets set
     H{ } clone kill-sets set
-    current-height new current-height set ;
+    initial-height-state height-state set ;
 
 : end-stack-analysis ( -- )
     cfg get
@@ -32,7 +32,8 @@ IN: compiler.cfg.stacks
 
 : ds-pop ( -- vreg ) ds-peek ds-drop ;
 
-: ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ;
+: ds-push ( vreg -- )
+    1 inc-d D 0 replace-loc ;
 
 : ds-load ( n -- vregs )
     dup 0 =
@@ -71,4 +72,5 @@ IN: compiler.cfg.stacks
 : unary-op ( quot -- )
     [ ds-pop ] dip call ds-push ; inline
 
-: adjust-d ( n -- ) current-height get [ + ] change-d drop ;
+: adjust-d ( n -- )
+    <ds-loc> height-state get swap adjust ;