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 compiler.test definitions generic.single shuffle math.order ;
   8 IN: compiler.tests.optimizer
   9
  10 GENERIC: xyz ( obj -- obj )
  11 M: array xyz xyz ;
  12
  13 [ t ] [ M\ array xyz optimized? ] unit-test
  14
  15 ! Test predicate inlining
  16 : pred-test-1 ( a -- b c )
  17     dup fixnum? [
  18         dup integer? [ "integer" ] [ "nope" ] if
  19     ] [
  20         "not a fixnum"
  21     ] if ;
  22
  23 [ 1 "integer" ] [ 1 pred-test-1 ] unit-test
  24
  25 TUPLE: pred-test ;
  26
  27 : pred-test-2 ( a -- b c )
  28     dup tuple? [
  29         dup pred-test? [ "pred-test" ] [ "nope" ] if
  30     ] [
  31         "not a tuple"
  32     ] if ;
  33
  34 [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
  35
  36 : pred-test-3 ( a -- b c )
  37     dup pred-test? [
  38         dup tuple? [ "pred-test" ] [ "nope" ] if
  39     ] [
  40         "not a tuple"
  41     ] if ;
  42
  43 [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
  44
  45 : inline-test ( a -- b )
  46     "nom" = ;
  47
  48 [ t ] [ "nom" inline-test ] unit-test
  49 [ f ] [ "shayin" inline-test ] unit-test
  50 [ f ] [ 3 inline-test ] unit-test
  51
  52 : fixnum-declarations ( a -- b ) >fixnum 24 shift 1234 bitxor ;
  53
  54 [ ] [ 1000000 fixnum-declarations . ] unit-test
  55
  56 ! regression
  57
  58 : literal-not-branch ( -- ) 0 not [ ] [ ] if ;
  59
  60 [ ] [ literal-not-branch ] unit-test
  61
  62 ! regression
  63
  64 : bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline recursive
  65 : bad-kill-2 ( a b -- c d ) bad-kill-1 drop ;
  66
  67 [ 3 ] [ t bad-kill-2 ] unit-test
  68
  69 ! regression
  70 : (the-test) ( x -- y ) dup 0 > [ 1 - (the-test) ] when ; inline recursive
  71 : the-test ( -- x y ) 2 dup (the-test) ;
  72
  73 [ 2 0 ] [ the-test ] unit-test
  74
  75 ! regression
  76 : (double-recursion) ( start end -- )
  77     < [
  78         6 1 (double-recursion)
  79         3 2 (double-recursion)
  80     ] when ; inline recursive
  81
  82 : double-recursion ( -- ) 0 2 (double-recursion) ;
  83
  84 [ ] [ double-recursion ] unit-test
  85
  86 ! regression
  87 : double-label-1 ( a b c -- d )
  88     [ f double-label-1 ] [ swap nth-unsafe ] if ; inline recursive
  89
  90 : double-label-2 ( a -- b )
  91     dup array? [ ] [ ] if 0 t double-label-1 ;
  92
  93 [ 0 ] [ 10 iota double-label-2 ] unit-test
  94
  95 ! regression
  96 GENERIC: void-generic ( obj -- * )
  97 : breakage ( -- * ) "hi" void-generic ;
  98 [ t ] [ \ breakage optimized? ] unit-test
  99 [ breakage ] must-fail
 100
 101 ! regression
 102 : branch-fold-regression-0 ( m -- n )
 103     t [ ] [ 1 + branch-fold-regression-0 ] if ; inline recursive
 104
 105 : branch-fold-regression-1 ( -- m )
 106     10 branch-fold-regression-0 ;
 107
 108 [ 10 ] [ branch-fold-regression-1 ] unit-test
 109
 110 ! another regression
 111 : constant-branch-fold-0 ( -- value ) "hey" ; foldable
 112 : constant-branch-fold-1 ( -- ? ) constant-branch-fold-0 "hey" = ; inline
 113 [ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
 114
 115 ! another regression
 116 : foo ( -- value ) f ;
 117 : bar ( -- ? ) foo 4 4 = and ;
 118 [ f ] [ bar ] unit-test
 119
 120 ! compiling <tuple> with a non-literal class failed
 121 : <tuple>-regression ( class -- tuple ) <tuple> ;
 122
 123 [ t ] [ \ <tuple>-regression optimized? ] unit-test
 124
 125 ! regression
 126 : constant-fold-2 ( -- value ) f ; foldable
 127 : constant-fold-3 ( -- value ) 4 ; foldable
 128
 129 [ f t ] [
 130     [ constant-fold-2 constant-fold-3 4 = ] compile-call
 131 ] unit-test
 132
 133 : constant-fold-4 ( -- value ) f ; foldable
 134 : constant-fold-5 ( -- value ) f ; foldable
 135
 136 [ f ] [
 137     [ constant-fold-4 constant-fold-5 or ] compile-call
 138 ] unit-test
 139
 140 [ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
 141 [ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
 142
 143 [ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
 144 [ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
 145 [ 0 ] [ 5 [ dup - ] compile-call ] unit-test
 146
 147 [ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
 148 [ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
 149 [ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
 150 [ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
 151 [ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
 152 [ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
 153
 154 [ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
 155 [ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
 156
 157 [ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
 158 [ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
 159 [ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
 160 [ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
 161 [ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
 162
 163 [ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
 164 [ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
 165 [ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
 166 [ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
 167 [ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
 168
 169 [ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
 170 [ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
 171 [ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
 172 [ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
 173 [ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
 174
 175 [ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
 176 [ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
 177
 178 [ f ] [ 5 [ dup < ] compile-call ] unit-test
 179 [ t ] [ 5 [ dup <= ] compile-call ] unit-test
 180 [ f ] [ 5 [ dup > ] compile-call ] unit-test
 181 [ t ] [ 5 [ dup >= ] compile-call ] unit-test
 182
 183 [ t ] [ 5 [ dup eq? ] compile-call ] unit-test
 184 [ t ] [ 5 [ dup = ] compile-call ] unit-test
 185 [ t ] [ 5 [ dup number= ] compile-call ] unit-test
 186 [ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
 187
 188 GENERIC: detect-number ( obj -- obj )
 189 M: number detect-number ;
 190
 191 [ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
 192
 193 ! Regression
 194 [ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
 195
 196 ! Regression
 197 USE: sorting
 198 USE: binary-search
 199 USE: binary-search.private
 200
 201 : old-binsearch ( elt quot: ( ..a -- ..b ) seq -- elt quot i )
 202     dup length 1 <= [
 203         from>>
 204     ] [
 205         [ midpoint swap call ] 3keep [ rot ] dip swap dup zero?
 206         [ drop dup from>> swap midpoint@ + ]
 207         [ drop dup midpoint@ head-slice old-binsearch ] if
 208     ] if ; inline recursive
 209
 210 [ 10 ] [
 211     10 20 iota <flat-slice>
 212     [ [ - ] swap old-binsearch ] compile-call 2nip
 213 ] unit-test
 214
 215 ! Regression
 216 : empty-compound ( -- ) ;
 217
 218 : node-successor-f-bug ( x -- * )
 219     [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
 220
 221 [ t ] [ \ node-successor-f-bug optimized? ] unit-test
 222
 223 [ ] [ [ new ] build-tree optimize-tree drop ] unit-test
 224
 225 [ ] [ [ <tuple> ] build-tree optimize-tree drop ] unit-test
 226
 227 ! Regression
 228 : lift-throw-tail-regression ( obj -- obj str )
 229     dup integer? [ "an integer" ] [
 230         dup string? [ "a string" ] [
 231             "error" throw
 232         ] if
 233     ] if ;
 234
 235 [ t ] [ \ lift-throw-tail-regression optimized? ] unit-test
 236 [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
 237 [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
 238
 239 : lift-loop-tail-test-1 ( a quot: ( -- ) -- )
 240     over even? [
 241         [ [ 3 - ] dip call ] keep lift-loop-tail-test-1
 242     ] [
 243         over 0 < [
 244             2drop
 245         ] [
 246             [ [ 2 - ] dip call ] keep lift-loop-tail-test-1
 247         ] if
 248     ] if ; inline recursive
 249
 250 : lift-loop-tail-test-2 ( -- a b c )
 251     10 [ ] lift-loop-tail-test-1 1 2 3 ;
 252
 253 \ lift-loop-tail-test-2 def>> must-infer
 254
 255 [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
 256
 257 ! Forgot a recursive inline check
 258 : recursive-inline-hang ( a -- a )
 259     dup array? [ recursive-inline-hang ] when ;
 260
 261 HINTS: recursive-inline-hang array ;
 262
 263 : recursive-inline-hang-1 ( -- a )
 264     { } recursive-inline-hang ;
 265
 266 [ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test
 267
 268 DEFER: recursive-inline-hang-3
 269
 270 : recursive-inline-hang-2 ( a -- a )
 271     dup array? [ recursive-inline-hang-3 ] when ;
 272
 273 HINTS: recursive-inline-hang-2 array ;
 274
 275 : recursive-inline-hang-3 ( a -- a )
 276     dup array? [ recursive-inline-hang-2 ] when ;
 277
 278 HINTS: recursive-inline-hang-3 array ;
 279
 280 ! Regression
 281 [ ] [ { 3append-as } compile ] unit-test
 282
 283 ! Wow
 284 : counter-example ( a b c d -- a' b' c' d' )
 285     dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline recursive
 286
 287 : counter-example' ( -- a' b' c' d' )
 288     1 2 3.0 3 counter-example ;
 289
 290 [ 2 4 6.0 0 ] [ counter-example' ] unit-test
 291
 292 : member-test ( obj -- ? ) { + - * / /i } member? ;
 293
 294 \ member-test def>> must-infer
 295 [ ] [ \ member-test build-tree optimize-tree drop ] unit-test
 296 [ t ] [ \ + member-test ] unit-test
 297 [ f ] [ \ append member-test ] unit-test
 298
 299 ! Infinite expansion
 300 TUPLE: cons car cdr ;
 301
 302 UNION: improper-list cons POSTPONE: f ;
 303
 304 PREDICATE: list < improper-list
 305     [ cdr>> list instance? ] [ t ] if* ;
 306
 307 [ t ] [
 308     T{ cons f 1 T{ cons f 2 T{ cons f 3 f } } }
 309     [ list instance? ] compile-call
 310 ] unit-test
 311
 312 ! Regression
 313 : interval-inference-bug ( obj -- obj x )
 314     dup "a" get { array-capacity } declare >=
 315     [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
 316
 317 [ t ] [ \ interval-inference-bug optimized? ] unit-test
 318
 319 [ ] [ 1 "a" set 2 "b" set ] unit-test
 320 [ 2 3 ] [ 2 interval-inference-bug ] unit-test
 321 [ 1 4 ] [ 1 interval-inference-bug ] unit-test
 322 [ 0 5 ] [ 0 interval-inference-bug ] unit-test
 323
 324 : aggressive-flush-regression ( a -- b )
 325     f over [ <array> drop ] dip 1 + ;
 326
 327 [ 1.0 aggressive-flush-regression drop ] must-fail
 328
 329 [ 1 [ "hi" + drop ] compile-call ] must-fail
 330
 331 [ "hi" f [ <array> drop ] compile-call ] must-fail
 332
 333 TUPLE: some-tuple x ;
 334
 335 : allot-regression ( a -- b )
 336     [ ] curry some-tuple boa ;
 337
 338 [ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test
 339
 340 [ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1 + ] compile-call ] unit-test
 341 [ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1 + ] compile-call ] unit-test
 342 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1 + ] compile-call ] unit-test
 343 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1 + ] compile-call ] unit-test
 344 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1 + ] compile-call ] unit-test
 345 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1 + ] compile-call ] unit-test
 346
 347 : deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
 348
 349 [ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
 350 [ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
 351
 352 [ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 iota [ ] B{ } map-as ] compile-call ] unit-test
 353
 354 [ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
 355
 356 ! Loop detection problem found by doublec
 357 SYMBOL: counter
 358
 359 DEFER: loop-bbb
 360
 361 : loop-aaa ( -- )
 362     counter inc counter get 2 < [ loop-bbb ] when ; inline recursive
 363
 364 : loop-bbb ( -- )
 365     [ loop-aaa ] with-scope ; inline recursive
 366
 367 : loop-ccc ( -- ) loop-bbb ;
 368
 369 [ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
 370
 371 ! Type inference issue
 372 [ 4 3 ] [
 373     1 >bignum 2 >bignum
 374     [ { bignum integer } declare [ shift ] keep 1 + ] compile-call
 375 ] unit-test
 376
 377 : broken-declaration ( -- ) \ + declare ;
 378
 379 [ f ] [ \ broken-declaration optimized? ] unit-test
 380
 381 [ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
 382
 383 ! Interval inference issue
 384 [ f ] [
 385     10 70
 386     [
 387         dup 70 >=
 388         [ dup 700 <= [ swap 1024 rem rem ] [ 2drop 70 ] if ]
 389         [ 2drop 70 ] if
 390         70 >=
 391     ] compile-call
 392 ] unit-test
 393
 394 ! Modular arithmetic bug
 395 : modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
 396
 397 [ 1 ] [ 257 modular-arithmetic-bug ] unit-test
 398 [ -10 ] [ -10 modular-arithmetic-bug ] unit-test
 399
 400 ! Optimizer needs to ignore invalid generics
 401 GENERIC# bad-dispatch-position-test* 3 ( -- )
 402
 403 M: object bad-dispatch-position-test* ;
 404
 405 : bad-dispatch-position-test ( -- ) bad-dispatch-position-test* ;
 406
 407 [ 1 2 3 4 bad-dispatch-position-test ] must-fail
 408
 409 [ ] [
 410     [
 411         \ bad-dispatch-position-test forget
 412         \ bad-dispatch-position-test* forget
 413     ] with-compilation-unit
 414 ] unit-test
 415
 416 [ 16 ] [
 417     [
 418         0 2
 419         [
 420             nip
 421             [
 422                 1 + {
 423                     [ 16 ]
 424                     [ 16 ]
 425                     [ 16 ]
 426                 } dispatch
 427             ] [
 428                 {
 429                     [ ]
 430                     [ ]
 431                     [ ]
 432                 } dispatch
 433             ] bi
 434         ] each-integer
 435     ] compile-call
 436 ] unit-test
 437
 438 : dispatch-branch-problem ( a b c -- d )
 439     dup 0 < [ "boo" throw ] when
 440     1 + { [ + ] [ - ] [ * ] } dispatch ;
 441
 442 [ 3 4 -1 dispatch-branch-problem ] [ "boo" = ] must-fail-with
 443 [ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test
 444 [ 12 ] [ 3 4 1 dispatch-branch-problem ] unit-test
 445
 446 [ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test
 447
 448 TUPLE: grid-mesh-tuple { length read-only } { step read-only } ;
 449
 450 : grid-mesh-test-case ( -- vertices )
 451     1.0 1.0 { 2 } first /f [ /i 1 + ] keep grid-mesh-tuple boa
 452     1 f <array>
 453     [
 454         [ drop length>> >fixnum 2 min ] 2keep
 455         [
 456             [ step>> 1 * ] dip
 457             0 swap set-nth-unsafe
 458         ] 2curry times
 459     ] keep ;
 460
 461 [ { 0.5 } ] [ grid-mesh-test-case ] unit-test