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

   1 USING: 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 byte-arrays ;
   7 IN: compiler.cfg.gc-checks.tests
   8
   9 : test-gc-checks ( -- )
  10     H{ } clone representations set
  11     cfg new 0 get >>entry cfg set ;
  12
  13 V{
  14     T{ ##inc-d f 3 }
  15     T{ ##replace f 0 D 1 }
  16 } 0 test-bb
  17
  18 V{
  19     T{ ##box-alien f 0 1 }
  20 } 1 test-bb
  21
  22 0 1 edge
  23
  24 [ ] [ test-gc-checks ] unit-test
  25
  26 [ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
  27
  28 [ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
  29
  30 2 \ vreg-counter set-global
  31
  32 : gc-check? ( bb -- ? )
  33     instructions>>
  34     {
  35         [ length 1 = ]
  36         [ first ##check-nursery-branch? ]
  37     } 1&& ;
  38
  39 [ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
  40
  41 4 \ vreg-counter set-global
  42
  43 [
  44     V{
  45         T{ ##gc-map f V{ 0 } V{ 3 } { 0 1 2 } }
  46         T{ ##call-gc }
  47         T{ ##branch }
  48     }
  49 ]
  50 [
  51     V{ D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
  52 ] unit-test
  53
  54 30 \ vreg-counter set-global
  55
  56 V{
  57     T{ ##branch }
  58 } 0 test-bb
  59
  60 V{
  61     T{ ##branch }
  62 } 1 test-bb
  63
  64 V{
  65     T{ ##branch }
  66 } 2 test-bb
  67
  68 V{
  69     T{ ##branch }
  70 } 3 test-bb
  71
  72 V{
  73     T{ ##branch }
  74 } 4 test-bb
  75
  76 0 { 1 2 } edges
  77 1 3 edge
  78 2 3 edge
  79 3 4 edge
  80
  81 [ ] [ test-gc-checks ] unit-test
  82
  83 [ ] [ cfg get needs-predecessors drop ] unit-test
  84
  85 [ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test
  86
  87 [ t ] [ 1 get successors>> first gc-check? ] unit-test
  88
  89 [ t ] [ 2 get successors>> first gc-check? ] unit-test
  90
  91 [ t ] [ 3 get predecessors>> first gc-check? ] unit-test
  92
  93 30 \ vreg-counter set-global
  94
  95 V{
  96     T{ ##prologue }
  97     T{ ##branch }
  98 } 0 test-bb
  99
 100 V{
 101     T{ ##peek f 2 D 0 }
 102     T{ ##inc-d f 3 }
 103     T{ ##branch }
 104 } 1 test-bb
 105
 106 V{
 107     T{ ##allot f 1 64 byte-array }
 108     T{ ##branch }
 109 } 2 test-bb
 110
 111 V{
 112     T{ ##branch }
 113 } 3 test-bb
 114
 115 V{
 116     T{ ##replace f 2 D 1 }
 117     T{ ##branch }
 118 } 4 test-bb
 119
 120 V{
 121     T{ ##epilogue }
 122     T{ ##return }
 123 } 5 test-bb
 124
 125 0 1 edge
 126 1 { 2 3 } edges
 127 2 4 edge
 128 3 4 edge
 129 4 5 edge
 130
 131 [ ] [ test-gc-checks ] unit-test
 132
 133 H{
 134     { 2 tagged-rep }
 135 } representations set
 136
 137 [ ] [ cfg get insert-gc-checks drop ] unit-test
 138
 139 [ 2 ] [ 2 get predecessors>> length ] unit-test
 140
 141 [ t ] [ 1 get successors>> first gc-check? ] unit-test
 142
 143 [ 64 ] [ 1 get successors>> first instructions>> first size>> ] unit-test
 144
 145 [ t ] [ 2 get predecessors>> first gc-check? ] unit-test
 146
 147 [
 148     V{
 149         T{ ##gc-map f V{ 0 1 2 } V{ } { 2 } }
 150         T{ ##call-gc }
 151         T{ ##branch }
 152     }
 153 ] [ 2 get predecessors>> second instructions>> ] unit-test
 154
 155 ! Don't forget to invalidate RPO after inserting basic blocks!
 156 [ 8 ] [ cfg get reverse-post-order length ] unit-test
 157
 158 ! Do the right thing with ##phi instructions
 159 V{
 160     T{ ##branch }
 161 } 0 test-bb
 162
 163 V{
 164     T{ ##load-reference f 1 "hi" }
 165     T{ ##branch }
 166 } 1 test-bb
 167
 168 V{
 169     T{ ##load-reference f 2 "bye" }
 170     T{ ##branch }
 171 } 2 test-bb
 172
 173 V{
 174     T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
 175     T{ ##allot f 1 64 byte-array }
 176     T{ ##branch }
 177 } 3 test-bb
 178
 179 0 { 1 2 } edges
 180 1 3 edge
 181 2 3 edge
 182
 183 [ ] [ test-gc-checks ] unit-test
 184
 185 H{
 186     { 1 tagged-rep }
 187     { 2 tagged-rep }
 188     { 3 tagged-rep }
 189 } representations set
 190
 191 [ ] [ cfg get insert-gc-checks drop ] unit-test
 192 [ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
 193 [ 2 ] [ 3 get instructions>> length ] unit-test