basis/compiler/cfg/gc-checks/gc-checks-tests.factor

   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
   9
  10 ! insert-gc-check?
  11 { t } [
  12     V{
  13         T{ ##inc } T{ ##allot }
  14     } 0 insns>block insert-gc-check?
  15 ] unit-test
  16
  17 ! allocation-size
  18 { t } [
  19     V{ T{ ##box-alien f 0 1 } } allocation-size 123 <alien> size =
  20 ] unit-test
  21
  22 ! add-gc-checks
  23 {
  24     {
  25         V{
  26             T{ ##inc }
  27             T{ ##peek }
  28             T{ ##alien-invoke }
  29             T{ ##check-nursery-branch
  30                { size 64 }
  31                { cc cc<= }
  32                { temp1 1 }
  33                { temp2 2 }
  34             }
  35         }
  36         V{
  37             T{ ##allot
  38                { dst 1 }
  39                { size 64 }
  40                { class-of byte-array }
  41             }
  42             T{ ##add }
  43             T{ ##branch }
  44         }
  45     }
  46 } [
  47     {
  48         V{ T{ ##inc } T{ ##peek } T{ ##alien-invoke } }
  49         V{
  50             T{ ##allot
  51                { dst 1 }
  52                { size 64 }
  53                { class-of byte-array }
  54             }
  55             T{ ##add }
  56             T{ ##branch }
  57         }
  58     } [ add-gc-checks ] keep
  59 ] cfg-unit-test
  60
  61 ! gc-check-offsets
  62 [ { } ] [
  63     V{
  64         T{ ##inc }
  65         T{ ##peek }
  66         T{ ##add }
  67         T{ ##branch }
  68     } gc-check-offsets
  69 ] unit-test
  70
  71 [ { } ] [
  72     V{
  73         T{ ##inc }
  74         T{ ##peek }
  75         T{ ##alien-invoke }
  76         T{ ##add }
  77         T{ ##branch }
  78     } gc-check-offsets
  79 ] unit-test
  80
  81 [ { 0 } ] [
  82     V{
  83         T{ ##inc }
  84         T{ ##peek }
  85         T{ ##allot }
  86         T{ ##alien-invoke }
  87         T{ ##add }
  88         T{ ##branch }
  89     } gc-check-offsets
  90 ] unit-test
  91
  92 [ { 0 } ] [
  93     V{
  94         T{ ##inc }
  95         T{ ##peek }
  96         T{ ##allot }
  97         T{ ##allot }
  98         T{ ##add }
  99         T{ ##branch }
 100     } gc-check-offsets
 101 ] unit-test
 102
 103 [ { 0 4 } ] [
 104     V{
 105         T{ ##inc }
 106         T{ ##peek }
 107         T{ ##allot }
 108         T{ ##alien-invoke }
 109         T{ ##allot }
 110         T{ ##add }
 111         T{ ##sub }
 112         T{ ##branch }
 113     } gc-check-offsets
 114 ] unit-test
 115
 116 [ { 3 } ] [
 117     V{
 118         T{ ##inc }
 119         T{ ##peek }
 120         T{ ##alien-invoke }
 121         T{ ##allot }
 122         T{ ##add }
 123         T{ ##branch }
 124     } gc-check-offsets
 125 ] unit-test
 126
 127 [ { { "a" } } ] [ { "a" } { } split-instructions ] unit-test
 128
 129 [ { { } { "a" } } ] [ { "a" } { 0 } split-instructions ] unit-test
 130
 131 [ { { "a" } { } } ] [ { "a" } { 1 } split-instructions ] unit-test
 132
 133 [ { { "a" } { "b" } } ] [ { "a" "b" } { 1 } split-instructions ] unit-test
 134
 135 [ { { } { "a" } { "b" "c" } } ] [ { "a" "b" "c" } { 0 1 } split-instructions ] unit-test
 136
 137 : test-gc-checks ( -- )
 138     H{ } clone representations set
 139     0 get block>cfg cfg set ;
 140
 141 V{
 142     T{ ##inc f 3 }
 143     T{ ##replace f 0 D 1 }
 144 } 0 test-bb
 145
 146 V{
 147     T{ ##box-alien f 0 1 }
 148 } 1 test-bb
 149
 150 0 1 edge
 151
 152 [ ] [ test-gc-checks ] unit-test
 153
 154 [ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
 155
 156 : gc-check? ( bb -- ? )
 157     instructions>>
 158     {
 159         [ length 1 = ]
 160         [ first ##check-nursery-branch? ]
 161     } 1&& ;
 162
 163 : gc-call? ( bb -- ? )
 164     instructions>>
 165     V{
 166         T{ ##call-gc f T{ gc-map } }
 167         T{ ##branch }
 168     } = ;
 169
 170 [ t ] [ <gc-call> gc-call? ] unit-test
 171
 172 reset-vreg-counter
 173
 174 V{
 175     T{ ##prologue }
 176     T{ ##branch }
 177 } 0 test-bb
 178
 179 V{
 180     T{ ##peek f 2 D 0 }
 181     T{ ##inc { loc D 3 } }
 182     T{ ##branch }
 183 } 1 test-bb
 184
 185 V{
 186     T{ ##allot f 1 64 byte-array }
 187     T{ ##branch }
 188 } 2 test-bb
 189
 190 V{
 191     T{ ##branch }
 192 } 3 test-bb
 193
 194 V{
 195     T{ ##replace f 2 D 1 }
 196     T{ ##branch }
 197 } 4 test-bb
 198
 199 V{
 200     T{ ##epilogue }
 201     T{ ##return }
 202 } 5 test-bb
 203
 204 0 1 edge
 205 1 { 2 3 } edges
 206 2 4 edge
 207 3 4 edge
 208 4 5 edge
 209
 210 [ ] [ test-gc-checks ] unit-test
 211
 212 H{
 213     { 2 tagged-rep }
 214 } representations set
 215
 216 [ ] [ cfg get insert-gc-checks ] unit-test
 217
 218 [ ] [ 1 get successors>> first successors>> first 2 set ] unit-test
 219
 220 [ 2 ] [ 2 get predecessors>> length ] unit-test
 221
 222 [ t ] [ 1 get successors>> first gc-check? ] unit-test
 223
 224 [ 64 ] [ 1 get successors>> first instructions>> first size>> ] unit-test
 225
 226 [ t ] [ 2 get predecessors>> first gc-check? ] unit-test
 227
 228 [
 229     V{
 230         T{ ##call-gc f T{ gc-map } }
 231         T{ ##branch }
 232     }
 233 ] [ 2 get predecessors>> second instructions>> ] unit-test
 234
 235 ! Don't forget to invalidate RPO after inserting basic blocks!
 236 [ 8 ] [ cfg get reverse-post-order length ] unit-test
 237
 238 ! Do the right thing with ##phi instructions
 239 V{
 240     T{ ##branch }
 241 } 0 test-bb
 242
 243 V{
 244     T{ ##load-reference f 1 "hi" }
 245     T{ ##branch }
 246 } 1 test-bb
 247
 248 V{
 249     T{ ##load-reference f 2 "bye" }
 250     T{ ##branch }
 251 } 2 test-bb
 252
 253 V{
 254     T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
 255     T{ ##allot f 1 64 byte-array }
 256     T{ ##branch }
 257 } 3 test-bb
 258
 259 0 { 1 2 } edges
 260 1 3 edge
 261 2 3 edge
 262
 263 [ ] [ test-gc-checks ] unit-test
 264
 265 H{
 266     { 1 tagged-rep }
 267     { 2 tagged-rep }
 268     { 3 tagged-rep }
 269 } representations set
 270
 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
 275
 276 ! GC check in a block that is its own successor
 277 V{
 278     T{ ##prologue }
 279     T{ ##branch }
 280 } 0 test-bb
 281
 282 V{
 283     T{ ##allot f 1 64 byte-array }
 284     T{ ##branch }
 285 } 1 test-bb
 286
 287 V{
 288     T{ ##epilogue }
 289     T{ ##return }
 290 } 2 test-bb
 291
 292 0 1 edge
 293 1 { 1 2 } edges
 294
 295 [ ] [ test-gc-checks ] unit-test
 296
 297 [ ] [ cfg get insert-gc-checks ] unit-test
 298
 299 [ ] [
 300     0 get successors>> first predecessors>>
 301     [ first 0 get assert= ]
 302     [ second 1 get [ instructions>> ] bi@ assert= ] bi
 303 ] unit-test
 304
 305 [ ] [
 306     0 get successors>> first successors>>
 307     [ first 1 get [ instructions>> ] bi@ assert= ]
 308     [ second gc-call? t assert= ] bi
 309 ] unit-test
 310
 311 [ ] [
 312     2 get predecessors>> first predecessors>>
 313     [ first gc-check? t assert= ]
 314     [ second gc-call? t assert= ] bi
 315 ] unit-test
 316
 317 ! Brave new world of calls in the middle of BBs
 318
 319 ! call then allot
 320 V{
 321     T{ ##prologue }
 322     T{ ##branch }
 323 } 0 test-bb
 324
 325 V{
 326     T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
 327     T{ ##allot f 1 64 byte-array }
 328     T{ ##branch }
 329 } 1 test-bb
 330
 331 V{
 332     T{ ##epilogue }
 333     T{ ##return }
 334 } 2 test-bb
 335
 336 0 1 edge
 337 1 2 edge
 338
 339 2 vreg-counter set-global
 340
 341 [ ] [ test-gc-checks ] unit-test
 342
 343 [ ] [ cfg get insert-gc-checks ] unit-test
 344
 345 ! The GC check should come after the alien-invoke
 346 [
 347     V{
 348         T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
 349         T{ ##check-nursery-branch f 64 cc<= 3 4 }
 350     }
 351 ] [ 0 get successors>> first instructions>> ] unit-test
 352
 353 ! call then allot then call then allot
 354 V{
 355     T{ ##prologue }
 356     T{ ##branch }
 357 } 0 test-bb
 358
 359 V{
 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 }
 364     T{ ##branch }
 365 } 1 test-bb
 366
 367 V{
 368     T{ ##epilogue }
 369     T{ ##return }
 370 } 2 test-bb
 371
 372 0 1 edge
 373 1 2 edge
 374
 375 2 vreg-counter set-global
 376
 377 [ ] [ test-gc-checks ] unit-test
 378
 379 [ ] [ cfg get insert-gc-checks ] unit-test
 380
 381 [
 382     V{
 383         T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
 384         T{ ##check-nursery-branch f 64 cc<= 3 4 }
 385     }
 386 ] [
 387     0 get
 388     successors>> first
 389     instructions>>
 390 ] unit-test
 391
 392 [
 393     V{
 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 }
 397     }
 398 ] [
 399     0 get
 400     successors>> first
 401     successors>> first
 402     instructions>>
 403 ] unit-test
 404
 405 [
 406     V{
 407         T{ ##allot f 2 64 byte-array }
 408         T{ ##branch }
 409     }
 410 ] [
 411     0 get
 412     successors>> first
 413     successors>> first
 414     successors>> first
 415     instructions>>
 416 ] unit-test