compiler.cfg.stacks.map: new vocab for creating an assoc that contains the stack state for each instruction in a cfg
Björn Lindqvist
Doug Coleman
parent
163fef12f9
commit
fd06e22e9a
|
|
@ -0,0 +1,233 @@
|
|||
USING: accessors arrays assocs compiler.cfg
|
||||
compiler.cfg.dataflow-analysis.private compiler.cfg.instructions
|
||||
compiler.cfg.linearization compiler.cfg.registers
|
||||
compiler.cfg.utilities compiler.cfg.stacks.map kernel math namespaces
|
||||
sequences sorting tools.test vectors ;
|
||||
IN: compiler.cfg.stacks.map.tests
|
||||
|
||||
! Utils
|
||||
: output-stack-map ( cfg -- map )
|
||||
H{ } clone stack-record set
|
||||
map-analysis run-dataflow-analysis
|
||||
nip [ [ number>> ] dip ] assoc-map >alist natural-sort last second ;
|
||||
|
||||
! Initially both the d and r stacks are empty.
|
||||
{
|
||||
{ { 0 { } } { 0 { } } }
|
||||
} [ V{ } insns>cfg output-stack-map ] unit-test
|
||||
|
||||
! Raise d stack.
|
||||
{
|
||||
{ { 1 { } } { 0 { } } }
|
||||
} [ V{ T{ ##inc-d f 1 } } insns>cfg output-stack-map ] unit-test
|
||||
|
||||
! Raise r stack.
|
||||
{
|
||||
{ { 0 { } } { 1 { } } }
|
||||
} [ V{ T{ ##inc-r f 1 } } insns>cfg output-stack-map ] unit-test
|
||||
|
||||
{
|
||||
H{
|
||||
{
|
||||
T{ ##inc-d { n 2 } }
|
||||
{ { 0 { } } { 0 { } } }
|
||||
}
|
||||
{
|
||||
T{ ##peek { loc D 2 } }
|
||||
{ { 2 { } } { 0 { } } }
|
||||
}
|
||||
{
|
||||
T{ ##inc-d { n 0 } }
|
||||
{ { 2 { 0 1 2 } } { 0 { } } }
|
||||
}
|
||||
|
||||
}
|
||||
} [
|
||||
{
|
||||
T{ ##inc-d f 2 }
|
||||
T{ ##peek f f D 2 }
|
||||
T{ ##inc-d f 0 }
|
||||
} insns>cfg trace-stack-state
|
||||
] unit-test
|
||||
|
||||
! Here the peek refers to a parameter of the word.
|
||||
[ ] [
|
||||
V{
|
||||
T{ ##peek { dst 0 } { loc D 25 } }
|
||||
} insns>cfg
|
||||
compute-map-sets
|
||||
] unit-test
|
||||
|
||||
! Replace -1 then peek is ok.
|
||||
[ ] [
|
||||
V{
|
||||
T{ ##replace { src 10 } { loc D -1 } }
|
||||
T{ ##peek { dst 0 } { loc D -1 } }
|
||||
} insns>cfg
|
||||
compute-map-sets
|
||||
] unit-test
|
||||
|
||||
! Should be ok because the value was at 0 when the gc ran.
|
||||
{ { -1 { -1 } } } [
|
||||
V{
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##peek { dst 0 } { loc D -1 } }
|
||||
} insns>cfg output-stack-map first
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ { 0 { } } { 0 { } } }
|
||||
} [
|
||||
V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } }
|
||||
insns>cfg output-stack-map
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ { 0 { 0 1 2 } } { 0 { } } }
|
||||
} [
|
||||
V{
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##replace { src 10 } { loc D 1 } }
|
||||
T{ ##replace { src 10 } { loc D 2 } }
|
||||
} insns>cfg output-stack-map
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ { 1 { 1 0 } } { 0 { } } }
|
||||
} [
|
||||
V{
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
} insns>cfg output-stack-map
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ 0 { 0 -1 } }
|
||||
} [
|
||||
V{
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##inc-d f -1 }
|
||||
} insns>cfg output-stack-map first
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ 0 { -1 } }
|
||||
} [
|
||||
V{
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##inc-d f -1 }
|
||||
} insns>cfg output-stack-map first
|
||||
] unit-test
|
||||
|
||||
! ##call clears the overinitialized slots.
|
||||
{
|
||||
{ -1 { } }
|
||||
} [
|
||||
V{
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##inc-d f -1 }
|
||||
T{ ##call }
|
||||
} insns>cfg output-stack-map first
|
||||
] unit-test
|
||||
|
||||
: cfg1 ( -- cfg )
|
||||
V{
|
||||
T{ ##inc-d f 1 }
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
} 0 insns>block
|
||||
V{
|
||||
T{ ##peek { dst 37 } { loc D 0 } }
|
||||
T{ ##inc-d f -1 }
|
||||
} 1 insns>block
|
||||
1vector >>successors block>cfg ;
|
||||
|
||||
{ { 0 { -1 } } } [ cfg1 output-stack-map first ] unit-test
|
||||
|
||||
! Same cfg structure as the bug1021:run-test word but with
|
||||
! non-datastack instructions mostly omitted.
|
||||
: bug1021-cfg ( -- cfg )
|
||||
{
|
||||
{ 0 V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } } }
|
||||
{
|
||||
1 V{
|
||||
T{ ##inc-d f 2 }
|
||||
T{ ##replace { src 0 } { loc D 1 } }
|
||||
T{ ##replace { src 0 } { loc D 0 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
2 V{
|
||||
T{ ##call { word <array> } }
|
||||
}
|
||||
}
|
||||
{
|
||||
3 V{
|
||||
T{ ##inc-d f 2 }
|
||||
T{ ##peek { dst 0 } { loc D 2 } }
|
||||
T{ ##peek { dst 0 } { loc D 3 } }
|
||||
T{ ##replace { src 0 } { loc D 2 } }
|
||||
T{ ##replace { src 0 } { loc D 3 } }
|
||||
T{ ##replace { src 0 } { loc D 1 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
8 V{
|
||||
T{ ##inc-d f 3 }
|
||||
T{ ##peek { dst 0 } { loc D 5 } }
|
||||
T{ ##replace { src 0 } { loc D 0 } }
|
||||
T{ ##replace { src 0 } { loc D 3 } }
|
||||
T{ ##peek { dst 0 } { loc D 4 } }
|
||||
T{ ##replace { src 0 } { loc D 1 } }
|
||||
T{ ##replace { src 0 } { loc D 2 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
10 V{
|
||||
T{ ##inc-d f -3 }
|
||||
T{ ##peek { dst 0 } { loc D -3 } }
|
||||
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
||||
}
|
||||
}
|
||||
} [ over insns>block ] assoc-map dup
|
||||
{ { 0 1 } { 1 2 } { 2 3 } { 3 8 } { 8 10 } } make-edges 0 of block>cfg ;
|
||||
|
||||
{ { 4 { 3 2 1 -3 0 -2 -1 } } } [
|
||||
bug1021-cfg output-stack-map first
|
||||
] unit-test
|
||||
|
||||
|
||||
! After a ##peek that can cause a stack underflow, it is certain that
|
||||
! all stack locations are initialized.
|
||||
{
|
||||
{ { 2 { 0 1 2 } } { 0 { } } }
|
||||
} [
|
||||
{ { 2 { } } { 0 { } } } T{ ##peek f f D 2 } visit-insn
|
||||
] unit-test
|
||||
|
||||
! If the ##peek can't cause a stack underflow, then we don't have the
|
||||
! same guarantees.
|
||||
{
|
||||
{ { 2 { 0 } } { 0 { } } }
|
||||
} [
|
||||
{ { 2 { } } { 0 { } } } T{ ##peek f f D 0 } visit-insn
|
||||
] unit-test
|
||||
|
||||
{ t f t } [
|
||||
{ { 0 { } } { 0 { } } } T{ ##peek { loc D 0 } } dangerous-peek?
|
||||
{ { 0 { } } { 0 { } } } T{ ##peek { loc D -1 } } dangerous-peek?
|
||||
{ { 2 { 0 1 2 } } { 0 { } } } T{ ##peek { loc D 2 } } dangerous-peek?
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ { 0 { } } { 2 { 0 1 } } }
|
||||
{ { 0 { } } { 2 { 0 1 } } }
|
||||
} [
|
||||
{ { 0 { } } { 2 { } } } fill-vacancies
|
||||
{ { 0 { } } { 2 { 0 } } } fill-vacancies
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
USING: accessors arrays assocs compiler.cfg.dataflow-analysis
|
||||
compiler.cfg.instructions compiler.cfg.registers fry kernel math math.order
|
||||
namespaces sequences ;
|
||||
QUALIFIED: sets
|
||||
IN: compiler.cfg.stacks.map
|
||||
|
||||
! Operations on the stack info
|
||||
: register-write ( n stack -- stack' )
|
||||
first2 rot suffix sets:members 2array ;
|
||||
|
||||
: adjust-stack ( n stack -- stack' )
|
||||
first2 pick '[ _ + ] map [ + ] dip 2array ;
|
||||
|
||||
: stack>vacant ( stack -- seq )
|
||||
first2 [ 0 max iota ] dip sets:diff ;
|
||||
|
||||
CONSTANT: initial-state { { 0 { } } { 0 { } } }
|
||||
|
||||
: insn>location ( insn -- n ds? )
|
||||
loc>> [ n>> ] [ ds-loc? ] bi ;
|
||||
|
||||
: mark-location ( state insn -- state' )
|
||||
[ first2 ] dip insn>location
|
||||
[ rot register-write swap ] [ swap register-write ] if 2array ;
|
||||
|
||||
: state>vacancies ( state -- vacants )
|
||||
[ stack>vacant ] map ;
|
||||
|
||||
: fill-vacancies ( state -- state' )
|
||||
dup state>vacancies [ [ first2 ] dip append 2array ] 2map ;
|
||||
|
||||
GENERIC: visit-insn ( state insn -- state' )
|
||||
|
||||
M: ##inc-d visit-insn ( state insn -- state' )
|
||||
n>> swap first2 [ adjust-stack ] dip 2array ;
|
||||
|
||||
M: ##inc-r visit-insn ( state insn -- state' )
|
||||
n>> swap first2 swapd adjust-stack 2array ;
|
||||
|
||||
M: ##replace-imm visit-insn mark-location ;
|
||||
M: ##replace visit-insn mark-location ;
|
||||
|
||||
M: ##call visit-insn ( state insn -- state' )
|
||||
! After a word call, we can't trust any overinitialized locations
|
||||
! to contain valid pointers anymore.
|
||||
drop [ first2 [ 0 >= ] filter 2array ] map ;
|
||||
|
||||
: dangerous-peek? ( state peek -- ? )
|
||||
loc>> [ ds-loc? 0 1 ? swap nth first ] keep n>> <= ;
|
||||
|
||||
M: ##peek visit-insn ( state insn -- state' )
|
||||
2dup dangerous-peek? [ [ fill-vacancies ] dip ] when mark-location ;
|
||||
|
||||
M: insn visit-insn ( state insn -- state' )
|
||||
drop ;
|
||||
|
||||
FORWARD-ANALYSIS: map
|
||||
|
||||
SYMBOL: stack-record
|
||||
|
||||
M: map-analysis transfer-set ( in-set bb dfa -- out-set )
|
||||
drop instructions>> swap [
|
||||
[ stack-record get set-at ] [ visit-insn ] 2bi
|
||||
] reduce ;
|
||||
|
||||
M: map-analysis ignore-block? ( bb dfa -- ? )
|
||||
2drop f ;
|
||||
|
||||
! Picking the first means that a block will only be analyzed once.
|
||||
M: map-analysis join-sets ( sets bb dfa -- set )
|
||||
2drop [ initial-state ] [ first ] if-empty ;
|
||||
|
||||
: trace-stack-state ( cfg -- assoc )
|
||||
H{ } clone stack-record set compute-map-sets stack-record get ;
|
||||
Loading…
Reference in New Issue