1 USING: accessors alien alien.accessors arrays assocs byte-arrays
2 combinators.short-circuit compiler.cfg compiler.cfg.builder
3 compiler.cfg.builder.blocks compiler.cfg.checker compiler.cfg.debugger
4 compiler.cfg.instructions compiler.cfg.linearization
5 compiler.cfg.optimizer compiler.cfg.registers
6 compiler.cfg.stacks.local compiler.cfg.utilities compiler.test
7 compiler.tree compiler.tree.builder compiler.tree.optimizer
8 compiler.tree.propagation.info cpu.architecture fry hashtables io
9 kernel kernel.private locals make math math.intervals
10 math.partial-dispatch math.private namespaces prettyprint sbufs
11 sequences sequences.private slots.private strings strings.private
12 tools.test vectors words ;
13 FROM: alien.c-types => int ;
14 IN: compiler.cfg.builder.tests
16 ! Just ensure that various CFGs build correctly.
17 : unit-test-builder ( quot -- )
21 [ optimize-cfg ] [ check-cfg ] bi
24 ] [ ] swap unit-test ;
26 : blahblah ( nodes -- ? )
28 dup 3 bitand 1 = [ drop t ] [
33 ] any? ; inline recursive
37 : test-case-1 ( -- ? ) f ;
40 test-case-1 [ test-case-2 ] [ ] if ; inline recursive
52 [ 3 swap fixnum*fast ]
54 [ 10 fixnum-shift-fast ]
55 [ -10 fixnum-shift-fast ]
56 [ 0 fixnum-shift-fast ]
57 [ 10 swap fixnum-shift-fast ]
58 [ -10 swap fixnum-shift-fast ]
59 [ 0 swap fixnum-shift-fast ]
74 [ fixnum< [ 1 ] [ 2 ] if ]
75 [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
76 [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
79 [ [ 2 ] [ 3 throw ] if 4 ]
80 [ int f "malloc" { int } f alien-invoke ]
81 [ int { int } cdecl alien-indirect ]
82 [ int { int } cdecl [ ] alien-callback ]
86 [ 1000 [ dup [ reverse ] when ] times ]
89 [ { array } declare [ ] map ]
90 [ { array } declare dup 1 slot [ 1 slot ] when ]
91 [ [ dup more? ] [ dup ] produce ]
92 [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
93 [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry each-integer-from ]
95 { fixnum sbuf } declare 2dup 3 slot fixnum> [
96 over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
99 [ [ 2 fixnum* ] when 3 ]
100 [ [ 2 fixnum+ ] when 3 ]
101 [ [ 2 fixnum- ] when 3 ]
105 over dup 16 <-integer-fixnum
106 [ 0 >=-integer-fixnum ] [ drop f ] if [
113 pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
120 : test-1 ( -- ) test-1 ;
121 : test-2 ( -- ) 3 . test-2 ;
122 : test-3 ( a -- b ) dup [ test-3 ] when ;
128 } [ unit-test-builder ] each
146 { class } word '[ _ declare 10 _ execute ] unit-test-builder
147 { class fixnum } word '[ _ declare _ execute ] unit-test-builder
158 { fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder
159 { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
162 { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-builder
163 { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-builder
165 { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-builder
166 { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-builder
168 { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-builder
169 { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
172 { t } [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
174 { f } [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
177 [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
178 [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
182 [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
183 [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
187 [ { byte-array fixnum } declare set-alien-unsigned-1 ]
188 [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
192 [ { byte-array fixnum } declare alien-cell ]
193 [ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn? ]
194 [ [ ##box-alien? ] contains-insn? ]
199 [ { byte-array integer } declare alien-cell ]
200 [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn?
204 [ 1000 [ ] times ] [ ##peek? ] contains-insn?
208 [ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
209 [ [ ##unbox-any-c-ptr? ] contains-insn? ]
210 [ [ ##unbox-alien? ] contains-insn? ] bi
213 \ alien-float "intrinsic" word-prop [
215 [ { byte-array fixnum } declare alien-cell 4 alien-float ]
216 [ [ ##box-alien? ] contains-insn? ]
217 [ [ ##allot? ] contains-insn? ] bi
221 [ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
222 [ [ ##box-alien? ] contains-insn? ]
223 [ [ ##allot? ] contains-insn? ] bi
226 [ 1 ] [ [ dup float+ ] [ ##load-memory-imm? ] count-insns ] unit-test
229 ! Regression. Make sure everything is inlined correctly
230 { f } [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
232 ! Regression. Make sure branch splitting works.
233 { 2 } [ [ 1 2 ? ] [ ##return? ] count-insns ] unit-test
235 ! Make sure fast union predicates don't have conditionals.
237 [ tag 1 swap fixnum-shift-fast ]
238 [ ##compare-integer-imm-branch? ] contains-insn?
245 \ foo f begin-cfg word>>
250 [ dup ] build-tree optimize-tree gensym build-cfg
251 first linearization-order length
256 { T{ #call { word + } } }
267 V{ T{ ##call { word print } } T{ ##branch } }
269 <basic-block> dup set-basic-block \ print 4 emit-call
270 predecessors>> first instructions>>
275 <basic-block> dup set-basic-block ##branch,
280 { T{ #push { literal 3 } { out-d { 6 } } } }
281 { T{ #push { literal 2 } { out-d { 7 } } } }
284 { live-branches { t t } }
286 predecessors>> [ instructions>> first val>> ] map
291 V{ } 0 insns>block dup set-basic-block
292 V{ } "good" insns>block swap [ emit-loop-call ] keep
293 [ successors>> length ] [ successors>> first number>> ] bi
301 T{ ##load-integer { dst 3 } { val 0 } }
302 T{ ##add { dst 4 } { src1 3 } { src2 2 } }
309 T{ ##box-alien { dst 7 } { src 5 } { temp 6 } }
316 } [ emit-node drop ] V{ } make
319 : call-node-1 ( -- node )
330 { interval full-interval }
337 { interval full-interval }
344 { interval full-interval }
352 V{ T{ ##call { word set-slot } } T{ ##branch } }
355 <basic-block> dup set-basic-block call-node-1 emit-node
357 predecessors>> first instructions>>
362 { T{ ##load-integer { dst 78 } { val 0 } } }
364 77 vreg-counter set-global
365 [ f T{ #push { literal 0 } { out-d { 8537399 } } } emit-node drop ] { } make
370 T{ height-state f 0 0 1 0 }
371 H{ { D: -1 4 } { D: 0 4 } }
375 { mapping { { 2 4 } { 3 4 } } }
386 <basic-block> dup set-basic-block
387 T{ #terminate { in-d { } } { in-r { } } } emit-node
398 <basic-block> dup set-basic-block end-word instructions>>
403 T{ #shuffle { in-d { 37 81 92 } } { out-d { 20 } } } height-changes
408 { { 37 D: 2 } { 81 D: 1 } { 92 D: 0 } }
410 T{ #shuffle { in-d { 37 81 92 } } } make-input-map
417 f T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
418 emit-node drop replaces get
422 H{ { D: -1 1 } { D: 0 1 } }
427 { mapping { { 55 7 } { 77 7 } } }
428 } emit-node drop replaces get