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