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