compiler.cfg.*: ds-load removed

basis/compiler/cfg/builder/builder.factor

@@ -163,7 +163,7 @@ M: #push emit-node
 
 : make-input-map ( #shuffle -- assoc )
     [ in-d>> ds-loc ] [ in-r>> rs-loc ] bi
-    [ over vregs>stack-locs zip ] 2bi@ append ;
+    [ over length stack-locs zip ] 2bi@ append ;
 
 : height-changes ( #shuffle -- height-changes )
     { [ out-d>> ] [ in-d>> ] [ out-r>> ] [ in-r>> ] } cleave

basis/compiler/cfg/intrinsics/allot/allot.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays byte-arrays compiler.cfg.builder.blocks
-compiler.cfg.hats compiler.cfg.instructions compiler.cfg.stacks
+compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers
-compiler.constants compiler.tree.propagation.info
+compiler.cfg.stacks compiler.constants compiler.tree.propagation.info
 cpu.architecture fry kernel layouts locals math math.order
 sequences ;
 IN: compiler.cfg.intrinsics.allot
@@ -12,11 +12,11 @@ IN: compiler.cfg.intrinsics.allot
 
 : emit-simple-allot ( node -- )
     [ in-d>> length ] [ node-output-infos first class>> ] bi
-    [ drop ds-load ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri
+    [ drop ds-loc load-vregs ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri
     [ ##set-slots, ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
 
 : tuple-slot-regs ( layout -- vregs )
-    [ second ds-load ] [ ^^load-literal ] bi prefix ;
+    [ second ds-loc load-vregs ] [ ^^load-literal ] bi prefix ;
 
 : ^^allot-tuple ( n -- dst )
     2 + cells tuple ^^allot ;

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

@@ -8,14 +8,14 @@ IN: compiler.cfg.stacks.local.tests
     { { 3 3 } { 0 0 } }
 } [
     test-init
-    3 <ds-loc> inc-stack height-state get
+    D 3 inc-stack height-state get
 ] unit-test
 
 {
     { { 5 3 } { 0 0 } }
 } [
     { { 2 0 } { 0 0 } } height-state set
-    3 <ds-loc> inc-stack height-state get
+    D 3 inc-stack height-state get
 ] unit-test
 
 {
@@ -40,7 +40,14 @@ IN: compiler.cfg.stacks.local.tests
 
 { 80 } [
     test-init
-    80 D 77 replace-loc D 77 peek-loc
+    80 D 77 replace-loc
+    D 77 peek-loc
+] unit-test
+
+{ H{ { D -1 40 } } } [
+    test-init
+    D 1 inc-stack 40 D 0 replace-loc
+    replace-mapping get
 ] unit-test
 
 { 0 } [

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

@@ -19,3 +19,19 @@ IN: compiler.cfg.stacks.tests
     replace-mapping get
     height-state get
 ] unit-test
+
+! load-vregs
+{
+    { 1 2 3 4 5 6 7 8 }
+} [
+    test-init 8 ds-loc load-vregs
+] unit-test
+
+! 2inputs
+{
+    1
+    2
+    { { -2 -2 } { 0 0 } }
+} [
+    test-init 2inputs height-state get
+] unit-test

basis/compiler/cfg/stacks/stacks.factor

@@ -26,39 +26,36 @@ IN: compiler.cfg.stacks
         finalize-stack-shuffling
     } apply-passes ;
 
-: ds-drop ( -- ) -1 <ds-loc> inc-stack ;
+: stack-locs ( loc-class n -- locs )
+    iota [ swap new swap >>n ] with map <reversed> ;
+
+: (load-vregs) ( n loc-class -- vregs )
+    swap stack-locs [ peek-loc ] map ;
+
+: load-vregs ( n loc-class -- vregs )
+    [ (load-vregs) ] [ new swap neg >>n inc-stack ] 2bi ;
+
+: store-vregs ( vregs loc-class -- )
+    over length stack-locs [ replace-loc ] 2each ;
+
+! Utility
+: ds-drop ( -- ) D -1 inc-stack ;
 
 : ds-peek ( -- vreg ) D 0 peek-loc ;
 
 : ds-pop ( -- vreg ) ds-peek ds-drop ;
 
 : ds-push ( vreg -- )
-    1 <ds-loc> inc-stack D 0 replace-loc ;
+    D 1 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 )
-    [ iota <reversed> [ <ds-loc> peek-loc ] map ]
-    [ neg <ds-loc> inc-stack ] bi ;
-
-: store-vregs ( vregs loc-class -- )
-    over vregs>stack-locs [ replace-loc ] 2each ;
 
 : (2inputs) ( -- vreg1 vreg2 )
-    D 1 peek-loc D 0 peek-loc ;
+    2 ds-loc (load-vregs) first2 ;
 
 : 2inputs ( -- vreg1 vreg2 )
-    (2inputs) -2 <ds-loc> inc-stack ;
+    2 ds-loc load-vregs first2 ;
-
-: (3inputs) ( -- vreg1 vreg2 vreg3 )
-    D 2 peek-loc D 1 peek-loc D 0 peek-loc ;
 
 : 3inputs ( -- vreg1 vreg2 vreg3 )
-    (3inputs) -3 <ds-loc> inc-stack ;
+    3 ds-loc load-vregs first3 ;
 
 : binary-op ( quot -- )
     [ 2inputs ] dip call ds-push ; inline