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 definitions generic.single ;
8 IN: compiler.tests.optimizer
10 GENERIC: xyz ( obj -- obj )
13 [ t ] [ M\ array xyz optimized? ] unit-test
15 ! Test predicate inlining
16 : pred-test-1 ( a -- b c )
18 dup integer? [ "integer" ] [ "nope" ] if
23 [ 1 "integer" ] [ 1 pred-test-1 ] unit-test
27 : pred-test-2 ( a -- b c )
29 dup pred-test? [ "pred-test" ] [ "nope" ] if
34 [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
36 : pred-test-3 ( a -- b c )
38 dup tuple? [ "pred-test" ] [ "nope" ] if
43 [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
45 : inline-test ( a -- b )
48 [ t ] [ "nom" inline-test ] unit-test
49 [ f ] [ "shayin" inline-test ] unit-test
50 [ f ] [ 3 inline-test ] unit-test
52 : fixnum-declarations ( a -- b ) >fixnum 24 shift 1234 bitxor ;
54 [ ] [ 1000000 fixnum-declarations . ] unit-test
58 : literal-not-branch ( -- ) 0 not [ ] [ ] if ;
60 [ ] [ literal-not-branch ] unit-test
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 ;
67 [ 3 ] [ t bad-kill-2 ] unit-test
70 : (the-test) ( x -- y ) dup 0 > [ 1 - (the-test) ] when ; inline recursive
71 : the-test ( -- x y ) 2 dup (the-test) ;
73 [ 2 0 ] [ the-test ] unit-test
76 : (double-recursion) ( start end -- )
78 6 1 (double-recursion)
79 3 2 (double-recursion)
80 ] when ; inline recursive
82 : double-recursion ( -- ) 0 2 (double-recursion) ;
84 [ ] [ double-recursion ] unit-test
87 : double-label-1 ( a b c -- d )
88 [ f double-label-1 ] [ swap nth-unsafe ] if ; inline recursive
90 : double-label-2 ( a -- b )
91 dup array? [ ] [ ] if 0 t double-label-1 ;
93 [ 0 ] [ 10 double-label-2 ] unit-test
96 GENERIC: void-generic ( obj -- * )
97 : breakage ( -- * ) "hi" void-generic ;
98 [ t ] [ \ breakage optimized? ] unit-test
99 [ breakage ] must-fail
102 : branch-fold-regression-0 ( m -- n )
103 t [ ] [ 1 + branch-fold-regression-0 ] if ; inline recursive
105 : branch-fold-regression-1 ( -- m )
106 10 branch-fold-regression-0 ;
108 [ 10 ] [ branch-fold-regression-1 ] unit-test
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
116 : foo ( -- value ) f ;
117 : bar ( -- ? ) foo 4 4 = and ;
118 [ f ] [ bar ] unit-test
120 ! compiling <tuple> with a non-literal class failed
121 : <tuple>-regression ( class -- tuple ) <tuple> ;
123 [ t ] [ \ <tuple>-regression optimized? ] unit-test
126 : constant-fold-2 ( -- value ) f ; foldable
127 : constant-fold-3 ( -- value ) 4 ; foldable
130 [ constant-fold-2 constant-fold-3 4 = ] compile-call
133 : constant-fold-4 ( -- value ) f ; foldable
134 : constant-fold-5 ( -- value ) f ; foldable
137 [ constant-fold-4 constant-fold-5 or ] compile-call
140 [ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
141 [ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
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
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
154 [ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
155 [ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
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
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
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
175 [ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
176 [ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
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
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
188 GENERIC: detect-number ( obj -- obj )
189 M: number detect-number ;
191 [ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
194 [ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
199 USE: binary-search.private
201 : old-binsearch ( elt quot: ( -- ) seq -- elt quot i )
205 [ midpoint swap call ] 3keep roll dup zero?
206 [ drop dup from>> swap midpoint@ + ]
207 [ drop dup midpoint@ head-slice old-binsearch ] if
208 ] if ; inline recursive
211 10 20 >vector <flat-slice>
212 [ [ - ] swap old-binsearch ] compile-call 2nip
216 : empty-compound ( -- ) ;
218 : node-successor-f-bug ( x -- * )
219 [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
221 [ t ] [ \ node-successor-f-bug optimized? ] unit-test
223 [ ] [ [ new ] build-tree optimize-tree drop ] unit-test
225 [ ] [ [ <tuple> ] build-tree optimize-tree drop ] unit-test
228 : lift-throw-tail-regression ( obj -- obj str )
229 dup integer? [ "an integer" ] [
230 dup string? [ "a string" ] [
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
239 : lift-loop-tail-test-1 ( a quot: ( -- ) -- )
241 [ [ 3 - ] dip call ] keep lift-loop-tail-test-1
246 [ [ 2 - ] dip call ] keep lift-loop-tail-test-1
248 ] if ; inline recursive
250 : lift-loop-tail-test-2 ( -- a b c )
251 10 [ ] lift-loop-tail-test-1 1 2 3 ;
253 \ lift-loop-tail-test-2 def>> must-infer
255 [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
257 ! Forgot a recursive inline check
258 : recursive-inline-hang ( a -- a )
259 dup array? [ recursive-inline-hang ] when ;
261 HINTS: recursive-inline-hang array ;
263 : recursive-inline-hang-1 ( -- a )
264 { } recursive-inline-hang ;
266 [ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test
268 DEFER: recursive-inline-hang-3
270 : recursive-inline-hang-2 ( a -- a )
271 dup array? [ recursive-inline-hang-3 ] when ;
273 HINTS: recursive-inline-hang-2 array ;
275 : recursive-inline-hang-3 ( a -- a )
276 dup array? [ recursive-inline-hang-2 ] when ;
278 HINTS: recursive-inline-hang-3 array ;
281 [ ] [ { 3append-as } compile ] unit-test
284 : counter-example ( a b c d -- a' b' c' d' )
285 dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline recursive
287 : counter-example' ( -- a' b' c' d' )
288 1 2 3.0 3 counter-example ;
290 [ 2 4 6.0 0 ] [ counter-example' ] unit-test
292 : member-test ( obj -- ? ) { + - * / /i } member? ;
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
300 TUPLE: cons car cdr ;
302 UNION: improper-list cons POSTPONE: f ;
304 PREDICATE: list < improper-list
305 [ cdr>> list instance? ] [ t ] if* ;
308 T{ cons f 1 T{ cons f 2 T{ cons f 3 f } } }
309 [ list instance? ] compile-call
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 ;
317 [ t ] [ \ interval-inference-bug optimized? ] unit-test
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
324 : aggressive-flush-regression ( a -- b )
325 f over [ <array> drop ] dip 1 + ;
327 [ 1.0 aggressive-flush-regression drop ] must-fail
329 [ 1 [ "hi" + drop ] compile-call ] must-fail
331 [ "hi" f [ <array> drop ] compile-call ] must-fail
333 TUPLE: some-tuple x ;
335 : allot-regression ( a -- b )
336 [ ] curry some-tuple boa ;
338 [ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test
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
347 : deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
349 [ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
350 [ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
352 [ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
354 [ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
356 ! Loop detection problem found by doublec
362 counter inc counter get 2 < [ loop-bbb ] when ; inline recursive
365 [ loop-aaa ] with-scope ; inline recursive
367 : loop-ccc ( -- ) loop-bbb ;
369 [ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
371 ! Type inference issue
374 [ { bignum integer } declare [ shift ] keep 1 + ] compile-call
377 : broken-declaration ( -- ) \ + declare ;
379 [ f ] [ \ broken-declaration optimized? ] unit-test
381 [ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
383 ! Interval inference issue
388 [ dup 700 <= [ swap 1024 rem rem ] [ 2drop 70 ] if ]
394 ! Modular arithmetic bug
395 : modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
397 [ 1 ] [ 257 modular-arithmetic-bug ] unit-test
398 [ -10 ] [ -10 modular-arithmetic-bug ] unit-test
400 ! Optimizer needs to ignore invalid generics
401 GENERIC# bad-dispatch-position-test* 3 ( -- )
403 M: object bad-dispatch-position-test* ;
405 : bad-dispatch-position-test ( -- ) bad-dispatch-position-test* ;
407 [ 1 2 3 4 bad-dispatch-position-test ] must-fail
411 \ bad-dispatch-position-test forget
412 \ bad-dispatch-position-test* forget
413 ] with-compilation-unit
438 : dispatch-branch-problem ( a b c -- d )
439 dup 0 < [ "boo" throw ] when
440 1 + { [ + ] [ - ] [ * ] } dispatch ;
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
446 ! Not sure if I want to fix this...
447 ! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with