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