instead of having separate words for the stacks like inc-d/r and ds/rs-store use generic words that work on either stack
--- /dev/null
+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
[ [ <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? [
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.stacks compiler.cfg.stacks.local compiler.cfg.utilities
-compiler.tree compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.representations fry hashtables kernel kernel.private locals make
-math math.partial-dispatch math.private namespaces prettyprint sbufs sequences
-sequences.private slots.private strings strings.private tools.test vectors
-words ;
+compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.representations
+compiler.cfg.rpo compiler.cfg.stacks compiler.cfg.stacks.local
+compiler.cfg.stacks.tests compiler.cfg.utilities compiler.tree
+compiler.tree.builder compiler.tree.optimizer fry hashtables kernel
+kernel.private locals make math math.partial-dispatch math.private namespaces
+prettyprint sbufs sequences sequences.private slots.private strings
+strings.private tools.test vectors words ;
FROM: alien.c-types => int ;
IN: compiler.cfg.builder.tests
! make-input-map
{
- H{
- { 81 T{ ds-loc { n 1 } } }
- { 37 T{ ds-loc { n 2 } } }
- { 92 T{ ds-loc } }
- }
+ { { 37 D 2 } { 81 D 1 } { 92 D 0 } }
} [
T{ #shuffle { in-d { 37 81 92 } } } make-input-map
] unit-test
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
! 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
! we try not to introduce useless ##peeks here, since this reduces
! the accuracy of global stack analysis.
-
-
: make-input-map ( #shuffle -- assoc )
- [
- [ in-d>> <reversed> [ <ds-loc> swap ,, ] each-index ]
- [ in-r>> <reversed> [ <rs-loc> swap ,, ] each-index ] bi
- ] H{ } make ;
+ [ in-d>> ds-loc ] [ in-r>> rs-loc ] bi
+ [ over vregs>stack-locs zip ] 2bi@ append ;
+
+: height-changes ( #shuffle -- height-changes )
+ { [ out-d>> ] [ in-d>> ] [ out-r>> ] [ in-r>> ] } cleave
+ 4array [ length ] map first4 [ - ] 2bi@ 2array ;
-: make-output-seq ( values mapping input-map -- vregs )
- '[ _ at _ at peek-loc ] map ;
+: store-height-changes ( #shuffle -- )
+ height-changes { ds-loc rs-loc } [ new swap >>n inc-stack ] 2each ;
-: load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
- [ [ out-d>> ] 2dip make-output-seq ]
- [ [ out-r>> ] 2dip make-output-seq ] 3bi ;
+: extract-outputs ( #shuffle -- seq )
+ [ out-d>> ds-loc 2array ] [ out-r>> rs-loc 2array ] bi 2array ;
-: store-shuffle ( #shuffle ds-vregs rs-vregs -- )
- [ [ in-d>> length neg inc-d ] dip ds-store ]
- [ [ 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 ( -- )
] ;
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 -- )
'[
dup node-input-infos 2 tail-slice* first literal>> @
[ _ _ emit-vl-vector-op ]
- [ _ emit-vv-vector-op ] if
+ [ _ emit-vv-vector-op ] if
] ;
-
HELP: emit-changes
{ $description "Insert height and stack changes prior to the last instruction." } ;
-HELP: inc-d
-{ $values { "n" number } }
-{ $description "Increases or decreases the current datastacks height. 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." } ;
+HELP: inc-stack
+{ $values { "loc" loc } }
+{ $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." } ;
ARTICLE: "compiler.cfg.stacks.local" "Local stack analysis"
"Local stack analysis. We build three sets for every basic block in the CFG:"
"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"
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
-cpu.architecture namespaces kernel tools.test ;
+compiler.cfg.stacks.height compiler.cfg.stacks.local compiler.cfg.stacks.tests
+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
- 3 inc-d height-state get
+ test-init
+ 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
{
] unit-test
{ 80 } [
- initial-height-state height-state set
- H{ } clone replace-mapping set 80
- D 77 replace-loc D 77 peek-loc
+ test-init
+ 80 D 77 replace-loc D 77 peek-loc
] unit-test
{ 0 } [
] unit-test
{ D 2 } [
- { { 1 2 } { 3 4 } } D 3 translate-local-loc2
+ { { 1 2 } { 3 4 } } D 3 translate-local-loc
] unit-test
[ [ <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 ;
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
-USING: compiler.cfg.instructions compiler.cfg.stacks.local compiler.tree
-help.markup help.syntax math sequences ;
+USING: compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.stacks.local compiler.tree help.markup help.syntax math
+sequences ;
IN: compiler.cfg.stacks
HELP: ds-push
HELP: ds-drop
{ $description "Used to signal to the stack analysis that the datastacks height is decreased by one." } ;
-HELP: ds-store
-{ $values { "vregs" "a " { $link sequence } " of vregs." } }
-{ $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." } ;
-
-HELP: rs-store
-{ $values { "vregs" "a " { $link sequence } " of vregs." } }
-{ $description "Stores one or more virtual register values on the retain stack. This modifies the " { $link height-state } " dynamic variable." } ;
+HELP: store-vregs
+{ $values
+ { "vregs" "a " { $link sequence } " of vregs" }
+ { "loc-class" "either " { $link ds-loc } " or " { $link rs-loc } }
+}
+{ $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" } ;
HELP: 2inputs
{ $values { "vreg1" "a vreg" } { "vreg2" "a vreg" } }
USING: accessors arrays assocs combinators compiler.cfg.registers
-compiler.cfg.stacks.local kernel literals namespaces tools.test ;
-IN: compiler.cfg.stacks
+compiler.cfg.stacks compiler.cfg.stacks.local kernel literals namespaces
+tools.test ;
+IN: compiler.cfg.stacks.tests
-{ H{ { D -2 4 } { D -1 3 } { D -3 5 } } } [
- {
- ${ height-state initial-height-state }
- ${ replace-mapping H{ } clone }
- } [
- { 3 4 5 } ds-store replace-mapping get
- ] with-variables
+: test-init ( -- )
+ 0 vreg-counter set-global
+ initial-height-state height-state set
+ H{ } clone replace-mapping set
+ H{ } clone locs>vregs set
+ H{ } clone local-peek-set set ;
+
+{
+ 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
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 ( -- )
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 =
- [ drop f ]
- [ [ iota <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
-
-: ds-store ( vregs -- )
- [
- <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 ;
+ [ 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 ;
: 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