basis/optimizer/optimizer-tests.factor

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