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