diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 812ef18e86..2de7c7c3d1 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -3,7 +3,8 @@ USING: tools.test kernel sequences words sequences.private fry prettyprint alien alien.accessors math.private compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker -arrays locals byte-arrays kernel.private math slots.private ; +arrays locals byte-arrays kernel.private math slots.private vectors sbufs +strings math.partial-dispatch strings.private ; ! Just ensure that various CFGs build correctly. : unit-test-cfg ( quot -- ) @@ -18,6 +19,13 @@ arrays locals byte-arrays kernel.private math slots.private ; ] if ] any? ; inline recursive +: more? ( x -- ? ) ; + +: test-case-1 ( -- ? ) f ; + +: test-case-2 ( -- ) + test-case-1 [ test-case-2 ] [ ] if ; inline recursive + { [ ] [ dup ] @@ -62,6 +70,36 @@ arrays locals byte-arrays kernel.private math slots.private ; [ swap - + * ] [ swap slot ] [ blahblah ] + [ 1000 [ dup [ reverse ] when ] times ] + [ 1array ] + [ 1 2 ? ] + [ { array } declare [ ] map ] + [ { array } declare dup 1 slot [ 1 slot ] when ] + [ [ dup more? ] [ dup ] produce ] + [ vector new over test-case-1 [ test-case-2 ] [ ] if ] + [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ] + [ + { fixnum sbuf } declare 2dup 3 slot fixnum> [ + over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot + ] [ ] if + ] + [ [ 2 fixnum* ] when 3 ] + [ [ 2 fixnum+ ] when 3 ] + [ [ 2 fixnum- ] when 3 ] + [ 10000 [ ] times ] + [ + over integer? [ + over dup 16 <-integer-fixnum + [ 0 >=-integer-fixnum ] [ drop f ] if [ + nip dup + [ ] [ ] if + ] [ 2drop f ] if + ] [ 2drop f ] if + ] + [ + pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if + set-string-nth-fast + ] } [ unit-test-cfg ] each diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor index afb364f4fe..28528068c2 100644 --- a/basis/compiler/cfg/coalescing/coalescing.factor +++ b/basis/compiler/cfg/coalescing/coalescing.factor @@ -54,6 +54,6 @@ SYMBOL: seen dup compute-dfs dup process-blocks break-interferences - insert-copies dup perform-renaming + insert-copies dup remove-phis ; \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/coalescing/copies/copies.factor index 86f9e12423..ab1c514c96 100644 --- a/basis/compiler/cfg/coalescing/copies/copies.factor +++ b/basis/compiler/cfg/coalescing/copies/copies.factor @@ -7,11 +7,11 @@ IN: compiler.cfg.coalescing.copies : compute-copies ( assoc -- assoc' ) dup assoc-size [ '[ - [ _ set-at ] with each + [ _ 2dup key? [ "OOPS" throw ] [ set-at ] if ] with each ] assoc-each ] keep ; -: insert-copies ( cfg -- ) +: insert-copies ( -- ) waiting get [ [ instructions>> building ] dip '[ building get pop diff --git a/basis/compiler/cfg/coalescing/renaming/renaming.factor b/basis/compiler/cfg/coalescing/renaming/renaming.factor index bad74807d0..848d0a4df0 100644 --- a/basis/compiler/cfg/coalescing/renaming/renaming.factor +++ b/basis/compiler/cfg/coalescing/renaming/renaming.factor @@ -5,29 +5,43 @@ compiler.cfg.coalescing.state compiler.cfg.renaming compiler.cfg.rpo disjoint-sets ; IN: compiler.cfg.coalescing.renaming +: build-disjoint-set ( assoc -- disjoint-set ) + dup [ + '[ + [ _ add-atom ] + [ [ drop _ add-atom ] assoc-each ] + bi* + ] assoc-each + ] keep ; + : update-congruence-class ( dst assoc disjoint-set -- ) - [ keys swap ] dip - [ nip add-atoms ] - [ add-atom drop ] - [ equate-all-with ] 3tri ; + [ keys swap ] dip equate-all-with ; : build-congruence-classes ( -- disjoint-set ) renaming-sets get - [ - '[ - _ update-congruence-class - ] assoc-each - ] keep ; + dup build-disjoint-set + [ '[ _ update-congruence-class ] assoc-each ] keep ; : compute-renaming ( disjoint-set -- assoc ) [ parents>> ] keep '[ drop dup _ representative ] assoc-map ; -: perform-renaming ( cfg -- ) - build-congruence-classes compute-renaming renamings set +: rename-blocks ( cfg -- ) [ instructions>> [ [ rename-insn-defs ] [ rename-insn-uses ] bi ] each ] each-basic-block ; + +: rename-copies ( -- ) + waiting renamings get '[ + [ + [ _ [ ?at drop ] [ '[ _ ?at drop ] map ] bi-curry bi* ] assoc-map + ] assoc-map + ] change ; + +: perform-renaming ( cfg -- ) + build-congruence-classes compute-renaming renamings set + rename-blocks + rename-copies ; diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor index 0d4513c848..3da98a5e87 100644 --- a/basis/compiler/cfg/dominance/dominance-tests.factor +++ b/basis/compiler/cfg/dominance/dominance-tests.factor @@ -7,6 +7,7 @@ compiler.cfg.predecessors ; cfg new 0 get >>entry compute-predecessors dup compute-dominance + dup compute-dom-frontiers compute-dfs ; ! Example with no back edges diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index 695a586199..e69de29bb2 100755 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -1,58 +0,0 @@ -USING: accessors arrays compiler.cfg.checker compiler.cfg.debugger -compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.optimizer -fry kernel kernel.private math math.partial-dispatch math.private -sbufs sequences sequences.private sets slots.private strings -strings.private tools.test vectors layouts ; -IN: compiler.cfg.optimizer.tests - -! Miscellaneous tests - -: more? ( x -- ? ) ; - -: test-case-1 ( -- ? ) f ; - -: test-case-2 ( -- ) - test-case-1 [ test-case-2 ] [ ] if ; inline recursive - -{ - [ 1array ] - [ 1 2 ? ] - [ { array } declare [ ] map ] - [ { array } declare dup 1 slot [ 1 slot ] when ] - [ [ dup more? ] [ dup ] produce ] - [ vector new over test-case-1 [ test-case-2 ] [ ] if ] - [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ] - [ - { fixnum sbuf } declare 2dup 3 slot fixnum> [ - over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot - ] [ ] if - ] - [ [ 2 fixnum* ] when 3 ] - [ [ 2 fixnum+ ] when 3 ] - [ [ 2 fixnum- ] when 3 ] - [ 10000 [ ] times ] - [ - over integer? [ - over dup 16 <-integer-fixnum - [ 0 >=-integer-fixnum ] [ drop f ] if [ - nip dup - [ ] [ ] if - ] [ 2drop f ] if - ] [ 2drop f ] if - ] - [ - pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if - set-string-nth-fast - ] -} [ - [ [ ] ] dip '[ _ test-cfg first optimize-cfg check-cfg ] unit-test -] each - -cell 8 = [ - [ t ] - [ - [ - 1 50 fixnum-shift-fast fixnum+fast - ] test-mr first instructions>> [ ##add? ] any? - ] unit-test -] when