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

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