tools.test vectors ;
IN: compiler.cfg.stacks.vacant.tests
-! Utils
-: output-stack-map ( cfg -- map )
- vacant-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
-
-! Uninitialized peeks
-[
- V{
- T{ ##inc-d f 1 }
- T{ ##peek { dst 0 } { loc D 0 } }
- } insns>cfg
- compute-vacant-sets
-] [ vacant-peek? ] must-fail-with
-
-[
- V{
- T{ ##inc-r f 1 }
- T{ ##peek { dst 0 } { loc R 0 } }
- } insns>cfg
- compute-vacant-sets
-] [ vacant-peek? ] must-fail-with
-
-
-! Here the peek refers to a parameter of the word.
-[ ] [
- V{
- T{ ##peek { dst 0 } { loc D 0 } }
- } insns>cfg
- compute-vacant-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-vacant-sets
+ { { { } { 0 0 0 } } { { } { 0 } } }
+} [
+ { { 4 { 3 2 1 -3 0 -2 -1 } } { 0 { -1 } } } state>gc-data
] unit-test
! Replace -1, then gc. Peek is ok here because the -1 should be
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
T{ ##peek { dst 0 } { loc D -1 } }
}
- [ insns>cfg compute-vacant-sets ]
+ [ insns>cfg fill-in-gc-maps ]
[ second gc-map>> check-d>> ] bi
] 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
-
-! Should not be ok because the value wasn't initialized when gc ran.
-[
- V{
- T{ ##inc-d f 1 }
- T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
- T{ ##peek { dst 0 } { loc D 0 } }
- } insns>cfg
- compute-vacant-sets
-] [ vacant-peek? ] must-fail-with
+! ! Replace -1, then gc. Peek is ok here because the -1 should be
+! ! checked.
+! { { 0 } } [
+! V{
+! T{ ##replace { src 10 } { loc D -1 } }
+! T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
+! T{ ##peek { dst 0 } { loc D -1 } }
+! }
+! [ insns>cfg compute-vacant-sets ]
+! [ second gc-map>> check-d>> ] bi
+! ] unit-test
+
+! ! Should not be ok because the value wasn't initialized when gc ran.
+! [
+! V{
+! T{ ##inc-d f 1 }
+! T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
+! T{ ##peek { dst 0 } { loc D 0 } }
+! } insns>cfg
+! compute-vacant-sets
+! ] [ vacant-peek? ] must-fail-with
! visit-insn should set the gc info.
{ { 0 0 } { } } [
{ { 2 { } } { 0 { } } }
T{ ##alien-invoke { gc-map T{ gc-map } } }
- [ visit-insn drop ] keep gc-map>> [ scrub-d>> ] [ scrub-r>> ] bi
-] 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
-
-{
- { { { } { 0 0 0 } } { { } { 0 } } }
-} [
- { { 4 { 3 2 1 -3 0 -2 -1 } } { 0 { -1 } } } state>gc-data
+ [ gc-map>> set-gc-map ] keep gc-map>> [ scrub-d>> ] [ scrub-r>> ] bi
] 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
+! ! read-ok?
+! { t } [
+! 0 { 0 { 0 1 2 } } read-ok?
+! ] unit-test
+
+! { f } [
+! 2 { 3 { } } read-ok?
+! ] unit-test
+
+! { f } [
+! -1 { 3 { } } read-ok?
+! ] unit-test
+
+! ! { f } [
+! ! 4 { 3 { } } read-ok?
+! ! ] unit-test
+
+! { t } [
+! 4 { 0 { } } read-ok?
+! ] unit-test
+
+! { t } [
+! 4 { 1 { 0 } } read-ok?
+! ] unit-test
+
+! ! Uninitialized peeks
+! [
+! V{
+! T{ ##inc-d f 1 }
+! T{ ##peek { dst 0 } { loc D 0 } }
+! } insns>cfg
+! compute-vacant-sets
+! ] [ vacant-peek? ] must-fail-with
+
+! [
+! V{
+! T{ ##inc-r f 1 }
+! T{ ##peek { dst 0 } { loc R 0 } }
+! } insns>cfg
+! compute-vacant-sets
+! ] [ vacant-peek? ] must-fail-with
+
+! ! Here again the peek refers to a parameter word, but there are
+! ! uninitialized stack locations. That probably isn't ok.
+! [
+! V{
+! T{ ##inc-d f 3 }
+! T{ ##peek { dst 0 } { loc D 3 } }
+! } insns>cfg
+! compute-vacant-sets
+! ] [ vacant-peek? ] must-fail-with
+
+
+! ! Should not be ok because the value wasn't initialized when gc ran.
+! ! [
+! ! V{
+! ! T{ ##inc-d f 1 }
+! ! T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
+! ! T{ ##peek { dst 0 } { loc D 0 } }
+! ! } insns>cfg
+! ! compute-map-sets
+! ! ] [ vacant-peek? ] must-fail-with
-USING: accessors arrays compiler.cfg.dataflow-analysis
-compiler.cfg.instructions compiler.cfg.registers fry kernel math
-math.order sequences sets ;
+USING: accessors arrays assocs compiler.cfg.instructions
+compiler.cfg.stacks.map fry kernel math sequences ;
IN: compiler.cfg.stacks.vacant
-! Utils
+! ! Utils
: write-slots ( tuple values slots -- )
[ execute( x y -- z ) ] 2each drop ;
-! Operations on the stack info
-: register-write ( n stack -- stack' )
- first2 rot suffix members 2array ;
-
-: adjust-stack ( n stack -- stack' )
- first2 pick '[ _ + ] map [ + ] dip 2array ;
-
-: read-ok? ( n stack -- ? )
- [ first >= ] [ second in? ] 2bi or ;
-
-: stack>vacant ( stack -- seq )
- first2 [ 0 max iota ] dip diff ;
-
: vacant>bits ( vacant -- bits )
[ { } ] [
dup supremum 1 + 1 <array>
: state>gc-data ( state -- gc-data )
[ stack>scrub-and-check ] map ;
-CONSTANT: initial-state { { 0 { } } { 0 { } } }
-
-: insn>location ( insn -- n ds? )
- loc>> [ n>> ] [ ds-loc? ] bi ;
-
-: visit-replace ( state insn -- state' )
- [ first2 ] dip insn>location
- [ rot register-write swap ] [ swap register-write ] if 2array ;
-
-ERROR: vacant-peek insn ;
-
-: peek-loc-ok? ( state insn -- ? )
- insn>location 0 1 ? rot nth read-ok? ;
-
-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 visit-replace ;
-M: ##replace visit-insn visit-replace ;
-
-M: ##peek visit-insn ( state insn -- state' )
- 2dup peek-loc-ok? [ drop ] [ vacant-peek ] if ;
-
-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 ;
-
: set-gc-map ( state gc-map -- )
swap state>gc-data concat
{ >>scrub-d >>check-d >>scrub-r >>check-r } write-slots ;
-M: gc-map-insn visit-insn ( state insn -- state' )
- dupd gc-map>> set-gc-map ;
-
-M: insn visit-insn ( state insn -- state' )
- drop ;
-
-FORWARD-ANALYSIS: vacant
-
-M: vacant-analysis transfer-set ( in-set bb dfa -- out-set )
- drop instructions>> swap [ visit-insn ] reduce ;
-
-M: vacant-analysis ignore-block? ( bb dfa -- ? )
- 2drop f ;
-
-! Picking the first means that a block will only be analyzed once.
-M: vacant-analysis join-sets ( sets bb dfa -- set )
- 2drop [ initial-state ] [ first ] if-empty ;
+: fill-gc-maps ( cfg -- )
+ trace-stack-state [ drop gc-map-insn? ] assoc-filter
+ [ swap gc-map>> set-gc-map ] assoc-each ;