basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

   1 USING: compiler.tree.escape-analysis
   2 compiler.tree.escape-analysis.allocations compiler.tree.builder
   3 compiler.tree.recursive compiler.tree.normalization
   4 math.functions compiler.tree.propagation compiler.tree.cleanup
   5 compiler.tree.combinators compiler.tree sequences math
   6 math.private kernel tools.test accessors slots.private
   7 quotations.private prettyprint classes.tuple.private classes
   8 classes.tuple namespaces
   9 compiler.tree.propagation.info stack-checker.errors
  10 compiler.tree.checker compiler.tree.def-use compiler.tree.dead-code
  11 kernel.private vectors ;
  12 IN: compiler.tree.escape-analysis.tests
  13
  14 GENERIC: count-unboxed-allocations* ( m node -- n )
  15
  16 : (count-unboxed-allocations) ( m node -- n )
  17     out-d>> first escaping-allocation? [ 1 + ] unless ;
  18
  19 M: #call count-unboxed-allocations*
  20     dup immutable-tuple-boa?
  21     [ (count-unboxed-allocations) ] [ drop ] if ;
  22
  23 M: #push count-unboxed-allocations*
  24     dup literal>> class-of immutable-tuple-class?
  25     [ (count-unboxed-allocations) ] [ drop ] if ;
  26
  27 M: #introduce count-unboxed-allocations*
  28     out-d>> [ escaping-allocation? [ 1 + ] unless ] each ;
  29
  30 M: node count-unboxed-allocations* drop ;
  31
  32 : count-unboxed-allocations ( quot -- sizes )
  33     build-tree
  34     analyze-recursive
  35     normalize
  36     propagate
  37     cleanup-tree
  38     escape-analysis
  39     dup check-nodes
  40     compute-def-use
  41     remove-dead-code
  42     0 swap [ count-unboxed-allocations* ] each-node ;
  43
  44 [ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
  45
  46 [ 1 ] [ [ [ + ] curry drop ] count-unboxed-allocations ] unit-test
  47
  48 [ 1 ] [ [ [ + ] curry 3 slot ] count-unboxed-allocations ] unit-test
  49
  50 [ 1 ] [ [ [ + ] curry 3 slot drop ] count-unboxed-allocations ] unit-test
  51
  52 [ 1 ] [ [ [ + ] curry uncurry ] count-unboxed-allocations ] unit-test
  53
  54 [ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
  55
  56 [ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
  57
  58 [ 0 ] [ [ [ [ + ] curry ] [ drop [ ] ] if ] count-unboxed-allocations ] unit-test
  59
  60 [ 2 ] [
  61     [ [ [ + ] curry ] [ [ * ] curry ] if uncurry ] count-unboxed-allocations
  62 ] unit-test
  63
  64 [ 0 ] [
  65     [ [ [ + ] curry ] [ [ * ] curry ] if ] count-unboxed-allocations
  66 ] unit-test
  67
  68 [ 3 ] [
  69     [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if uncurry ] count-unboxed-allocations
  70 ] unit-test
  71
  72 [ 2 ] [
  73     [ [ [ + ] curry 4 ] [ dup [ [ * ] curry ] [ [ / ] curry ] if uncurry ] if ] count-unboxed-allocations
  74 ] unit-test
  75
  76 [ 0 ] [
  77     [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if ] count-unboxed-allocations
  78 ] unit-test
  79
  80 TUPLE: cons { car read-only } { cdr read-only } ;
  81
  82 [ 0 ] [
  83     [
  84         dup 0 = [
  85             2 cons boa
  86         ] [
  87             dup 1 = [
  88                 3 cons boa
  89             ] when
  90         ] if car>>
  91     ] count-unboxed-allocations
  92 ] unit-test
  93
  94 [ 3 ] [
  95     [
  96         dup 0 = [
  97             2 cons boa
  98         ] [
  99             dup 1 = [
 100                 3 cons boa
 101             ] [
 102                 4 cons boa
 103             ] if
 104         ] if car>>
 105     ] count-unboxed-allocations
 106 ] unit-test
 107
 108 [ 0 ] [
 109     [
 110         dup 0 = [
 111             dup 1 = [
 112                 3 cons boa
 113             ] [
 114                 4 cons boa
 115             ] if
 116         ] unless car>>
 117     ] count-unboxed-allocations
 118 ] unit-test
 119
 120 [ 2 ] [
 121     [
 122         dup 0 = [
 123             2 cons boa
 124         ] [
 125             dup 1 = [
 126                 3 cons boa
 127             ] [
 128                 4 cons boa
 129             ] if car>>
 130         ] if
 131     ] count-unboxed-allocations
 132 ] unit-test
 133
 134 [ 0 ] [
 135     [
 136         dup 0 = [
 137             2 cons boa
 138         ] [
 139             dup 1 = [
 140                 3 cons boa dup .
 141             ] [
 142                 4 cons boa
 143             ] if
 144         ] if drop
 145     ] count-unboxed-allocations
 146 ] unit-test
 147
 148 [ 2 ] [
 149     [
 150         [ dup cons boa ] [ drop 1 2 cons boa ] if car>>
 151     ] count-unboxed-allocations
 152 ] unit-test
 153
 154 [ 2 ] [
 155     [
 156         3dup
 157         [ cons boa ] [ cons boa 3 cons boa ] if
 158         [ car>> ] [ cdr>> ] bi
 159     ] count-unboxed-allocations
 160 ] unit-test
 161
 162 [ 2 ] [
 163     [
 164         3dup [ cons boa ] [ cons boa . 1 2 cons boa ] if
 165         [ car>> ] [ cdr>> ] bi
 166     ] count-unboxed-allocations
 167 ] unit-test
 168
 169 [ 1 ] [
 170     [ [ 3 cons boa ] [ "A" throw ] if car>> ]
 171     count-unboxed-allocations
 172 ] unit-test
 173
 174 [ 0 ] [
 175     [ 10 [ drop ] each-integer ] count-unboxed-allocations
 176 ] unit-test
 177
 178 [ 0 ] [
 179     [
 180         1 2 cons boa 10 [ drop 2 cons boa ] each-integer car>>
 181     ] count-unboxed-allocations
 182 ] unit-test
 183
 184 : infinite-cons-loop ( a -- b ) 2 cons boa infinite-cons-loop ; inline recursive
 185
 186 [ 0 ] [
 187     [
 188         1 2 cons boa infinite-cons-loop
 189     ] count-unboxed-allocations
 190 ] unit-test
 191
 192 TUPLE: rw-box i ;
 193
 194 C: <rw-box> rw-box
 195
 196 [ 0 ] [ [ <rw-box> i>> ] count-unboxed-allocations ] unit-test
 197
 198 : fake-fib ( m -- n )
 199     dup i>> 1 <= [ drop 1 <rw-box> ] when ; inline recursive
 200
 201 [ 0 ] [ [ <rw-box> fake-fib i>> ] count-unboxed-allocations ] unit-test
 202
 203 TUPLE: ro-box { i read-only } ;
 204
 205 C: <ro-box> ro-box
 206
 207 : tuple-fib ( m -- n )
 208     dup i>> 1 <= [
 209         drop 1 <ro-box>
 210     ] [
 211         i>> 1 - <ro-box>
 212         dup tuple-fib
 213         swap
 214         i>> 1 - <ro-box>
 215         tuple-fib
 216         swap i>> swap i>> + <ro-box>
 217     ] if ; inline recursive
 218
 219 [ 5 ] [ [ <ro-box> tuple-fib i>> ] count-unboxed-allocations ] unit-test
 220
 221 [ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
 222
 223 : tuple-fib' ( m -- n )
 224     dup 1 <= [ 1 - tuple-fib' i>> ] when <ro-box> ; inline recursive
 225
 226 [ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test
 227
 228 : bad-tuple-fib-1 ( m -- n )
 229     dup i>> 1 <= [
 230         drop 1 <ro-box>
 231     ] [
 232         i>> 1 - <ro-box>
 233         dup bad-tuple-fib-1
 234         swap
 235         i>> 1 - <ro-box>
 236         bad-tuple-fib-1 dup .
 237         swap i>> swap i>> + <ro-box>
 238     ] if ; inline recursive
 239
 240 [ 3 ] [ [ <ro-box> bad-tuple-fib-1 i>> ] count-unboxed-allocations ] unit-test
 241
 242 : bad-tuple-fib-2 ( m -- n )
 243     dup .
 244     dup i>> 1 <= [
 245         drop 1 <ro-box>
 246     ] [
 247         i>> 1 - <ro-box>
 248         dup bad-tuple-fib-2
 249         swap
 250         i>> 1 - <ro-box>
 251         bad-tuple-fib-2
 252         swap i>> swap i>> + <ro-box>
 253     ] if ; inline recursive
 254
 255 [ 2 ] [ [ <ro-box> bad-tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
 256
 257 : tuple-fib-2 ( m -- n )
 258     dup 1 <= [
 259         drop 1 <ro-box>
 260     ] [
 261         1 - dup tuple-fib-2
 262         swap
 263         1 - tuple-fib-2
 264         swap i>> swap i>> + <ro-box>
 265     ] if ; inline recursive
 266
 267 [ 2 ] [ [ tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
 268
 269 : tuple-fib-3 ( m -- n )
 270     dup 1 <= [
 271         drop 1 <ro-box>
 272     ] [
 273         1 - dup tuple-fib-3
 274         swap
 275         1 - tuple-fib-3 dup .
 276         swap i>> swap i>> + <ro-box>
 277     ] if ; inline recursive
 278
 279 [ 0 ] [ [ tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
 280
 281 : bad-tuple-fib-3 ( m -- n )
 282     dup 1 <= [
 283         drop 1 <ro-box>
 284     ] [
 285         1 - dup bad-tuple-fib-3
 286         swap
 287         1 - bad-tuple-fib-3
 288         2drop f
 289     ] if ; inline recursive
 290
 291 [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
 292
 293 [ 1 ] [ [ complex boa >rect ] count-unboxed-allocations ] unit-test
 294
 295 [ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
 296
 297 [ 1 ] [ [ 1 cons boa 2 cons boa car>> ] count-unboxed-allocations ] unit-test
 298
 299 [ 0 ] [ [ 1 cons boa 2 cons boa dup . car>> ] count-unboxed-allocations ] unit-test
 300
 301 [ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
 302
 303 [ 0 ] [
 304     [ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
 305     count-unboxed-allocations
 306 ] unit-test
 307
 308 [ 0 ] [
 309     [ \ too-many->r boa f f \ inference-error boa ]
 310     count-unboxed-allocations
 311 ] unit-test
 312
 313 ! Doug found a regression
 314
 315 TUPLE: empty-tuple ;
 316
 317 [ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
 318
 319 ! New feature!
 320
 321 [ 1 ] [ [ { complex } declare real>> ] count-unboxed-allocations ] unit-test
 322
 323 [ 1 ] [
 324     [ { complex } declare [ real>> ] [ imaginary>> ] bi ]
 325     count-unboxed-allocations
 326 ] unit-test
 327
 328 [ 0 ] [
 329     [ { vector } declare length>> ]
 330     count-unboxed-allocations
 331 ] unit-test
 332
 333 ! Bug found while tweaking benchmark.raytracer-simd
 334
 335 TUPLE: point-2d { x read-only } { y read-only } ;
 336 TUPLE: point-3d < point-2d { z read-only } ;
 337
 338 [ 0 ] [
 339     [ { point-2d } declare dup point-3d? [ z>> ] [ x>> ] if ]
 340     count-unboxed-allocations
 341 ] unit-test
 342
 343 [ 0 ] [
 344     [ point-2d boa dup point-3d? [ z>> ] [ x>> ] if ]
 345     count-unboxed-allocations
 346 ] unit-test