diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 847964e30a..b656ddb0b3 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/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 diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index bb46e49c0d..c41be223f8 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/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.constants compiler.tree.propagation.info +compiler.cfg.hats compiler.cfg.instructions compiler.cfg.registers +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 ; diff --git a/basis/compiler/cfg/stacks/local/local-tests.factor b/basis/compiler/cfg/stacks/local/local-tests.factor index 851a13adfa..11740a97ce 100644 --- a/basis/compiler/cfg/stacks/local/local-tests.factor +++ b/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 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 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 } [ diff --git a/basis/compiler/cfg/stacks/stacks-tests.factor b/basis/compiler/cfg/stacks/stacks-tests.factor index d745d86c6e..9ad2c0bd28 100644 --- a/basis/compiler/cfg/stacks/stacks-tests.factor +++ b/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 diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index 201c328e5d..8c6483f48d 100644 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -26,39 +26,36 @@ IN: compiler.cfg.stacks finalize-stack-shuffling } apply-passes ; -: ds-drop ( -- ) -1 inc-stack ; +: stack-locs ( loc-class n -- locs ) + iota [ swap new swap >>n ] with map ; + +: (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 inc-stack D 0 replace-loc ; - -: stack-locs ( loc-class n -- locs ) - iota [ swap new swap >>n ] with map ; - -: vregs>stack-locs ( loc-class vregs -- locs ) - length stack-locs ; - -: ds-load ( n -- vregs ) - [ iota [ peek-loc ] map ] - [ neg inc-stack ] bi ; - -: store-vregs ( vregs loc-class -- ) - over vregs>stack-locs [ replace-loc ] 2each ; + D 1 inc-stack D 0 replace-loc ; : (2inputs) ( -- vreg1 vreg2 ) - D 1 peek-loc D 0 peek-loc ; + 2 ds-loc (load-vregs) first2 ; : 2inputs ( -- vreg1 vreg2 ) - (2inputs) -2 inc-stack ; - -: (3inputs) ( -- vreg1 vreg2 vreg3 ) - D 2 peek-loc D 1 peek-loc D 0 peek-loc ; + 2 ds-loc load-vregs first2 ; : 3inputs ( -- vreg1 vreg2 vreg3 ) - (3inputs) -3 inc-stack ; + 3 ds-loc load-vregs first3 ; : binary-op ( quot -- ) [ 2inputs ] dip call ds-push ; inline