compiler.cfg.*: changing height-state from a 2-el array to a tuple
This way, it is a little easier to see what is going on in the local analysis phase.char-rename
Björn Lindqvist
parent
11ec120c2d
commit
c640e3b8c1
|
|
@ -22,9 +22,10 @@ IN: compiler.cfg.builder.blocks.tests
|
|||
! emit-call-block
|
||||
{
|
||||
V{ T{ ##call { word 2drop } } }
|
||||
{ { -2 -2 } { 0 0 } }
|
||||
T{ height-state f 0 0 -2 0 }
|
||||
} [
|
||||
\ 2drop -2 <basic-block> [ emit-call-block ] V{ } make height-state get
|
||||
\ 2drop -2 <basic-block> [ emit-call-block ] V{ } make
|
||||
height-state get
|
||||
] cfg-unit-test
|
||||
|
||||
! emit-trivial-block
|
||||
|
|
|
|||
|
|
@ -38,13 +38,13 @@ SLOT: out-d
|
|||
[ word>> ] [ call-height ] bi emit-trivial-call ;
|
||||
|
||||
: begin-branch ( block -- block' )
|
||||
height-state [ clone-height-state ] change (begin-basic-block) ;
|
||||
height-state [ clone ] change (begin-basic-block) ;
|
||||
|
||||
: end-branch ( block/f -- pair/f )
|
||||
dup [
|
||||
##branch,
|
||||
end-local-analysis
|
||||
height-state get clone-height-state 2array
|
||||
height-state get clone 2array
|
||||
] when* ;
|
||||
|
||||
: with-branch ( block quot: ( ..a block -- ..b block' ) -- pair/f )
|
||||
|
|
|
|||
|
|
@ -367,7 +367,7 @@ SYMBOL: foo
|
|||
|
||||
! ! #shuffle
|
||||
{
|
||||
{ { 1 1 } { 0 0 } }
|
||||
T{ height-state f 0 0 1 0 }
|
||||
H{ { D: -1 4 } { D: 0 4 } }
|
||||
} [
|
||||
4 D: 0 replace-loc
|
||||
|
|
@ -398,6 +398,11 @@ SYMBOL: foo
|
|||
<basic-block> dup set-basic-block end-word instructions>>
|
||||
] unit-test
|
||||
|
||||
! height-changes
|
||||
{ { -2 0 } } [
|
||||
T{ #shuffle { in-d { 37 81 92 } } { out-d { 20 } } } height-changes
|
||||
] unit-test
|
||||
|
||||
! make-input-map
|
||||
{
|
||||
{ { 37 D: 2 } { 81 D: 1 } { 92 D: 0 } }
|
||||
|
|
|
|||
|
|
@ -12,7 +12,29 @@ HELP: end-local-analysis
|
|||
{ $description "Called to end the local analysis of a block. The word fills in the blocks slots " { $slot "replaces" } ", " { $slot "peeks" } " and " { $slot "kills" } " with what the blocks replaces, peeks and kill locations are." } ;
|
||||
|
||||
HELP: height-state
|
||||
{ $var-description "A two-tuple used to keep track of the heights of the data and retain stacks in a " { $link basic-block } " The idea is that if the stack change instructions are tracked, then multiple changes can be folded into one. The first item is the datastacks current height and queued up height change. The second item is the same for the retain stack." } ;
|
||||
{ $description "A tuple which keeps track of the stacks heights and increments of a " { $link basic-block } " during local analysis. The idea is that if the stack change instructions are tracked, then multiple changes can be folded into one. It has the following slots:"
|
||||
{ $table
|
||||
{
|
||||
{ $slot "ds-begin" }
|
||||
"Datastack height at the beginning of the block."
|
||||
}
|
||||
{
|
||||
{ $slot "rs-begin" }
|
||||
"Retainstack height at the beginning of the block."
|
||||
}
|
||||
{
|
||||
{ $slot "ds-inc" }
|
||||
"Datastack change during the block."
|
||||
}
|
||||
{
|
||||
{ $slot "rs-inc" }
|
||||
"Retainstack change during the block."
|
||||
}
|
||||
}
|
||||
}
|
||||
{ $see-also inc-stack reset-incs } ;
|
||||
|
||||
! { $var-description "A two-tuple used to keep track of the heights of the data and retain stacks in a " { $link basic-block } " The idea is that if the stack change instructions are tracked, then multiple changes can be folded into one. The first item is the datastacks current height and queued up height change. The second item is the same for the retain stack." } ;
|
||||
|
||||
HELP: height-state>insns
|
||||
{ $values { "state" sequence } { "insns" sequence } }
|
||||
|
|
@ -21,7 +43,7 @@ HELP: height-state>insns
|
|||
"In this example the datastacks height is increased by 4 and the retainstacks decreased by 2."
|
||||
{ $example
|
||||
"USING: compiler.cfg.stacks.local prettyprint ;"
|
||||
"{ { 0 4 } { 0 -2 } } height-state>insns ."
|
||||
"T{ height-state f 0 0 4 -2 } height-state>insns ."
|
||||
"{ T{ ##inc { loc D: 4 } } T{ ##inc { loc R: -2 } } }"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -64,13 +86,13 @@ HELP: replaces
|
|||
{ $var-description "An " { $link assoc } " that maps from stack locations to virtual registers that were put on the stack during the local analysis phase. " { $link ds-push } " and similar words writes to it." }
|
||||
{ $see-also replace-loc } ;
|
||||
|
||||
HELP: translate-local-loc
|
||||
{ $values { "loc" loc } { "state" "height state" } { "loc'" loc } }
|
||||
HELP: global-loc>local
|
||||
{ $values { "loc" loc } { "height-state" height-state } { "loc'" loc } }
|
||||
{ $description "Translates an absolute stack location to one that is relative to the given height state." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: compiler.cfg.stacks.local compiler.cfg.registers namespaces prettyprint ;"
|
||||
"D: 7 { { 3 0 } { 0 0 } } translate-local-loc ."
|
||||
"D: 7 T{ height-state f 3 0 0 0 } global-loc>local ."
|
||||
"D: 4"
|
||||
}
|
||||
}
|
||||
|
|
@ -88,11 +110,11 @@ $nl
|
|||
"Words for reading the stack state:"
|
||||
{ $subsections
|
||||
peek-loc
|
||||
translate-local-loc }
|
||||
global-loc>local
|
||||
}
|
||||
"Words for writing the stack state:"
|
||||
{ $subsections
|
||||
inc-stack
|
||||
modify-height
|
||||
replace-loc
|
||||
}
|
||||
"Beginning and ending analysis:"
|
||||
|
|
|
|||
|
|
@ -85,46 +85,41 @@ IN: compiler.cfg.stacks.local.tests
|
|||
] cfg-unit-test
|
||||
|
||||
! compute-local-kill-set
|
||||
{ 0 } [
|
||||
V{ } 0 insns>block 0 0 pick record-stack-heights
|
||||
compute-local-kill-set sets:cardinality
|
||||
{ HS{ } } [
|
||||
0 0 0 0 height-state boa compute-local-kill-set
|
||||
] unit-test
|
||||
|
||||
{ HS{ R: -4 } } [
|
||||
V{ } 0 insns>block 4 4 pick record-stack-heights
|
||||
{ { 8 0 } { 3 0 } } height-state set
|
||||
compute-local-kill-set
|
||||
0 4 0 -1 height-state boa compute-local-kill-set
|
||||
] unit-test
|
||||
|
||||
{ HS{ D: -1 D: -2 } } [
|
||||
V{ } 0 insns>block [ 2 0 rot record-stack-heights ] keep
|
||||
{ { 0 0 } { 0 0 } } height-state set
|
||||
compute-local-kill-set
|
||||
] cfg-unit-test
|
||||
2 0 -2 0 height-state boa compute-local-kill-set
|
||||
] unit-test
|
||||
|
||||
! translate-local-loc
|
||||
! global-loc>local
|
||||
{ D: 2 } [
|
||||
D: 3 { { 1 2 } { 3 4 } } translate-local-loc
|
||||
D: 3 1 0 0 0 height-state boa global-loc>local
|
||||
] unit-test
|
||||
|
||||
! height-state
|
||||
{
|
||||
{ { 3 3 } { 0 0 } }
|
||||
T{ height-state f 0 0 3 0 }
|
||||
} [
|
||||
D: 3 inc-stack height-state get
|
||||
] cfg-unit-test
|
||||
|
||||
{
|
||||
{ { 5 3 } { 0 0 } }
|
||||
T{ height-state f 2 0 3 0 }
|
||||
} [
|
||||
{ { 2 0 } { 0 0 } } height-state set
|
||||
2 0 0 0 height-state boa height-state set
|
||||
D: 3 inc-stack height-state get
|
||||
] cfg-unit-test
|
||||
|
||||
{
|
||||
{ T{ ##inc { loc D: 4 } } T{ ##inc { loc R: -2 } } }
|
||||
} [
|
||||
{ { 0 4 } { 0 -2 } } height-state>insns
|
||||
0 0 4 -2 height-state boa height-state>insns
|
||||
] unit-test
|
||||
|
||||
{ H{ { D: -1 40 } } } [
|
||||
|
|
|
|||
|
|
@ -1,47 +1,46 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs compiler.cfg.instructions
|
||||
compiler.cfg.parallel-copy compiler.cfg.registers hash-sets kernel
|
||||
USING: accessors arrays assocs combinators compiler.cfg.instructions
|
||||
compiler.cfg.parallel-copy compiler.cfg.registers fry hash-sets kernel
|
||||
make math math.order namespaces sequences sets ;
|
||||
IN: compiler.cfg.stacks.local
|
||||
|
||||
: current-height ( state -- ds rs )
|
||||
first2 [ first ] bi@ ;
|
||||
TUPLE: height-state ds-begin rs-begin ds-inc rs-inc ;
|
||||
|
||||
: >loc< ( loc -- n ds? )
|
||||
[ n>> ] [ ds-loc? ] bi ;
|
||||
|
||||
: modify-height ( state loc -- )
|
||||
>loc< 0 1 ? rot nth [ + ] with map! drop ;
|
||||
: ds-height ( height-state -- n )
|
||||
[ ds-begin>> ] [ ds-inc>> ] bi + ;
|
||||
|
||||
: reset-emits ( state -- )
|
||||
[ 0 1 rot set-nth ] each ;
|
||||
: rs-height ( height-state -- n )
|
||||
[ rs-begin>> ] [ rs-inc>> ] bi + ;
|
||||
|
||||
: height-state>insns ( state -- insns )
|
||||
[ second ] map { ds-loc rs-loc } [ new swap >>n ] 2map
|
||||
: global-loc>local ( loc height-state -- loc' )
|
||||
[ clone dup >loc< ] dip swap [ ds-height ] [ rs-height ] if - >>n ;
|
||||
|
||||
: inc-stack ( loc -- )
|
||||
>loc< height-state get swap
|
||||
[ [ + ] change-ds-inc ] [ [ + ] change-rs-inc ] if drop ;
|
||||
|
||||
: height-state>insns ( height-state -- insns )
|
||||
[ ds-inc>> ds-loc ] [ rs-inc>> rs-loc ] bi [ new swap >>n ] 2bi@ 2array
|
||||
[ n>> 0 = ] reject [ ##inc new swap >>loc ] map ;
|
||||
|
||||
: translate-local-loc ( loc state -- loc' )
|
||||
[ clone ] dip over >loc< 0 1 ? rot nth first - >>n ;
|
||||
: reset-incs ( height-state -- )
|
||||
dup ds-inc>> '[ _ + ] change-ds-begin
|
||||
dup rs-inc>> '[ _ + ] change-rs-begin
|
||||
0 >>ds-inc 0 >>rs-inc drop ;
|
||||
|
||||
: clone-height-state ( state -- state' )
|
||||
[ clone ] map ;
|
||||
|
||||
: initial-height-state ( -- state )
|
||||
{ { 0 0 } { 0 0 } } clone-height-state ;
|
||||
|
||||
: kill-locations ( saved-height height -- seq )
|
||||
: kill-locations ( begin-height current-height -- seq )
|
||||
dupd [-] iota [ swap - ] with map ;
|
||||
|
||||
: local-kill-set ( ds-height rs-height state -- set )
|
||||
current-height swapd [ kill-locations ] 2bi@
|
||||
: local-kill-set ( ds-begin rs-begin ds-current rs-current -- set )
|
||||
swapd [ kill-locations ] 2bi@
|
||||
[ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
|
||||
append >hash-set ;
|
||||
|
||||
SYMBOLS: height-state locs>vregs local-peek-set replaces ;
|
||||
|
||||
: inc-stack ( loc -- )
|
||||
height-state get swap modify-height ;
|
||||
SYMBOLS: locs>vregs local-peek-set replaces ;
|
||||
|
||||
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
|
||||
: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
|
||||
|
|
@ -56,21 +55,24 @@ SYMBOLS: height-state locs>vregs local-peek-set replaces ;
|
|||
building get pop -rot changes>insns % , ;
|
||||
|
||||
: peek-loc ( loc -- vreg )
|
||||
height-state get translate-local-loc dup replaces get at
|
||||
height-state get global-loc>local
|
||||
dup replaces get at
|
||||
[ ] [ dup local-peek-set get adjoin loc>vreg ] ?if ;
|
||||
|
||||
: replace-loc ( vreg loc -- )
|
||||
height-state get translate-local-loc replaces get set-at ;
|
||||
height-state get global-loc>local
|
||||
replaces get set-at ;
|
||||
|
||||
: record-stack-heights ( ds-height rs-height bb -- )
|
||||
[ rs-height<< ] keep ds-height<< ;
|
||||
|
||||
: compute-local-kill-set ( basic-block -- set )
|
||||
[ ds-height>> ] [ rs-height>> ] bi height-state get local-kill-set ;
|
||||
: compute-local-kill-set ( height-state -- set )
|
||||
{ [ ds-begin>> ] [ rs-begin>> ] [ ds-height ] [ rs-height ] } cleave
|
||||
local-kill-set ;
|
||||
|
||||
: begin-local-analysis ( basic-block -- )
|
||||
height-state get dup reset-emits
|
||||
current-height rot record-stack-heights
|
||||
height-state get reset-incs
|
||||
height-state get [ ds-height ] [ rs-height ] bi rot record-stack-heights
|
||||
HS{ } clone local-peek-set namespaces:set
|
||||
H{ } clone replaces namespaces:set ;
|
||||
|
||||
|
|
@ -84,4 +86,4 @@ SYMBOLS: height-state locs>vregs local-peek-set replaces ;
|
|||
] unless
|
||||
keys >hash-set >>replaces
|
||||
local-peek-set get >>peeks
|
||||
dup compute-local-kill-set >>kills drop ;
|
||||
height-state get compute-local-kill-set >>kills drop ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: compiler.cfg.stacks.tests
|
|||
! store-vregs
|
||||
{
|
||||
H{ { D: 1 4 } { D: 2 3 } { D: 0 5 } }
|
||||
{ { 0 0 } { 0 0 } }
|
||||
T{ height-state f 0 0 0 0 }
|
||||
} [
|
||||
{ 3 4 5 } ds-loc store-vregs
|
||||
replaces get
|
||||
|
|
@ -29,7 +29,7 @@ IN: compiler.cfg.stacks.tests
|
|||
{
|
||||
1
|
||||
2
|
||||
{ { -2 -2 } { 0 0 } }
|
||||
T{ height-state f 0 0 -2 0 }
|
||||
} [
|
||||
2inputs height-state get
|
||||
] cfg-unit-test
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: compiler.cfg.stacks
|
|||
|
||||
: begin-stack-analysis ( -- )
|
||||
<bihash> locs>vregs set
|
||||
initial-height-state height-state set ;
|
||||
0 0 0 0 height-state boa height-state set ;
|
||||
|
||||
: end-stack-analysis ( cfg -- )
|
||||
{
|
||||
|
|
|
|||
Loading…
Reference in New Issue