compiler.cfg.*: some refactoring in the stack tracking for #shuffle nodes

instead of having separate words for the stacks like inc-d/r and ds/rs-store use generic words that work on either stack

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

@@ -0,0 +1,13 @@
+USING: alien.c-types compiler.cfg.builder.alien compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.stacks.local compiler.cfg.stacks.tests
+cpu.architecture kernel make namespaces tools.test ;
+IN: compiler.cfg.builder.alien.tests
+
+{
+    { 2 3 }
+    { { int-rep f f } { int-rep f f } }
+    V{ T{ ##unbox-any-c-ptr { dst 2 } { src 1 } } }
+} [
+    test-init
+    [ { c-string int } unbox-parameters ] V{ } make
+] unit-test

basis/compiler/cfg/builder/alien/alien.factor

@@ -32,7 +32,7 @@ IN: compiler.cfg.builder.alien
         [ [ <ds-loc> peek-loc ] [ base-type ] bi* unbox-parameter ]
         2 2 mnmap [ concat ] bi@
     ]
-    [ length neg inc-d ] bi ;
+    [ length neg <ds-loc> inc-stack ] bi ;
 
 : prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
     dup large-struct? [

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

@@ -1,13 +1,13 @@
 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.predecessors compiler.cfg.registers compiler.cfg.representations
-compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.utilities
+compiler.cfg.rpo compiler.cfg.stacks compiler.cfg.stacks.local
-compiler.tree compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.stacks.tests compiler.cfg.utilities compiler.tree
-compiler.cfg.representations fry hashtables kernel kernel.private locals make
+compiler.tree.builder compiler.tree.optimizer fry hashtables kernel
-math math.partial-dispatch math.private namespaces prettyprint sbufs sequences
+kernel.private locals make math math.partial-dispatch math.private namespaces
-sequences.private slots.private strings strings.private tools.test vectors
+prettyprint sbufs sequences sequences.private slots.private strings
-words ;
+strings.private tools.test vectors words ;
 FROM: alien.c-types => int ;
 IN: compiler.cfg.builder.tests
 
@@ -239,11 +239,7 @@ IN: compiler.cfg.builder.tests
 
 ! make-input-map
 {
-    H{
+    { { 37 D 2 } { 81 D 1 } { 92 D 0 } }
-        { 81 T{ ds-loc { n 1 } } }
-        { 37 T{ ds-loc { n 2 } } }
-        { 92 T{ ds-loc } }
-    }
 } [
     T{ #shuffle { in-d { 37 81 92 } } } make-input-map
 ] unit-test
@@ -283,3 +279,23 @@ IN: compiler.cfg.builder.tests
     V{ } 1 insns>block [ emit-loop-call ] V{ } make drop
     basic-block get successors>> length
 ] unit-test
+
+! store-shuffle
+{
+    H{ { D 2 1 } }
+} [
+    test-init
+    T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
+    emit-node replace-mapping get
+] unit-test
+
+{
+    H{ { D -1 1 } { D 0 1 } }
+} [
+    test-init
+    T{ #shuffle
+       { in-d { 7 } }
+       { out-d { 55 77 } }
+       { mapping { { 55 7 } { 77 7 } } }
+    } emit-node replace-mapping get
+] unit-test

basis/compiler/cfg/builder/builder.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators compiler.cfg
+USING: accessors arrays assocs combinators compiler.cfg
 compiler.cfg.builder.blocks compiler.cfg.comparisons
 compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.intrinsics compiler.cfg.registers
@@ -161,28 +161,26 @@ M: #push emit-node
 ! we try not to introduce useless ##peeks here, since this reduces
 ! the accuracy of global stack analysis.
 
-
-
 : make-input-map ( #shuffle -- assoc )
-    [
+    [ in-d>> ds-loc ] [ in-r>> rs-loc ] bi
-        [ in-d>> <reversed> [ <ds-loc> swap ,, ] each-index ]
+    [ over vregs>stack-locs zip ] 2bi@ append ;
-        [ in-r>> <reversed> [ <rs-loc> swap ,, ] each-index ] bi
-    ] H{ } make ;
 
-: make-output-seq ( values mapping input-map -- vregs )
+: height-changes ( #shuffle -- height-changes )
-    '[ _ at _ at peek-loc ] map ;
+    { [ out-d>> ] [ in-d>> ] [ out-r>> ] [ in-r>> ] } cleave
+    4array [ length ] map first4 [ - ] 2bi@ 2array ;
 
-: load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
+: store-height-changes ( #shuffle -- )
-    [ [ out-d>> ] 2dip make-output-seq ]
+    height-changes { ds-loc rs-loc } [ new swap >>n inc-stack ] 2each ;
-    [ [ out-r>> ] 2dip make-output-seq ] 3bi ;
 
-: store-shuffle ( #shuffle ds-vregs rs-vregs -- )
+: extract-outputs ( #shuffle -- seq )
-    [ [ in-d>> length neg inc-d ] dip ds-store ]
+    [ out-d>> ds-loc 2array ] [ out-r>> rs-loc 2array ] bi 2array ;
-    [ [ in-r>> length neg inc-r ] dip rs-store ]
+
-    bi-curry* bi ;
+: out-vregs/stack ( #shuffle -- seq )
+    [ make-input-map ] [ mapping>> ] [ extract-outputs ] tri
+    [ first2 [ [ of of peek-loc ] 2with map ] dip 2array ] 2with map ;
 
 M: #shuffle emit-node
-    dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
+    [ out-vregs/stack ] keep store-height-changes [ first2 store-vregs ] each ;
 
 ! #return
 : end-word ( -- )

basis/compiler/cfg/intrinsics/simd/backend/backend.factor

@@ -125,21 +125,21 @@ MACRO: if-literals-match ( quots -- )
     ] ;
 
 CONSTANT: [unary]        [ ds-drop  ds-pop ]
-CONSTANT: [unary/param]  [ [ -2 inc-d ds-pop ] dip ]
+CONSTANT: [unary/param]  [ [ -2 <ds-loc> inc-stack ds-pop ] dip ]
 CONSTANT: [binary]       [ ds-drop 2inputs ]
-CONSTANT: [binary/param] [ [ -2 inc-d 2inputs ] dip ]
+CONSTANT: [binary/param] [ [ -2 <ds-loc> inc-stack 2inputs ] dip ]
 CONSTANT: [quaternary]
     [
-        ds-drop 
+        ds-drop
         D 3 peek-loc
         D 2 peek-loc
         D 1 peek-loc
         D 0 peek-loc
-        -4 inc-d
+        -4 <ds-loc> inc-stack
     ]
 
 :: [emit-vector-op] ( trials params-quot op-quot literal-preds -- quot )
-    params-quot trials op-quot literal-preds 
+    params-quot trials op-quot literal-preds
     '[ [ _ dip _ @ ds-push ] _ if-literals-match ] ;
 
 MACRO: emit-v-vector-op ( trials -- )
@@ -158,6 +158,5 @@ MACRO:: emit-vv-or-vl-vector-op ( var-trials imm-trials literal-pred -- )
     '[
         dup node-input-infos 2 tail-slice* first literal>> @
         [ _ _ emit-vl-vector-op ]
-        [ _   emit-vv-vector-op ] if 
+        [ _   emit-vv-vector-op ] if
     ] ;
-

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

@@ -47,13 +47,9 @@ HELP: height-state>insns
 HELP: emit-changes
 { $description "Insert height and stack changes prior to the last instruction." } ;
 
-HELP: inc-d
+HELP: inc-stack
-{ $values { "n" number } }
+{ $values { "loc" loc } }
-{ $description "Increases or decreases the current datastacks height. An " { $link ##inc } " instruction will later be inserted." } ;
+{ $description "Increases or decreases the data or retain stack depending on if loc is a " { $link ds-loc } " or " { $link rs-loc } " instance. 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:"
@@ -61,7 +57,19 @@ ARTICLE: "compiler.cfg.stacks.local" "Local stack analysis"
   "peek-set: all stack locations that the block reads before writing"
   "replace-set: all stack locations that the block writes"
   "kill-set: all stack locations which become unavailable after the block ends because of the stack height being decremented" }
-"This is done while constructing the CFG." ;
+"This is done while constructing the CFG."
+$nl
+"Words for reading the stack state:"
+{ $subsections
+  peek-loc
+  translate-local-loc }
+"Words for writing the stack state:"
+{ $subsections
+  adjust
+  inc-stack
+  modify-height
+  replace-loc
+} ;
 
 
 ABOUT: "compiler.cfg.stacks.local"

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

@@ -1,21 +1,21 @@
 USING: accessors assocs biassocs combinators compiler.cfg
 compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks
-compiler.cfg.stacks.height compiler.cfg.stacks.local compiler.cfg.utilities
+compiler.cfg.stacks.height compiler.cfg.stacks.local compiler.cfg.stacks.tests
-cpu.architecture namespaces kernel tools.test ;
+compiler.cfg.utilities cpu.architecture namespaces kernel tools.test ;
 IN: compiler.cfg.stacks.local.tests
 
 {
     { { 3 3 } { 0 0 } }
 } [
-    initial-height-state height-state set
+    test-init
-    3 inc-d height-state get
+    3 <ds-loc> inc-stack height-state get
 ] unit-test
 
 {
     { { 5 3 } { 0 0 } }
 } [
     { { 2 0 } { 0 0 } } height-state set
-    3 inc-d height-state get
+    3 <ds-loc> inc-stack height-state get
 ] unit-test
 
 {
@@ -39,9 +39,8 @@ IN: compiler.cfg.stacks.local.tests
 ] unit-test
 
 { 80 } [
-    initial-height-state height-state set
+    test-init
-    H{ } clone replace-mapping set 80
+    80 D 77 replace-loc D 77 peek-loc
-    D 77 replace-loc D 77 peek-loc
 ] unit-test
 
 { 0 } [
@@ -58,5 +57,5 @@ IN: compiler.cfg.stacks.local.tests
 ] unit-test
 
 { D 2 } [
-    { { 1 2 } { 3 4 } } D 3 translate-local-loc2
+    { { 1 2 } { 3 4 } } D 3 translate-local-loc
 ] unit-test

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

@@ -40,9 +40,10 @@ IN: compiler.cfg.stacks.local
     [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
     append unique ;
 
-SYMBOLS: height-state peek-sets replace-sets kill-sets ;
+SYMBOLS: height-state peek-sets replace-sets kill-sets locs>vregs ;
 
-SYMBOL: locs>vregs
+: inc-stack ( loc -- )
+    height-state get swap modify-height ;
 
 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
@@ -58,12 +59,6 @@ SYMBOLS: local-peek-set local-replace-set replace-mapping ;
     height-state get height-state>insns %
     , ;
 
-: inc-d ( n -- )
-    height-state get swap <ds-loc> modify-height ;
-
-: inc-r ( n -- )
-    height-state get swap <rs-loc> modify-height ;
-
 : peek-loc ( loc -- vreg )
     height-state get swap translate-local-loc
     dup replace-mapping get at

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

@@ -1,5 +1,6 @@
-USING: compiler.cfg.instructions compiler.cfg.stacks.local compiler.tree
+USING: compiler.cfg.instructions compiler.cfg.registers
-help.markup help.syntax math sequences ;
+compiler.cfg.stacks.local compiler.tree help.markup help.syntax math
+sequences ;
 IN: compiler.cfg.stacks
 
 HELP: ds-push
@@ -20,13 +21,12 @@ HELP: adjust-d
 HELP: ds-drop
 { $description "Used to signal to the stack analysis that the datastacks height is decreased by one." } ;
 
-HELP: ds-store
+HELP: store-vregs
-{ $values { "vregs" "a " { $link sequence } " of vregs." } }
+{ $values
-{ $description "Registers that a sequence of vregs are stored at at each corresponding index of the data stack. It is used for compiling " { $link #shuffle } " nodes." } ;
+  { "vregs" "a " { $link sequence } " of vregs" }
-
+  { "loc-class" "either " { $link ds-loc } " or " { $link rs-loc } }
-HELP: rs-store
+}
-{ $values { "vregs" "a " { $link sequence } " of vregs." } }
+{ $description "Stores one or more virtual register values on the data or retain stack. The " { $link replace-mapping } " dynamic variable is modified but the " { $link height-state } " is not touched" } ;
-{ $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

@@ -1,12 +1,21 @@
 USING: accessors arrays assocs combinators compiler.cfg.registers
-compiler.cfg.stacks.local kernel literals namespaces tools.test ;
+compiler.cfg.stacks compiler.cfg.stacks.local kernel literals namespaces
-IN: compiler.cfg.stacks
+tools.test ;
+IN: compiler.cfg.stacks.tests
 
-{ H{ { D -2 4 } { D -1 3 } { D -3 5 } } } [
+: test-init ( -- )
-    {
+    0 vreg-counter set-global
-        ${ height-state initial-height-state }
+    initial-height-state height-state set
-        ${ replace-mapping H{ } clone }
+    H{ } clone replace-mapping set
-    } [
+    H{ } clone locs>vregs set
-        { 3 4 5 } ds-store replace-mapping get
+    H{ } clone local-peek-set set ;
-    ] with-variables
+
+{
+    H{ { D 1 4 } { D 2 3 } { D 0 5 } }
+    { { 0 0 } { 0 0 } }
+} [
+    test-init
+    { 3 4 5 } ds-loc store-vregs
+    replace-mapping get
+    height-state get
 ] unit-test

basis/compiler/cfg/stacks/stacks.factor

@@ -3,7 +3,7 @@
 USING: accessors biassocs compiler.cfg compiler.cfg.registers
 compiler.cfg.stacks.finalize compiler.cfg.stacks.global
 compiler.cfg.stacks.height compiler.cfg.stacks.local compiler.cfg.utilities
-kernel math namespaces sequences ;
+fry kernel math namespaces sequences ;
 IN: compiler.cfg.stacks
 
 : begin-stack-analysis ( -- )
@@ -26,45 +26,39 @@ IN: compiler.cfg.stacks
         finalize-stack-shuffling
     } apply-passes ;
 
-: ds-drop ( -- ) -1 inc-d ;
+: ds-drop ( -- ) -1 <ds-loc> inc-stack ;
 
 : ds-peek ( -- vreg ) D 0 peek-loc ;
 
 : ds-pop ( -- vreg ) ds-peek ds-drop ;
 
 : ds-push ( vreg -- )
-    1 inc-d D 0 replace-loc ;
+    1 <ds-loc> inc-stack D 0 replace-loc ;
+
+: stack-locs ( loc-class n -- locs )
+    iota [ swap new swap >>n ] with map <reversed> ;
+
+: vregs>stack-locs ( loc-class vregs -- locs )
+    length stack-locs ;
 
 : ds-load ( n -- vregs )
-    dup 0 =
+    [ iota <reversed> [ <ds-loc> peek-loc ] map ]
-    [ drop f ]
+    [ neg <ds-loc> inc-stack ] bi ;
-    [ [ iota <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
 
-: ds-store ( vregs -- )
+: store-vregs ( vregs loc-class -- )
-    [
+    over vregs>stack-locs [ replace-loc ] 2each ;
-        <reversed>
-        [ length inc-d ]
-        [ [ <ds-loc> replace-loc ] each-index ] bi
-    ] unless-empty ;
-
-: rs-store ( vregs -- )
-    [
-        <reversed>
-        [ length inc-r ]
-        [ [ <rs-loc> replace-loc ] each-index ] bi
-    ] unless-empty ;
 
 : (2inputs) ( -- vreg1 vreg2 )
     D 1 peek-loc D 0 peek-loc ;
 
 : 2inputs ( -- vreg1 vreg2 )
-    (2inputs) -2 inc-d ;
+    (2inputs) -2 <ds-loc> inc-stack ;
 
 : (3inputs) ( -- vreg1 vreg2 vreg3 )
     D 2 peek-loc D 1 peek-loc D 0 peek-loc ;
 
 : 3inputs ( -- vreg1 vreg2 vreg3 )
-    (3inputs) -3 inc-d ;
+    (3inputs) -3 <ds-loc> inc-stack ;
 
 : binary-op ( quot -- )
     [ 2inputs ] dip call ds-push ; inline