basis/compiler/tests/optimizer.factor

   1 USING: accessors arrays compiler.units generic hashtables
   2 stack-checker kernel kernel.private math prettyprint sequences
   3 sbufs strings tools.test vectors words sequences.private
   4 quotations classes classes.algebra classes.tuple.private
   5 continuations growable namespaces hints alien.accessors
   6 compiler.tree.builder compiler.tree.optimizer sequences.deep ;
   7 IN: optimizer.tests
   8
   9 GENERIC: xyz ( obj -- obj )
  10 M: array xyz xyz ;
  11
  12 [ t ] [ \ xyz compiled>> ] unit-test
  13
  14 ! Test predicate inlining
  15 : pred-test-1
  16     dup fixnum? [
  17         dup integer? [ "integer" ] [ "nope" ] if
  18     ] [
  19         "not a fixnum"
  20     ] if ;
  21
  22 [ 1 "integer" ] [ 1 pred-test-1 ] unit-test
  23
  24 TUPLE: pred-test ;
  25
  26 : pred-test-2
  27     dup tuple? [
  28         dup pred-test? [ "pred-test" ] [ "nope" ] if
  29     ] [
  30         "not a tuple"
  31     ] if ;
  32
  33 [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
  34
  35 : pred-test-3
  36     dup pred-test? [
  37         dup tuple? [ "pred-test" ] [ "nope" ] if
  38     ] [
  39         "not a tuple"
  40     ] if ;
  41
  42 [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
  43
  44 : inline-test
  45     "nom" = ;
  46
  47 [ t ] [ "nom" inline-test ] unit-test
  48 [ f ] [ "shayin" inline-test ] unit-test
  49 [ f ] [ 3 inline-test ] unit-test
  50
  51 : fixnum-declarations >fixnum 24 shift 1234 bitxor ;
  52
  53 [ ] [ 1000000 fixnum-declarations . ] unit-test
  54
  55 ! regression
  56
  57 : literal-not-branch 0 not [ ] [ ] if ;
  58
  59 [ ] [ literal-not-branch ] unit-test
  60
  61 ! regression
  62
  63 : bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
  64 : bad-kill-2 bad-kill-1 drop ;
  65
  66 [ 3 ] [ t bad-kill-2 ] unit-test
  67
  68 ! regression
  69 : (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
  70 : the-test ( -- x y ) 2 dup (the-test) ;
  71
  72 [ 2 0 ] [ the-test ] unit-test
  73
  74 ! regression
  75 : (double-recursion) ( start end -- )
  76     < [
  77         6 1 (double-recursion)
  78         3 2 (double-recursion)
  79     ] when ; inline
  80
  81 : double-recursion ( -- ) 0 2 (double-recursion) ;
  82
  83 [ ] [ double-recursion ] unit-test
  84
  85 ! regression
  86 : double-label-1 ( a b c -- d )
  87     [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
  88
  89 : double-label-2 ( a -- b )
  90     dup array? [ ] [ ] if 0 t double-label-1 ;
  91
  92 [ 0 ] [ 10 double-label-2 ] unit-test
  93
  94 ! regression
  95 GENERIC: void-generic ( obj -- * )
  96 : breakage ( -- * ) "hi" void-generic ;
  97 [ t ] [ \ breakage compiled>> ] unit-test
  98 [ breakage ] must-fail
  99
 100 ! regression
 101 : branch-fold-regression-0 ( m -- n )
 102     t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
 103
 104 : branch-fold-regression-1 ( -- m )
 105     10 branch-fold-regression-0 ;
 106
 107 [ 10 ] [ branch-fold-regression-1 ] unit-test
 108
 109 ! another regression
 110 : constant-branch-fold-0 "hey" ; foldable
 111 : constant-branch-fold-1 ( -- ? ) constant-branch-fold-0 "hey" = ; inline
 112 [ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
 113
 114 ! another regression
 115 : foo f ;
 116 : bar ( -- ? ) foo 4 4 = and ;
 117 [ f ] [ bar ] unit-test
 118
 119 ! compiling <tuple> with a non-literal class failed
 120 : <tuple>-regression ( class -- tuple ) <tuple> ;
 121
 122 [ t ] [ \ <tuple>-regression compiled>> ] unit-test
 123
 124 GENERIC: foozul ( a -- b )
 125 M: reversed foozul ;
 126 M: integer foozul ;
 127 M: slice foozul ;
 128
 129 [ t ] [
 130     reversed \ foozul specific-method
 131     reversed \ foozul method
 132     eq?
 133 ] unit-test
 134
 135 ! regression
 136 : constant-fold-2 f ; foldable
 137 : constant-fold-3 4 ; foldable
 138
 139 [ f t ] [
 140     [ constant-fold-2 constant-fold-3 4 = ] compile-call
 141 ] unit-test
 142
 143 : constant-fold-4 f ; foldable
 144 : constant-fold-5 f ; foldable
 145
 146 [ f ] [
 147     [ constant-fold-4 constant-fold-5 or ] compile-call
 148 ] unit-test
 149
 150 [ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
 151 [ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
 152
 153 [ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
 154 [ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
 155 [ 0 ] [ 5 [ dup - ] compile-call ] unit-test
 156
 157 [ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
 158 [ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
 159 [ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
 160 [ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
 161 [ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
 162 [ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
 163
 164 [ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
 165 [ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
 166
 167 [ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
 168 [ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
 169 [ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
 170 [ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
 171 [ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
 172
 173 [ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
 174 [ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
 175 [ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
 176 [ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
 177 [ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
 178
 179 [ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
 180 [ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
 181 [ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
 182 [ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
 183 [ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
 184
 185 [ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
 186 [ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
 187
 188 [ f ] [ 5 [ dup < ] compile-call ] unit-test
 189 [ t ] [ 5 [ dup <= ] compile-call ] unit-test
 190 [ f ] [ 5 [ dup > ] compile-call ] unit-test
 191 [ t ] [ 5 [ dup >= ] compile-call ] unit-test
 192
 193 [ t ] [ 5 [ dup eq? ] compile-call ] unit-test
 194 [ t ] [ 5 [ dup = ] compile-call ] unit-test
 195 [ t ] [ 5 [ dup number= ] compile-call ] unit-test
 196 [ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
 197
 198 GENERIC: detect-number ( obj -- obj )
 199 M: number detect-number ;
 200
 201 [ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
 202
 203 ! Regression
 204 [ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
 205
 206 ! Regression
 207 USE: sorting
 208 USE: binary-search
 209 USE: binary-search.private
 210
 211 : old-binsearch ( elt quot seq -- elt quot i )
 212     dup length 1 <= [
 213         from>>
 214     ] [
 215         [ midpoint swap call ] 3keep roll dup zero?
 216         [ drop dup from>> swap midpoint@ + ]
 217         [ dup midpoint@ cut-slice old-binsearch ] if
 218     ] if ; inline
 219
 220 [ 10 ] [
 221     10 20 >vector <flat-slice>
 222     [ [ - ] swap old-binsearch ] compile-call 2nip
 223 ] unit-test
 224
 225 ! Regression
 226 : empty-compound ;
 227
 228 : node-successor-f-bug ( x -- * )
 229     [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
 230
 231 [ t ] [ \ node-successor-f-bug compiled>> ] unit-test
 232
 233 [ ] [ [ new ] build-tree optimize-tree drop ] unit-test
 234
 235 [ ] [ [ <tuple> ] build-tree optimize-tree drop ] unit-test
 236
 237 ! Regression
 238 : lift-throw-tail-regression ( obj -- obj str )
 239     dup integer? [ "an integer" ] [
 240         dup string? [ "a string" ] [
 241             "error" throw
 242         ] if
 243     ] if ;
 244
 245 [ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
 246 [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
 247 [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
 248
 249 : lift-loop-tail-test-1 ( a quot -- )
 250     over even? [
 251         [ [ 3 - ] dip call ] keep lift-loop-tail-test-1
 252     ] [
 253         over 0 < [
 254             2drop
 255         ] [
 256             [ [ 2 - ] dip call ] keep lift-loop-tail-test-1
 257         ] if
 258     ] if ; inline
 259
 260 : lift-loop-tail-test-2
 261     10 [ ] lift-loop-tail-test-1 1 2 3 ;
 262
 263 [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
 264
 265 ! Forgot a recursive inline check
 266 : recursive-inline-hang ( a -- a )
 267     dup array? [ recursive-inline-hang ] when ;
 268
 269 HINTS: recursive-inline-hang array ;
 270
 271 : recursive-inline-hang-1 ( -- a )
 272     { } recursive-inline-hang ;
 273
 274 [ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
 275
 276 DEFER: recursive-inline-hang-3
 277
 278 : recursive-inline-hang-2 ( a -- a )
 279     dup array? [ recursive-inline-hang-3 ] when ;
 280
 281 HINTS: recursive-inline-hang-2 array ;
 282
 283 : recursive-inline-hang-3 ( a -- a )
 284     dup array? [ recursive-inline-hang-2 ] when ;
 285
 286 HINTS: recursive-inline-hang-3 array ;
 287
 288 ! Regression
 289 [ ] [ { 3append-as } compile ] unit-test
 290
 291 ! Wow
 292 : counter-example ( a b c d -- a' b' c' d' )
 293     dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline
 294
 295 : counter-example' ( -- a' b' c' d' )
 296     1 2 3.0 3 counter-example ;
 297
 298 [ 2 4 6.0 0 ] [ counter-example' ] unit-test
 299
 300 : member-test ( obj -- ? ) { + - * / /i } member? ;
 301
 302 \ member-test must-infer
 303 [ ] [ \ member-test build-tree-from-word optimize-tree 2drop ] unit-test
 304 [ t ] [ \ + member-test ] unit-test
 305 [ f ] [ \ append member-test ] unit-test
 306
 307 ! Infinite expansion
 308 TUPLE: cons car cdr ;
 309
 310 UNION: improper-list cons POSTPONE: f ;
 311
 312 PREDICATE: list < improper-list
 313     [ cdr>> list instance? ] [ t ] if* ;
 314
 315 [ t ] [
 316     T{ cons f 1 T{ cons f 2 T{ cons f 3 f } } }
 317     [ list instance? ] compile-call
 318 ] unit-test
 319
 320 ! Regression
 321 : interval-inference-bug ( obj -- obj x )
 322     dup "a" get { array-capacity } declare >=
 323     [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
 324
 325 \ interval-inference-bug must-infer
 326
 327 [ ] [ 1 "a" set 2 "b" set ] unit-test
 328 [ 2 3 ] [ 2 interval-inference-bug ] unit-test
 329 [ 1 4 ] [ 1 interval-inference-bug ] unit-test
 330 [ 0 5 ] [ 0 interval-inference-bug ] unit-test
 331
 332 : aggressive-flush-regression ( a -- b )
 333     f over [ <array> drop ] dip 1 + ;
 334
 335 [ 1.0 aggressive-flush-regression drop ] must-fail
 336
 337 [ 1 [ "hi" + drop ] compile-call ] must-fail
 338
 339 [ "hi" f [ <array> drop ] compile-call ] must-fail
 340
 341 TUPLE: some-tuple x ;
 342
 343 : allot-regression ( a -- b )
 344     [ ] curry some-tuple boa ;
 345
 346 [ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test
 347
 348 [ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1+ ] compile-call ] unit-test
 349 [ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1+ ] compile-call ] unit-test
 350 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1+ ] compile-call ] unit-test
 351 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
 352 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
 353 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
 354
 355 : deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
 356
 357 [ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
 358 [ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
 359
 360 [ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
 361
 362 [ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
 363
 364 ! Loop detection problem found by doublec
 365 SYMBOL: counter
 366
 367 DEFER: loop-bbb
 368
 369 : loop-aaa ( -- )
 370     counter inc counter get 2 < [ loop-bbb ] when ; inline recursive
 371
 372 : loop-bbb ( -- )
 373     [ loop-aaa ] with-scope ; inline recursive
 374
 375 : loop-ccc ( -- ) loop-bbb ;
 376
 377 [ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
 378
 379 ! Type inference issue
 380 [ 4 3 ] [
 381     1 >bignum 2 >bignum
 382     [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
 383 ] unit-test