421 lines
7.8 KiB
Factor
421 lines
7.8 KiB
Factor
USING: accessors alien arrays byte-arrays combinators.short-circuit
|
|
compiler.cfg compiler.cfg.comparisons compiler.cfg.gc-checks
|
|
compiler.cfg.gc-checks.private compiler.cfg.instructions
|
|
compiler.cfg.registers compiler.cfg.rpo compiler.cfg.utilities
|
|
compiler.test cpu.architecture kernel layouts math memory namespaces
|
|
sequences tools.test ;
|
|
IN: compiler.cfg.gc-checks.tests
|
|
|
|
! insert-gc-check?
|
|
{ t f } [
|
|
V{ T{ ##inc } T{ ##allot } } 0 insns>block insert-gc-check?
|
|
V{ T{ ##call } } 0 insns>block insert-gc-check?
|
|
] unit-test
|
|
|
|
! allocation-size
|
|
{ t } [
|
|
V{ T{ ##box-alien f 0 1 } } allocation-size
|
|
123 <alien> size =
|
|
] unit-test
|
|
|
|
{ t } [
|
|
V{ T{ ##box-alien } T{ ##replace } } allocation-size
|
|
5 cells data-alignment get align =
|
|
] unit-test
|
|
|
|
! add-gc-checks
|
|
{
|
|
{
|
|
V{
|
|
T{ ##inc }
|
|
T{ ##peek }
|
|
T{ ##alien-invoke }
|
|
T{ ##check-nursery-branch
|
|
{ size 64 }
|
|
{ cc cc<= }
|
|
{ temp1 1 }
|
|
{ temp2 2 }
|
|
}
|
|
}
|
|
V{
|
|
T{ ##allot
|
|
{ dst 1 }
|
|
{ size 64 }
|
|
{ class-of byte-array }
|
|
}
|
|
T{ ##add }
|
|
T{ ##branch }
|
|
}
|
|
}
|
|
} [
|
|
{
|
|
V{ T{ ##inc } T{ ##peek } T{ ##alien-invoke } }
|
|
V{
|
|
T{ ##allot
|
|
{ dst 1 }
|
|
{ size 64 }
|
|
{ class-of byte-array }
|
|
}
|
|
T{ ##add }
|
|
T{ ##branch }
|
|
}
|
|
} [ add-gc-checks ] keep
|
|
] cfg-unit-test
|
|
|
|
! gc-check-offsets
|
|
{ { } } [
|
|
V{
|
|
T{ ##inc }
|
|
T{ ##peek }
|
|
T{ ##add }
|
|
T{ ##branch }
|
|
} gc-check-offsets
|
|
] unit-test
|
|
|
|
{ { } } [
|
|
V{
|
|
T{ ##inc }
|
|
T{ ##peek }
|
|
T{ ##alien-invoke }
|
|
T{ ##add }
|
|
T{ ##branch }
|
|
} gc-check-offsets
|
|
] unit-test
|
|
|
|
{ { 0 } } [
|
|
V{
|
|
T{ ##inc }
|
|
T{ ##peek }
|
|
T{ ##allot }
|
|
T{ ##alien-invoke }
|
|
T{ ##add }
|
|
T{ ##branch }
|
|
} gc-check-offsets
|
|
] unit-test
|
|
|
|
{ { 0 } } [
|
|
V{
|
|
T{ ##inc }
|
|
T{ ##peek }
|
|
T{ ##allot }
|
|
T{ ##allot }
|
|
T{ ##add }
|
|
T{ ##branch }
|
|
} gc-check-offsets
|
|
] unit-test
|
|
|
|
{ { 0 4 } } [
|
|
V{
|
|
T{ ##inc }
|
|
T{ ##peek }
|
|
T{ ##allot }
|
|
T{ ##alien-invoke }
|
|
T{ ##allot }
|
|
T{ ##add }
|
|
T{ ##sub }
|
|
T{ ##branch }
|
|
} gc-check-offsets
|
|
] unit-test
|
|
|
|
{ { 3 } } [
|
|
V{
|
|
T{ ##inc }
|
|
T{ ##peek }
|
|
T{ ##alien-invoke }
|
|
T{ ##allot }
|
|
T{ ##add }
|
|
T{ ##branch }
|
|
} gc-check-offsets
|
|
] unit-test
|
|
|
|
{ { { "a" } } } [ { "a" } { } split-instructions ] unit-test
|
|
|
|
{ { { } { "a" } } } [ { "a" } { 0 } split-instructions ] unit-test
|
|
|
|
{ { { "a" } { } } } [ { "a" } { 1 } split-instructions ] unit-test
|
|
|
|
{ { { "a" } { "b" } } } [ { "a" "b" } { 1 } split-instructions ] unit-test
|
|
|
|
{ { { } { "a" } { "b" "c" } } } [ { "a" "b" "c" } { 0 1 } split-instructions ] unit-test
|
|
|
|
: test-gc-checks ( -- )
|
|
H{ } clone representations set
|
|
0 get block>cfg cfg set ;
|
|
|
|
V{
|
|
T{ ##inc f 3 }
|
|
T{ ##replace f 0 D: 1 }
|
|
} 0 test-bb
|
|
|
|
V{
|
|
T{ ##box-alien f 0 1 }
|
|
} 1 test-bb
|
|
|
|
0 1 edge
|
|
|
|
{ } [ test-gc-checks ] unit-test
|
|
|
|
{ t } [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
|
|
|
|
: gc-check? ( bb -- ? )
|
|
instructions>>
|
|
{
|
|
[ length 1 = ]
|
|
[ first ##check-nursery-branch? ]
|
|
} 1&& ;
|
|
|
|
: gc-call? ( bb -- ? )
|
|
instructions>>
|
|
V{
|
|
T{ ##call-gc f T{ gc-map } }
|
|
T{ ##branch }
|
|
} = ;
|
|
|
|
{ t } [ <gc-call> gc-call? ] unit-test
|
|
|
|
reset-vreg-counter
|
|
|
|
V{
|
|
T{ ##prologue }
|
|
T{ ##branch }
|
|
} 0 test-bb
|
|
|
|
V{
|
|
T{ ##peek f 2 D: 0 }
|
|
T{ ##inc { loc D: 3 } }
|
|
T{ ##branch }
|
|
} 1 test-bb
|
|
|
|
V{
|
|
T{ ##allot f 1 64 byte-array }
|
|
T{ ##branch }
|
|
} 2 test-bb
|
|
|
|
V{
|
|
T{ ##branch }
|
|
} 3 test-bb
|
|
|
|
V{
|
|
T{ ##replace f 2 D: 1 }
|
|
T{ ##branch }
|
|
} 4 test-bb
|
|
|
|
V{
|
|
T{ ##epilogue }
|
|
T{ ##return }
|
|
} 5 test-bb
|
|
|
|
0 1 edge
|
|
1 { 2 3 } edges
|
|
2 4 edge
|
|
3 4 edge
|
|
4 5 edge
|
|
|
|
{ } [ test-gc-checks ] unit-test
|
|
|
|
H{
|
|
{ 2 tagged-rep }
|
|
} representations set
|
|
|
|
{ } [ cfg get insert-gc-checks ] unit-test
|
|
|
|
{ } [ 1 get successors>> first successors>> first 2 set ] unit-test
|
|
|
|
{ 2 } [ 2 get predecessors>> length ] unit-test
|
|
|
|
{ t } [ 1 get successors>> first gc-check? ] unit-test
|
|
|
|
{ 64 } [ 1 get successors>> first instructions>> first size>> ] unit-test
|
|
|
|
{ t } [ 2 get predecessors>> first gc-check? ] unit-test
|
|
|
|
{
|
|
V{
|
|
T{ ##call-gc f T{ gc-map } }
|
|
T{ ##branch }
|
|
}
|
|
} [ 2 get predecessors>> second instructions>> ] unit-test
|
|
|
|
! Don't forget to invalidate RPO after inserting basic blocks!
|
|
{ 8 } [ cfg get reverse-post-order length ] unit-test
|
|
|
|
! Do the right thing with ##phi instructions
|
|
V{
|
|
T{ ##branch }
|
|
} 0 test-bb
|
|
|
|
V{
|
|
T{ ##load-reference f 1 "hi" }
|
|
T{ ##branch }
|
|
} 1 test-bb
|
|
|
|
V{
|
|
T{ ##load-reference f 2 "bye" }
|
|
T{ ##branch }
|
|
} 2 test-bb
|
|
|
|
V{
|
|
T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
|
|
T{ ##allot f 1 64 byte-array }
|
|
T{ ##branch }
|
|
} 3 test-bb
|
|
|
|
0 { 1 2 } edges
|
|
1 3 edge
|
|
2 3 edge
|
|
|
|
{ } [ test-gc-checks ] unit-test
|
|
|
|
H{
|
|
{ 1 tagged-rep }
|
|
{ 2 tagged-rep }
|
|
{ 3 tagged-rep }
|
|
} representations set
|
|
|
|
{ } [ cfg get insert-gc-checks ] unit-test
|
|
{ } [ 1 get successors>> first successors>> first 3 set ] unit-test
|
|
{ t } [ 2 get successors>> first instructions>> first ##phi? ] unit-test
|
|
{ 2 } [ 3 get instructions>> length ] unit-test
|
|
|
|
! GC check in a block that is its own successor
|
|
V{
|
|
T{ ##prologue }
|
|
T{ ##branch }
|
|
} 0 test-bb
|
|
|
|
V{
|
|
T{ ##allot f 1 64 byte-array }
|
|
T{ ##branch }
|
|
} 1 test-bb
|
|
|
|
V{
|
|
T{ ##epilogue }
|
|
T{ ##return }
|
|
} 2 test-bb
|
|
|
|
0 1 edge
|
|
1 { 1 2 } edges
|
|
|
|
{ } [ test-gc-checks ] unit-test
|
|
|
|
{ } [ cfg get insert-gc-checks ] unit-test
|
|
|
|
{ } [
|
|
0 get successors>> first predecessors>>
|
|
[ first 0 get assert= ]
|
|
[ second 1 get [ instructions>> ] bi@ assert= ] bi
|
|
] unit-test
|
|
|
|
{ } [
|
|
0 get successors>> first successors>>
|
|
[ first 1 get [ instructions>> ] bi@ assert= ]
|
|
[ second gc-call? t assert= ] bi
|
|
] unit-test
|
|
|
|
{ } [
|
|
2 get predecessors>> first predecessors>>
|
|
[ first gc-check? t assert= ]
|
|
[ second gc-call? t assert= ] bi
|
|
] unit-test
|
|
|
|
! Brave new world of calls in the middle of BBs
|
|
|
|
! call then allot
|
|
V{
|
|
T{ ##prologue }
|
|
T{ ##branch }
|
|
} 0 test-bb
|
|
|
|
V{
|
|
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
|
T{ ##allot f 1 64 byte-array }
|
|
T{ ##branch }
|
|
} 1 test-bb
|
|
|
|
V{
|
|
T{ ##epilogue }
|
|
T{ ##return }
|
|
} 2 test-bb
|
|
|
|
0 1 edge
|
|
1 2 edge
|
|
|
|
2 vreg-counter set-global
|
|
|
|
{ } [ test-gc-checks ] unit-test
|
|
|
|
{ } [ cfg get insert-gc-checks ] unit-test
|
|
|
|
! The GC check should come after the alien-invoke
|
|
{
|
|
V{
|
|
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
|
T{ ##check-nursery-branch f 64 cc<= 3 4 }
|
|
}
|
|
} [ 0 get successors>> first instructions>> ] unit-test
|
|
|
|
! call then allot then call then allot
|
|
V{
|
|
T{ ##prologue }
|
|
T{ ##branch }
|
|
} 0 test-bb
|
|
|
|
V{
|
|
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
|
T{ ##allot f 1 64 byte-array }
|
|
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
|
T{ ##allot f 2 64 byte-array }
|
|
T{ ##branch }
|
|
} 1 test-bb
|
|
|
|
V{
|
|
T{ ##epilogue }
|
|
T{ ##return }
|
|
} 2 test-bb
|
|
|
|
0 1 edge
|
|
1 2 edge
|
|
|
|
2 vreg-counter set-global
|
|
|
|
{ } [ test-gc-checks ] unit-test
|
|
|
|
{ } [ cfg get insert-gc-checks ] unit-test
|
|
|
|
{
|
|
V{
|
|
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
|
T{ ##check-nursery-branch f 64 cc<= 3 4 }
|
|
}
|
|
} [
|
|
0 get
|
|
successors>> first
|
|
instructions>>
|
|
] unit-test
|
|
|
|
{
|
|
V{
|
|
T{ ##allot f 1 64 byte-array }
|
|
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
|
|
T{ ##check-nursery-branch f 64 cc<= 5 6 }
|
|
}
|
|
} [
|
|
0 get
|
|
successors>> first
|
|
successors>> first
|
|
instructions>>
|
|
] unit-test
|
|
|
|
{
|
|
V{
|
|
T{ ##allot f 2 64 byte-array }
|
|
T{ ##branch }
|
|
}
|
|
} [
|
|
0 get
|
|
successors>> first
|
|
successors>> first
|
|
successors>> first
|
|
instructions>>
|
|
] unit-test
|