! 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
: 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 ;
{ { 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
{
{ 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 } [
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> ;
-: ds-peek ( -- vreg ) D 0 peek-loc ;
+: (load-vregs) ( n loc-class -- vregs )
+ swap stack-locs [ peek-loc ] map ;
-: ds-pop ( -- vreg ) ds-peek ds-drop ;
+: load-vregs ( n loc-class -- vregs )
+ [ (load-vregs) ] [ new swap neg >>n inc-stack ] 2bi ;
-: ds-push ( vreg -- )
- 1 <ds-loc> inc-stack D 0 replace-loc ;
+: store-vregs ( vregs loc-class -- )
+ over length stack-locs [ replace-loc ] 2each ;
-: stack-locs ( loc-class n -- locs )
- iota [ swap new swap >>n ] with map <reversed> ;
+! Utility
+: ds-drop ( -- ) D -1 inc-stack ;
-: vregs>stack-locs ( loc-class vregs -- locs )
- length stack-locs ;
+: ds-peek ( -- vreg ) D 0 peek-loc ;
-: ds-load ( n -- vregs )
- [ iota <reversed> [ <ds-loc> peek-loc ] map ]
- [ neg <ds-loc> inc-stack ] bi ;
+: ds-pop ( -- vreg ) ds-peek ds-drop ;
-: store-vregs ( vregs loc-class -- )
- over vregs>stack-locs [ replace-loc ] 2each ;
+: ds-push ( vreg -- )
+ 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 <ds-loc> 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 <ds-loc> inc-stack ;
+ 3 ds-loc load-vregs first3 ;
: binary-op ( quot -- )
[ 2inputs ] dip call ds-push ; inline