compiler.cfg.*: ds-load removed
Björn Lindqvist
John Benediktsson
parent
cc1903bec1
commit
6559382028
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 } [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: 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 ;
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue