1 USING: arrays byte-arrays compiler.cfg.gc-checks
2 compiler.cfg.gc-checks.private compiler.cfg.debugger
3 compiler.cfg.registers compiler.cfg.instructions compiler.cfg
4 compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
5 tools.test kernel vectors namespaces accessors sequences alien
6 memory classes make combinators.short-circuit
7 compiler.cfg.comparisons compiler.test compiler.cfg.utilities ;
8 IN: compiler.cfg.gc-checks.tests
13 T{ ##inc } T{ ##allot }
14 } 0 insns>block insert-gc-check?
19 V{ T{ ##box-alien f 0 1 } } allocation-size 123 <alien> size =
29 T{ ##check-nursery-branch
40 { class-of byte-array }
48 V{ T{ ##inc } T{ ##peek } T{ ##alien-invoke } }
53 { class-of byte-array }
58 } [ add-gc-checks ] keep
127 { { { "a" } } } [ { "a" } { } split-instructions ] unit-test
129 { { { } { "a" } } } [ { "a" } { 0 } split-instructions ] unit-test
131 { { { "a" } { } } } [ { "a" } { 1 } split-instructions ] unit-test
133 { { { "a" } { "b" } } } [ { "a" "b" } { 1 } split-instructions ] unit-test
135 { { { } { "a" } { "b" "c" } } } [ { "a" "b" "c" } { 0 1 } split-instructions ] unit-test
137 : test-gc-checks ( -- )
138 H{ } clone representations set
139 0 get block>cfg cfg set ;
143 T{ ##replace f 0 D 1 }
147 T{ ##box-alien f 0 1 }
152 { } [ test-gc-checks ] unit-test
154 { t } [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
156 : gc-check? ( bb -- ? )
160 [ first ##check-nursery-branch? ]
163 : gc-call? ( bb -- ? )
166 T{ ##call-gc f T{ gc-map } }
170 { t } [ <gc-call> gc-call? ] unit-test
181 T{ ##inc { loc D 3 } }
186 T{ ##allot f 1 64 byte-array }
195 T{ ##replace f 2 D 1 }
210 { } [ test-gc-checks ] unit-test
214 } representations set
216 { } [ cfg get insert-gc-checks ] unit-test
218 { } [ 1 get successors>> first successors>> first 2 set ] unit-test
220 { 2 } [ 2 get predecessors>> length ] unit-test
222 { t } [ 1 get successors>> first gc-check? ] unit-test
224 { 64 } [ 1 get successors>> first instructions>> first size>> ] unit-test
226 { t } [ 2 get predecessors>> first gc-check? ] unit-test
230 T{ ##call-gc f T{ gc-map } }
233 } [ 2 get predecessors>> second instructions>> ] unit-test
235 ! Don't forget to invalidate RPO after inserting basic blocks!
236 { 8 } [ cfg get reverse-post-order length ] unit-test
238 ! Do the right thing with ##phi instructions
244 T{ ##load-reference f 1 "hi" }
249 T{ ##load-reference f 2 "bye" }
254 T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
255 T{ ##allot f 1 64 byte-array }
263 { } [ test-gc-checks ] unit-test
269 } representations set
271 { } [ cfg get insert-gc-checks ] unit-test
272 { } [ 1 get successors>> first successors>> first 3 set ] unit-test
273 { t } [ 2 get successors>> first instructions>> first ##phi? ] unit-test
274 { 2 } [ 3 get instructions>> length ] unit-test
276 ! GC check in a block that is its own successor
283 T{ ##allot f 1 64 byte-array }
295 { } [ test-gc-checks ] unit-test
297 { } [ cfg get insert-gc-checks ] unit-test
300 0 get successors>> first predecessors>>
301 [ first 0 get assert= ]
302 [ second 1 get [ instructions>> ] bi@ assert= ] bi
306 0 get successors>> first successors>>
307 [ first 1 get [ instructions>> ] bi@ assert= ]
308 [ second gc-call? t assert= ] bi
312 2 get predecessors>> first predecessors>>
313 [ first gc-check? t assert= ]
314 [ second gc-call? t assert= ] bi
317 ! Brave new world of calls in the middle of BBs
326 T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
327 T{ ##allot f 1 64 byte-array }
339 2 vreg-counter set-global
341 { } [ test-gc-checks ] unit-test
343 { } [ cfg get insert-gc-checks ] unit-test
345 ! The GC check should come after the alien-invoke
348 T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
349 T{ ##check-nursery-branch f 64 cc<= 3 4 }
351 } [ 0 get successors>> first instructions>> ] unit-test
353 ! call then allot then call then allot
360 T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
361 T{ ##allot f 1 64 byte-array }
362 T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
363 T{ ##allot f 2 64 byte-array }
375 2 vreg-counter set-global
377 { } [ test-gc-checks ] unit-test
379 { } [ cfg get insert-gc-checks ] unit-test
383 T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
384 T{ ##check-nursery-branch f 64 cc<= 3 4 }
394 T{ ##allot f 1 64 byte-array }
395 T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
396 T{ ##check-nursery-branch f 64 cc<= 5 6 }
407 T{ ##allot f 2 64 byte-array }