Debugging compiler.cfg.coalescing

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

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 ;

basis/compiler/cfg/coalescing/copies/copies.factor

@@ -7,11 +7,11 @@ IN: compiler.cfg.coalescing.copies
 : compute-copies ( assoc -- assoc' )
     dup assoc-size <hashtable> [
         '[
-            [ _ 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

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 )
+    <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
-    <disjoint-set> [
-        '[
-            _ 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 ;

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

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