1 USING: accessors alien alien.accessors arrays assocs byte-arrays
2 combinators.short-circuit compiler.cfg compiler.cfg.builder compiler.cfg.checker
3 compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.optimizer
4 compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.representations
5 compiler.cfg.rpo compiler.cfg.stacks compiler.cfg.stacks.local
6 compiler.cfg.utilities compiler.test compiler.tree compiler.tree.builder
7 compiler.tree.optimizer fry hashtables kernel kernel.private locals make math
8 math.partial-dispatch math.private namespaces prettyprint sbufs sequences
9 sequences.private slots.private strings strings.private tools.test vectors
11 FROM: alien.c-types => int ;
12 IN: compiler.cfg.builder.tests
14 ! Just ensure that various CFGs build correctly.
15 : unit-test-builder ( quot -- )
19 [ optimize-cfg ] [ check-cfg ] bi
22 ] [ ] swap unit-test ;
24 : blahblah ( nodes -- ? )
26 dup 3 bitand 1 = [ drop t ] [
31 ] any? ; inline recursive
35 : test-case-1 ( -- ? ) f ;
38 test-case-1 [ test-case-2 ] [ ] if ; inline recursive
50 [ 3 swap fixnum*fast ]
52 [ 10 fixnum-shift-fast ]
53 [ -10 fixnum-shift-fast ]
54 [ 0 fixnum-shift-fast ]
55 [ 10 swap fixnum-shift-fast ]
56 [ -10 swap fixnum-shift-fast ]
57 [ 0 swap fixnum-shift-fast ]
72 [ fixnum< [ 1 ] [ 2 ] if ]
73 [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
74 [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
77 [ [ 2 ] [ 3 throw ] if 4 ]
78 [ int f "malloc" { int } alien-invoke ]
79 [ int { int } cdecl alien-indirect ]
80 [ int { int } cdecl [ ] alien-callback ]
84 [ 1000 [ dup [ reverse ] when ] times ]
87 [ { array } declare [ ] map ]
88 [ { array } declare dup 1 slot [ 1 slot ] when ]
89 [ [ dup more? ] [ dup ] produce ]
90 [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
91 [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
93 { fixnum sbuf } declare 2dup 3 slot fixnum> [
94 over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
97 [ [ 2 fixnum* ] when 3 ]
98 [ [ 2 fixnum+ ] when 3 ]
99 [ [ 2 fixnum- ] when 3 ]
103 over dup 16 <-integer-fixnum
104 [ 0 >=-integer-fixnum ] [ drop f ] if [
111 pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
118 : test-1 ( -- ) test-1 ;
119 : test-2 ( -- ) 3 . test-2 ;
120 : test-3 ( a -- b ) dup [ test-3 ] when ;
126 } [ unit-test-builder ] each
144 { class } word '[ _ declare 10 _ execute ] unit-test-builder
145 { class fixnum } word '[ _ declare _ execute ] unit-test-builder
156 { fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder
157 { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
160 { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-builder
161 { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-builder
163 { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-builder
164 { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-builder
166 { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-builder
167 { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
170 [ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
172 [ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
175 [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
176 [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
180 [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
181 [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
185 [ { byte-array fixnum } declare set-alien-unsigned-1 ]
186 [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
190 [ { byte-array fixnum } declare alien-cell ]
191 [ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn? ]
192 [ [ ##box-alien? ] contains-insn? ]
197 [ { byte-array integer } declare alien-cell ]
198 [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn?
202 [ 1000 [ ] times ] [ ##peek? ] contains-insn?
206 [ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
207 [ [ ##unbox-any-c-ptr? ] contains-insn? ]
208 [ [ ##unbox-alien? ] contains-insn? ] bi
211 \ alien-float "intrinsic" word-prop [
213 [ { byte-array fixnum } declare alien-cell 4 alien-float ]
214 [ [ ##box-alien? ] contains-insn? ]
215 [ [ ##allot? ] contains-insn? ] bi
219 [ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
220 [ [ ##box-alien? ] contains-insn? ]
221 [ [ ##allot? ] contains-insn? ] bi
224 [ 1 ] [ [ dup float+ ] [ ##load-memory-imm? ] count-insns ] unit-test
227 ! Regression. Make sure everything is inlined correctly
228 [ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
230 ! Regression. Make sure branch splitting works.
231 [ 2 ] [ [ 1 2 ? ] [ ##return? ] count-insns ] unit-test
233 ! Make sure fast union predicates don't have conditionals.
235 [ tag 1 swap fixnum-shift-fast ]
236 [ ##compare-integer-imm-branch? ] contains-insn?
241 { { 37 D 2 } { 81 D 1 } { 92 D 0 } }
243 T{ #shuffle { in-d { 37 81 92 } } } make-input-map
248 { T{ ##load-integer { dst 78 } { val 0 } } }
250 77 vreg-counter set-global
252 T{ #push { literal 0 } { out-d { 8537399 } } } emit-node
258 H{ { D -1 4 } { D 0 4 } }
262 { mapping { { 2 4 } { 3 4 } } }
271 V{ } 0 insns>block basic-block set init-cfg-test
272 V{ } 1 insns>block [ emit-loop-call ] V{ } make drop
273 basic-block get successors>> length
278 V{ } "foo" insns>block basic-block set init-cfg-test
279 [ V{ } "bar" insns>block emit-loop-call ] V{ } make drop
280 basic-block get successors>> first number>>
287 \ foo f begin-cfg word>>
294 T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
295 emit-node replaces get
299 H{ { D -1 1 } { D 0 1 } }
304 { mapping { { 55 7 } { 77 7 } } }
305 } emit-node replaces get