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