compiler.cfg.stacks.*: new vocab 'padding' to perform much more accurate
live analysis. it will replace the 'map' vocabdb4
Björn Lindqvist
John Benediktsson
parent
0c2559ef6e
commit
ecf3829843
|
|
@ -1,6 +1,6 @@
|
|||
USING: accessors arrays assocs combinators.short-circuit
|
||||
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
|
||||
compiler.cfg.stacks compiler.cfg.stacks.map kernel math sequences ;
|
||||
compiler.cfg.stacks compiler.cfg.stacks.padding kernel math sequences ;
|
||||
IN: compiler.cfg.stacks.clearing
|
||||
|
||||
: state>replaces ( state -- replaces )
|
||||
|
|
@ -19,6 +19,6 @@ IN: compiler.cfg.stacks.clearing
|
|||
[ [ clearing-replaces ] keep suffix ] with map V{ } concat-as ;
|
||||
|
||||
: clear-uninitialized ( cfg -- )
|
||||
[ trace-stack-state ] keep [
|
||||
[ trace-stack-state2 ] keep [
|
||||
[ visit-insns ] change-instructions drop
|
||||
] with each-basic-block ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,611 @@
|
|||
USING: accessors arrays assocs compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.stacks.padding compiler.cfg.utilities kernel sequences sorting
|
||||
vectors tools.test ;
|
||||
IN: compiler.cfg.stacks.padding.tests
|
||||
|
||||
! classify-read: vacant locations
|
||||
{ 2 2 2 } [
|
||||
{ 3 { } } 2 classify-read
|
||||
{ 0 { } } -1 classify-read
|
||||
{ 3 { } } -1 classify-read
|
||||
] unit-test
|
||||
|
||||
! classify-read: over locations
|
||||
{ 1 1 1 1 1 } [
|
||||
{ 1 { 0 } } 1 classify-read
|
||||
{ 0 { } } 0 classify-read
|
||||
{ 3 { } } 4 classify-read
|
||||
{ 0 { } } 4 classify-read
|
||||
{ 1 { 0 } } 4 classify-read
|
||||
] unit-test
|
||||
|
||||
! classify-read: initialized locations
|
||||
{ 0 0 0 } [
|
||||
{ 1 { 0 } } 0 classify-read
|
||||
{ 2 { 0 1 2 } } 0 classify-read
|
||||
{ 0 { 0 1 2 } } 0 classify-read
|
||||
] unit-test
|
||||
|
||||
! fill-stack
|
||||
{
|
||||
{ 2 { 4 5 0 1 } }
|
||||
} [
|
||||
{ 2 { 4 5 } } fill-stack
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ -1 { 3 4 } }
|
||||
} [
|
||||
{ -1 { 3 4 } } fill-stack
|
||||
] unit-test
|
||||
|
||||
! fill-vacancies
|
||||
{
|
||||
{ { 0 { } } { 2 { 0 1 } } }
|
||||
{ { 0 { } } { 2 { 0 1 } } }
|
||||
{ { 0 { -1 -2 } } { 2 { 0 1 } } }
|
||||
} [
|
||||
{ { 0 { } } { 2 { } } } fill-vacancies
|
||||
{ { 0 { } } { 2 { 0 } } } fill-vacancies
|
||||
{ { 0 { -1 -2 } } { 2 { 0 } } } fill-vacancies
|
||||
] unit-test
|
||||
|
||||
! combined-state
|
||||
{
|
||||
{ { 4 { } } { 2 { 0 1 } } }
|
||||
} [
|
||||
V{ { { 4 { } } { 2 { 0 1 } } } } combine-states
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ { 0 { } } { 0 { } } }
|
||||
} [
|
||||
V{ } combine-states
|
||||
] unit-test
|
||||
|
||||
! States can't be combined if their heights are different
|
||||
[
|
||||
V{ { { 3 { } } { 0 { } } } { { 8 { } } { 0 { } } } } combine-states
|
||||
] [ height-mismatches? ] must-fail-with
|
||||
|
||||
[
|
||||
V{ { { 4 { } } { 2 { 0 1 } } } { { 5 { 4 3 2 } } { 0 { } } } }
|
||||
combine-states
|
||||
] [ height-mismatches? ] must-fail-with
|
||||
|
||||
! stack>vacant
|
||||
{
|
||||
{ 0 1 2 }
|
||||
{ }
|
||||
{ 1 }
|
||||
} [
|
||||
{ 3 { } } stack>vacant
|
||||
{ -2 { } } stack>vacant
|
||||
{ 3 { 0 2 } } stack>vacant
|
||||
] unit-test
|
||||
|
||||
! visit-insn ##inc
|
||||
|
||||
! We assume that overinitialized locations are always dead.
|
||||
{
|
||||
{ { 0 { } } { 0 { } } }
|
||||
} [
|
||||
{ { 3 { 0 } } { 0 { } } } T{ ##inc { loc D -3 } } visit-insn
|
||||
] unit-test
|
||||
|
||||
! visit-insn ##call
|
||||
{
|
||||
{ { 3 { 0 1 2 } } { 0 { } } }
|
||||
} [
|
||||
initial-state T{ ##call { height 3 } } visit-insn
|
||||
] unit-test
|
||||
|
||||
|
||||
{
|
||||
{ { -1 { } } { 0 { } } }
|
||||
} [
|
||||
initial-state T{ ##call { height -1 } } visit-insn
|
||||
] unit-test
|
||||
|
||||
|
||||
{
|
||||
{ { 4 { 2 3 0 1 } } { 0 { } } }
|
||||
} [
|
||||
{ { 2 { 0 1 } } { 0 { } } } T{ ##call { height 2 } } visit-insn
|
||||
] unit-test
|
||||
|
||||
! This looks weird but is right.
|
||||
{
|
||||
{ { 0 { 0 1 } } { 0 { } } }
|
||||
} [
|
||||
{ { -2 { } } { 0 { } } } T{ ##call { height 2 } } visit-insn
|
||||
] unit-test
|
||||
|
||||
|
||||
! if any of the stack locations are uninitialized when ##call is
|
||||
! visisted then something is wrong. ##call might gc and the
|
||||
! uninitialized locations would cause a crash.
|
||||
[
|
||||
{ { 3 { } } { 0 { } } } T{ ##call { height 3 } } visit-insn
|
||||
] [ vacant-when-calling? ] must-fail-with
|
||||
|
||||
! ! Overinitialized locations can't be live when ##call is visited. They
|
||||
! ! could be garbage collected in the called word so they maybe wouldn't
|
||||
! ! survive.
|
||||
! [
|
||||
! { { 0 { -1 -2 } } { 0 { -1 -2 } } } T{ ##call { height 0 } } visit-insn
|
||||
! ] [ overinitialized-when-calling? ] must-fail-with
|
||||
|
||||
! This is tricky. Normally, there should be no overinitialized
|
||||
! locations before a ##call (I think). But if they are, we can at
|
||||
! least be sure they are dead after the call.
|
||||
{
|
||||
{ { 2 { 0 1 } } { 0 { } } }
|
||||
} [
|
||||
{ { 2 { 0 1 -1 } } { 0 { } } } T{ ##call { height 0 } } visit-insn
|
||||
] unit-test
|
||||
|
||||
! visit-insn ##call-gc
|
||||
|
||||
! ##call-gc ofcourse fills all uninitialized locations.
|
||||
{
|
||||
{ { 4 { 0 1 2 3 } } { 0 { } } }
|
||||
} [
|
||||
{ { 4 { } } { 0 { } } } T{ ##call-gc } visit-insn
|
||||
] unit-test
|
||||
|
||||
! visit-insn ##peek
|
||||
{
|
||||
{ { 3 { 0 } } { 0 { } } }
|
||||
} [
|
||||
{ { 3 { 0 } } { 0 { } } } T{ ##peek { dst 1 } { loc D 0 } } visit-insn
|
||||
] unit-test
|
||||
|
||||
! After a ##peek that can cause a stack underflow, it is certain that
|
||||
! all stack locations are initialized.
|
||||
{
|
||||
{ { 0 { } } { 2 { 0 1 2 } } }
|
||||
{ { 2 { 0 1 2 } } { 0 { } } }
|
||||
} [
|
||||
{ { 0 { } } { 2 { } } } T{ ##peek { dst 1 } { loc R 2 } } visit-insn
|
||||
{ { 2 { } } { 0 { } } } T{ ##peek { dst 1 } { loc D 2 } } visit-insn
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ { 2 { 0 1 } } { 2 { 0 1 2 } } }
|
||||
} [
|
||||
{ { 2 { } } { 2 { } } } T{ ##peek { dst 1 } { loc R 2 } } visit-insn
|
||||
] unit-test
|
||||
|
||||
! If the ##peek can't cause a stack underflow, then we don't have the
|
||||
! same guarantees.
|
||||
[
|
||||
{ { 3 { } } { 0 { } } } T{ ##peek { dst 1 } { loc D 0 } } visit-insn
|
||||
] [ vacant-peek? ] must-fail-with
|
||||
|
||||
: following-stack-state ( insns -- state )
|
||||
T{ ##branch } suffix insns>cfg trace-stack-state2
|
||||
>alist [ first ] sort-with last second ;
|
||||
|
||||
! trace-stack-state2
|
||||
{
|
||||
H{
|
||||
{
|
||||
0
|
||||
{ { 0 { } } { 0 { } } }
|
||||
}
|
||||
{
|
||||
1
|
||||
{ { 2 { } } { 0 { } } }
|
||||
}
|
||||
{
|
||||
2
|
||||
{ { 2 { 0 1 2 } } { 0 { } } }
|
||||
}
|
||||
}
|
||||
} [
|
||||
{
|
||||
T{ ##inc f D 2 }
|
||||
T{ ##peek f f D 2 }
|
||||
T{ ##inc f D 0 }
|
||||
} insns>cfg trace-stack-state2
|
||||
] unit-test
|
||||
|
||||
{
|
||||
H{
|
||||
{ 0 { { 0 { } } { 0 { } } } }
|
||||
{ 1 { { 0 { } } { 0 { } } } }
|
||||
{ 2 { { 0 { } } { 0 { } } } }
|
||||
}
|
||||
} [
|
||||
V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } }
|
||||
insns>cfg trace-stack-state2
|
||||
] unit-test
|
||||
|
||||
! The peek "causes" the vacant locations to become populated.
|
||||
{
|
||||
H{
|
||||
{ 0 { { 0 { } } { 0 { } } } }
|
||||
{ 1 { { 3 { } } { 0 { } } } }
|
||||
{ 2 { { 3 { 0 1 2 3 } } { 0 { } } } }
|
||||
}
|
||||
} [
|
||||
V{
|
||||
T{ ##inc f D 3 }
|
||||
T{ ##peek { loc D 3 } }
|
||||
T{ ##branch }
|
||||
}
|
||||
insns>cfg trace-stack-state2
|
||||
] unit-test
|
||||
|
||||
! Replace -1 then peek is ok.
|
||||
{
|
||||
H{
|
||||
{ 0 { { 0 { } } { 0 { } } } }
|
||||
{ 1 { { 0 { -1 } } { 0 { } } } }
|
||||
{ 2 { { 0 { -1 } } { 0 { } } } }
|
||||
}
|
||||
} [
|
||||
V{
|
||||
T{ ##replace { src 10 } { loc D -1 } }
|
||||
T{ ##peek { loc D -1 } }
|
||||
T{ ##branch }
|
||||
}
|
||||
insns>cfg trace-stack-state2
|
||||
] unit-test
|
||||
|
||||
: cfg1 ( -- cfg )
|
||||
V{
|
||||
T{ ##inc f D 1 }
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
} 0 insns>block
|
||||
V{
|
||||
T{ ##peek { dst 37 } { loc D 0 } }
|
||||
T{ ##inc f D -1 }
|
||||
} 1 insns>block
|
||||
1vector >>successors block>cfg ;
|
||||
|
||||
{
|
||||
H{
|
||||
{ 0 { { 0 { } } { 0 { } } } }
|
||||
{ 1 { { 1 { } } { 0 { } } } }
|
||||
{ 2 { { 1 { 0 } } { 0 { } } } }
|
||||
{ 3 { { 1 { 0 } } { 0 { } } } }
|
||||
}
|
||||
} [ cfg1 trace-stack-state2 ] 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 f D 2 }
|
||||
T{ ##replace { src 0 } { loc D 1 } }
|
||||
T{ ##replace { src 0 } { loc D 0 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
2 V{
|
||||
T{ ##call { word <array> } { height 0 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
3 V{
|
||||
T{ ##peek { dst 0 } { loc D 0 } }
|
||||
T{ ##peek { dst 0 } { loc D 1 } }
|
||||
T{ ##inc f D 2 }
|
||||
T{ ##replace { src 0 } { loc D 2 } }
|
||||
T{ ##replace { src 0 } { loc D 3 } }
|
||||
T{ ##replace { src 0 } { loc D 1 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
8 V{
|
||||
T{ ##peek { dst 0 } { loc D 2 } }
|
||||
T{ ##peek { dst 0 } { loc D 1 } }
|
||||
T{ ##inc f D 3 }
|
||||
T{ ##replace { src 0 } { loc D 0 } }
|
||||
T{ ##replace { src 0 } { loc D 1 } }
|
||||
T{ ##replace { src 0 } { loc D 2 } }
|
||||
T{ ##replace { src 0 } { loc D 3 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
10 V{
|
||||
T{ ##inc f D -3 }
|
||||
T{ ##peek { dst 0 } { loc D 0 } }
|
||||
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 ;
|
||||
|
||||
{
|
||||
H{
|
||||
{ 0 { { 0 { } } { 0 { } } } }
|
||||
{ 1 { { 0 { } } { 0 { } } } }
|
||||
{ 2 { { 0 { } } { 0 { } } } }
|
||||
{ 3 { { 0 { } } { 0 { } } } }
|
||||
{ 4 { { 2 { } } { 0 { } } } }
|
||||
{ 5 { { 2 { 1 } } { 0 { } } } }
|
||||
{ 6 { { 2 { 1 0 } } { 0 { } } } }
|
||||
{ 7 { { 2 { 1 0 } } { 0 { } } } }
|
||||
{ 8 { { 2 { 1 0 } } { 0 { } } } }
|
||||
{ 9 { { 2 { 1 0 } } { 0 { } } } }
|
||||
{ 10 { { 4 { 3 2 } } { 0 { } } } }
|
||||
{ 11 { { 4 { 3 2 } } { 0 { } } } }
|
||||
{ 12 { { 4 { 3 2 } } { 0 { } } } }
|
||||
{ 13 { { 4 { 3 2 1 } } { 0 { } } } }
|
||||
{ 14 { { 4 { 3 2 1 } } { 0 { } } } }
|
||||
{ 15 { { 4 { 3 2 1 } } { 0 { } } } }
|
||||
{ 16 { { 7 { 6 5 4 } } { 0 { } } } }
|
||||
{ 17 { { 7 { 6 5 4 0 } } { 0 { } } } }
|
||||
{ 18 { { 7 { 6 5 4 0 1 } } { 0 { } } } }
|
||||
{ 19 { { 7 { 6 5 4 0 1 2 } } { 0 { } } } }
|
||||
{ 20 { { 7 { 6 5 4 0 1 2 3 } } { 0 { } } } }
|
||||
{ 21 { { 4 { 3 2 1 0 } } { 0 { } } } }
|
||||
{ 22 { { 4 { 3 2 1 0 } } { 0 { } } } }
|
||||
}
|
||||
} [
|
||||
bug1021-cfg trace-stack-state2
|
||||
] unit-test
|
||||
|
||||
! Same cfg structure as the bug1289:run-test word but with
|
||||
! non-datastack instructions mostly omitted.
|
||||
: bug1289-cfg ( -- cfg )
|
||||
{
|
||||
{ 0 V{ } }
|
||||
{
|
||||
1 V{
|
||||
T{ ##inc f D 3 }
|
||||
T{ ##replace { src 0 } { loc D 2 } }
|
||||
T{ ##replace { src 0 } { loc D 0 } }
|
||||
T{ ##replace { src 0 } { loc D 1 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
2 V{
|
||||
T{ ##call { word <array> } { height -1 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
3 V{
|
||||
T{ ##peek { dst 0 } { loc D 1 } }
|
||||
T{ ##peek { dst 0 } { loc D 0 } }
|
||||
T{ ##inc f D 1 }
|
||||
T{ ##inc f R 1 }
|
||||
T{ ##replace { src 0 } { loc R 0 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
4 V{ }
|
||||
}
|
||||
{
|
||||
5 V{
|
||||
T{ ##inc f D -2 }
|
||||
T{ ##inc f R 5 }
|
||||
T{ ##replace { src 0 } { loc R 3 } }
|
||||
T{ ##replace { src 0 } { loc D 0 } }
|
||||
T{ ##replace { src 0 } { loc R 4 } }
|
||||
T{ ##replace { src 0 } { loc R 2 } }
|
||||
T{ ##replace { src 0 } { loc R 1 } }
|
||||
T{ ##replace { src 0 } { loc R 0 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
6 V{
|
||||
T{ ##call { word f } { height 0 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
7 V{
|
||||
T{ ##peek { dst 0 } { loc D 0 } }
|
||||
T{ ##peek { dst 0 } { loc R 3 } }
|
||||
T{ ##peek { dst 0 } { loc R 2 } }
|
||||
T{ ##peek { dst 0 } { loc R 1 } }
|
||||
T{ ##peek { dst 0 } { loc R 0 } }
|
||||
T{ ##peek { dst 0 } { loc R 4 } }
|
||||
T{ ##inc f D 2 }
|
||||
T{ ##inc f R -5 }
|
||||
}
|
||||
}
|
||||
{ 8 V{ } }
|
||||
{ 9 V{ } }
|
||||
{ 10 V{ } }
|
||||
{
|
||||
11 V{
|
||||
T{ ##call-gc }
|
||||
}
|
||||
}
|
||||
{
|
||||
12 V{
|
||||
T{ ##peek { dst 0 } { loc R 0 } }
|
||||
T{ ##inc f D -3 }
|
||||
T{ ##inc f D 1 }
|
||||
T{ ##inc f R -1 }
|
||||
T{ ##replace { src 0 } { loc D 0 } }
|
||||
}
|
||||
}
|
||||
{
|
||||
13 V{ }
|
||||
}
|
||||
} [ over insns>block ] assoc-map dup
|
||||
{
|
||||
{ 0 1 }
|
||||
{ 1 2 }
|
||||
{ 2 3 }
|
||||
{ 3 4 }
|
||||
{ 4 9 }
|
||||
{ 5 6 }
|
||||
{ 6 7 }
|
||||
{ 7 8 }
|
||||
{ 8 9 }
|
||||
{ 9 5 }
|
||||
{ 9 10 }
|
||||
{ 10 12 }
|
||||
{ 10 11 }
|
||||
{ 11 12 }
|
||||
{ 12 13 }
|
||||
} make-edges 0 of block>cfg ;
|
||||
|
||||
{
|
||||
H{
|
||||
{ 0 { { 0 { } } { 0 { } } } }
|
||||
{ 1 { { 3 { } } { 0 { } } } }
|
||||
{ 2 { { 3 { 2 } } { 0 { } } } }
|
||||
{ 3 { { 3 { 2 0 } } { 0 { } } } }
|
||||
{ 4 { { 3 { 2 0 1 } } { 0 { } } } }
|
||||
{ 5 { { 2 { 1 0 } } { 0 { } } } }
|
||||
{ 6 { { 2 { 1 0 } } { 0 { } } } }
|
||||
{ 7 { { 2 { 1 0 } } { 0 { } } } }
|
||||
{ 8 { { 3 { 2 1 } } { 0 { } } } }
|
||||
{ 9 { { 3 { 2 1 } } { 1 { } } } }
|
||||
{ 10 { { 3 { 2 } } { 1 { 0 } } } }
|
||||
{ 11 { { 1 { 0 } } { 1 { 0 } } } }
|
||||
{ 12 { { 1 { 0 } } { 6 { 5 } } } }
|
||||
{ 13 { { 1 { 0 } } { 6 { 5 3 } } } }
|
||||
{ 14 { { 1 { 0 } } { 6 { 5 3 } } } }
|
||||
{ 15 { { 1 { 0 } } { 6 { 5 3 4 } } } }
|
||||
{ 16 { { 1 { 0 } } { 6 { 5 3 4 2 } } } }
|
||||
{ 17 { { 1 { 0 } } { 6 { 5 3 4 2 1 } } } }
|
||||
{ 18 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } }
|
||||
{ 19 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } }
|
||||
{ 20 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } }
|
||||
{ 21 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } }
|
||||
{ 22 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } }
|
||||
{ 23 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } }
|
||||
{ 24 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } }
|
||||
{ 25 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } }
|
||||
{ 26 { { 3 { 2 } } { 6 { 5 3 4 2 1 0 } } } }
|
||||
{ 27 { { 3 { 2 } } { 1 { 0 } } } }
|
||||
{ 28 { { 3 { 2 } } { 1 { 0 } } } }
|
||||
{ 29 { { 3 { 2 } } { 1 { 0 } } } }
|
||||
{ 30 { { 0 { } } { 1 { 0 } } } }
|
||||
{ 31 { { 1 { } } { 1 { 0 } } } }
|
||||
{ 32 { { 1 { } } { 0 { } } } }
|
||||
}
|
||||
} [ bug1289-cfg trace-stack-state2 ] unit-test
|
||||
|
||||
! following-stack-state
|
||||
{
|
||||
{ { 0 { } } { 0 { } } }
|
||||
} [ V{ } following-stack-state ] unit-test
|
||||
|
||||
{
|
||||
{ { 1 { } } { 0 { } } }
|
||||
} [ V{ T{ ##inc f D 1 } } following-stack-state ] unit-test
|
||||
|
||||
{
|
||||
{ { 0 { } } { 1 { } } }
|
||||
} [ V{ T{ ##inc f R 1 } } following-stack-state ] unit-test
|
||||
|
||||
! Here the peek refers to a parameter of the word.
|
||||
{
|
||||
{ { 0 { 25 } } { 0 { } } }
|
||||
} [
|
||||
V{
|
||||
T{ ##peek { loc D 25 } }
|
||||
} following-stack-state
|
||||
] unit-test
|
||||
|
||||
! Should be ok because the value was at 0 when the gc ran.
|
||||
{
|
||||
{ { -1 { -1 } } { 0 { } } }
|
||||
} [
|
||||
V{
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
||||
T{ ##inc f D -1 }
|
||||
T{ ##peek { loc D -1 } }
|
||||
} following-stack-state
|
||||
] 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 } }
|
||||
} following-stack-state
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ { 1 { 1 0 } } { 0 { } } }
|
||||
} [
|
||||
V{
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##inc f D 1 }
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
} following-stack-state
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ { 0 { 0 } } { 0 { } } }
|
||||
} [
|
||||
V{
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##inc f D 1 }
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##inc f D -1 }
|
||||
} following-stack-state
|
||||
] unit-test
|
||||
|
||||
{
|
||||
{ { 0 { } } { 0 { } } }
|
||||
} [
|
||||
V{
|
||||
T{ ##inc f D 1 }
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##inc f D -1 }
|
||||
} following-stack-state
|
||||
] unit-test
|
||||
|
||||
! ##call clears the overinitialized slots.
|
||||
{
|
||||
{ { -1 { } } { 0 { } } }
|
||||
} [
|
||||
V{
|
||||
T{ ##replace { src 10 } { loc D 0 } }
|
||||
T{ ##inc f D -1 }
|
||||
T{ ##call { height 0 } }
|
||||
} following-stack-state
|
||||
] unit-test
|
||||
|
||||
! Should not be ok because the value wasn't initialized when gc ran.
|
||||
[
|
||||
V{
|
||||
T{ ##inc f D 1 }
|
||||
T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
|
||||
T{ ##peek { loc D 0 } }
|
||||
} following-stack-state
|
||||
] [ vacant-peek? ] must-fail-with
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##inc f D 1 }
|
||||
T{ ##peek { loc D 0 } }
|
||||
} following-stack-state
|
||||
] [ vacant-peek? ] must-fail-with
|
||||
|
||||
[
|
||||
V{
|
||||
T{ ##inc f R 1 }
|
||||
T{ ##peek { loc R 0 } }
|
||||
} following-stack-state
|
||||
] [ vacant-peek? ] must-fail-with
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
! ! (scan-c-args) run-test flip
|
||||
|
||||
|
||||
! seem good: (gamma-random-float>1)
|
||||
|
|
@ -0,0 +1,127 @@
|
|||
! Copyright (C) 2015 Björn Lindqvist.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs compiler.cfg.dataflow-analysis
|
||||
compiler.cfg.instructions compiler.cfg.linearization compiler.cfg.predecessors
|
||||
compiler.cfg.registers compiler.cfg.stacks compiler.cfg.stacks.local
|
||||
compiler.cfg.stacks.global fry grouping kernel math math.order namespaces
|
||||
sequences ;
|
||||
QUALIFIED: sets
|
||||
IN: compiler.cfg.stacks.padding
|
||||
|
||||
ERROR: overinitialized-when-calling seq ;
|
||||
ERROR: vacant-when-calling seq ;
|
||||
|
||||
: safe-iota ( n -- seq )
|
||||
0 max iota ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !! Stack
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
ERROR: height-mismatches seq ;
|
||||
|
||||
: 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 [ safe-iota ] dip sets:diff ;
|
||||
|
||||
: combine-stacks ( stacks -- stack )
|
||||
[ [ first ] map dup all-equal? [ first ] [ height-mismatches ] if ]
|
||||
[ [ second ] map refine ] bi 2array ;
|
||||
|
||||
: fill-stack ( stack -- stack' )
|
||||
first2 over safe-iota sets:union 2array ;
|
||||
|
||||
: classify-read ( stack n -- val )
|
||||
swap 2dup second member? [ 2drop 0 ] [ first >= [ 1 ] [ 2 ] if ] if ;
|
||||
|
||||
: push-items ( n stack -- stack' )
|
||||
first2 pick '[ _ + ] map pick safe-iota sets:union [ + ] dip 2array ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! !! States
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
CONSTANT: initial-state { { 0 { } } { 0 { } } }
|
||||
|
||||
: apply-stack-op ( state insn quote: ( n stack -- stack' ) -- state' )
|
||||
[ [ first2 ] dip loc>> >loc< ] dip
|
||||
[ '[ rot @ swap ] ] [ '[ swap @ ] ] bi if 2array ; inline
|
||||
|
||||
: combine-states ( states -- state )
|
||||
[ initial-state ] [ flip [ combine-stacks ] map ] if-empty ;
|
||||
|
||||
: mark-location ( state insn -- state' )
|
||||
[ register-write ] apply-stack-op ;
|
||||
|
||||
: ensure-no-vacant ( state -- )
|
||||
[ stack>vacant ] map dup { { } { } } =
|
||||
[ drop ] [ vacant-when-calling ] if ;
|
||||
|
||||
: ensure-no-overinitialized ( state -- )
|
||||
[ second [ 0 < ] filter ] map dup { { } { } } =
|
||||
[ drop ] [ overinitialized-when-calling ] if ;
|
||||
|
||||
: fill-vacancies ( state -- state' )
|
||||
[ fill-stack ] map ;
|
||||
|
||||
GENERIC: visit-insn ( state insn -- state' )
|
||||
|
||||
M: ##inc visit-insn ( state insn -- state' )
|
||||
[ adjust-stack ] apply-stack-op
|
||||
[ first2 [ 0 >= ] filter 2array ] map ;
|
||||
|
||||
M: ##replace-imm visit-insn mark-location ;
|
||||
M: ##replace visit-insn mark-location ;
|
||||
|
||||
M: ##call visit-insn ( state insn -- state' )
|
||||
over ensure-no-vacant
|
||||
height>> swap first2 [ push-items ] dip 2array
|
||||
[ first2 [ 0 >= ] filter 2array ] map ;
|
||||
|
||||
M: ##call-gc visit-insn ( state insn -- state' )
|
||||
drop dup ensure-no-overinitialized fill-vacancies ;
|
||||
|
||||
M: gc-map-insn visit-insn ( state insn -- state' )
|
||||
drop ;
|
||||
|
||||
ERROR: vacant-peek insn ;
|
||||
|
||||
: underflowable-peek? ( state peek -- ? )
|
||||
2dup loc>> >loc< swap [ 0 1 ? swap nth ] dip classify-read
|
||||
dup 2 = [ drop vacant-peek ] [ 2nip 1 = ] if ;
|
||||
|
||||
M: ##peek visit-insn ( state insn -- state )
|
||||
2dup underflowable-peek? [ [ fill-vacancies ] dip ] when mark-location ;
|
||||
|
||||
M: insn visit-insn ( state insn -- state' )
|
||||
drop ;
|
||||
|
||||
FORWARD-ANALYSIS: padding
|
||||
|
||||
SYMBOL: stack-record
|
||||
|
||||
: register-stack-state ( state insn -- )
|
||||
insn#>> stack-record get set-at ;
|
||||
|
||||
: visit-insns ( insns state -- state' )
|
||||
[ [ register-stack-state ] [ visit-insn ] 2bi ] reduce ;
|
||||
|
||||
M: padding-analysis transfer-set ( in-set bb dfa -- out-set )
|
||||
drop instructions>> swap visit-insns ;
|
||||
|
||||
M: padding-analysis ignore-block? ( bb dfa -- ? )
|
||||
2drop f ;
|
||||
|
||||
M: padding-analysis join-sets ( sets bb dfa -- set )
|
||||
2drop combine-states ;
|
||||
|
||||
: uniquely-number-instructions ( cfg -- )
|
||||
cfg>insns [ swap insn#<< ] each-index ;
|
||||
|
||||
: trace-stack-state2 ( cfg -- assoc )
|
||||
H{ } clone stack-record set
|
||||
[ uniquely-number-instructions ] [ compute-padding-sets ] bi
|
||||
stack-record get ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: compiler.cfg compiler.cfg.instructions compiler.cfg.stacks.map
|
||||
USING: compiler.cfg compiler.cfg.instructions compiler.cfg.stacks.padding
|
||||
help.markup help.syntax sequences strings ;
|
||||
IN: compiler.cfg.stacks.vacant
|
||||
|
||||
|
|
@ -19,7 +19,7 @@ HELP: fill-gc-maps
|
|||
|
||||
HELP: state>gc-data
|
||||
{ $values { "state" sequence } { "gc-data" sequence } }
|
||||
{ $description "Takes a stack state on the format given by " { $link trace-stack-state } " and emits an array containing two bit-patterns with locations on the data and retain stacks to scrub." } ;
|
||||
{ $description "Takes a stack state on the format given by " { $link trace-stack-state2 } " and emits an array containing two bit-patterns with locations on the data and retain stacks to scrub." } ;
|
||||
|
||||
HELP: vacant>bits
|
||||
{ $values
|
||||
|
|
|
|||
|
|
@ -1,26 +1,20 @@
|
|||
USING: accessors arrays assocs compiler.cfg.instructions
|
||||
compiler.cfg.linearization compiler.cfg.stacks.map fry kernel math sequences ;
|
||||
compiler.cfg.linearization compiler.cfg.stacks.padding fry kernel math
|
||||
sequences ;
|
||||
IN: compiler.cfg.stacks.vacant
|
||||
|
||||
! ! Utils
|
||||
: write-slots ( tuple values slots -- )
|
||||
[ execute( x y -- z ) ] 2each drop ;
|
||||
|
||||
: vacant>bits ( vacant -- bits )
|
||||
[ { } ] [
|
||||
dup supremum 1 + 1 <array>
|
||||
[ '[ _ 0 -rot set-nth ] each ] keep
|
||||
] if-empty ;
|
||||
|
||||
! Operations on the analysis state
|
||||
: state>gc-data ( state -- gc-data )
|
||||
[ stack>vacant vacant>bits ] map ;
|
||||
|
||||
: set-gc-map ( state gc-map -- )
|
||||
swap state>gc-data { >>scrub-d >>scrub-r } write-slots ;
|
||||
! swap state>gc-data { { } { } } append
|
||||
! { >>scrub-d >>scrub-r >>check-d >>check-r } write-slots ;
|
||||
swap state>gc-data first2 -rot >>scrub-d swap >>scrub-r drop ;
|
||||
|
||||
: fill-gc-maps ( cfg -- )
|
||||
[ trace-stack-state ] [ cfg>insns [ gc-map-insn? ] filter ] bi
|
||||
[ trace-stack-state2 ] [ cfg>insns [ gc-map-insn? ] filter ] bi
|
||||
[ [ insn#>> of ] [ gc-map>> ] bi set-gc-map ] with each ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue