compiler.cfg.parallel-copy: fix algorithm

basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor

@@ -11,9 +11,9 @@ SYMBOL: temp
 
 [
     {
-        T{ ##copy f V int-regs 3 V int-regs 2 }
+        T{ ##copy f V int-regs 4 V int-regs 2 }
         T{ ##copy f V int-regs 2 V int-regs 1 }
-        T{ ##copy f V int-regs 1 V int-regs 3 }
+        T{ ##copy f V int-regs 1 V int-regs 4 }
     }
 ] [
     H{

basis/compiler/cfg/parallel-copy/parallel-copy.alt.factor

@@ -1,57 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs compiler.cfg.hats compiler.cfg.instructions
-deques dlists fry kernel locals namespaces sequences
-hashtables ;
-IN: compiler.cfg.parallel-copy
-
-! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency
-! http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf,
-! Algorithm 1
-
-<PRIVATE
-
-SYMBOLS: temp locs preds to-do ready ;
-
-: init-to-do ( bs -- )
-    to-do get push-all-back ;
-
-: init-ready ( bs -- )
-    locs get '[ _ key? not ] filter ready get push-all-front ;
-
-: init ( mapping temp -- )
-    temp set
-    <dlist> to-do set
-    <dlist> ready set
-    [  preds set ]
-    [ [ nip dup ] H{ } assoc-map-as locs set ]
-    [ keys [ init-to-do ] [ init-ready ] bi ] tri ;
-
-:: process-ready ( b quot -- )
-    b preds get at :> a
-    a locs get at :> c
-    b c quot call
-    b a locs get set-at
-    a c = a preds get at and [ a ready get push-front ] when ; inline
-
-:: process-to-do ( b quot -- )
-    b preds get at locs get at b = [
-        temp get b quot call
-        temp get b locs get set-at
-        b ready get push-front
-    ] unless ; inline
-
-PRIVATE>
-
-:: parallel-mapping ( mapping temp quot -- )
-    [
-        mapping temp init
-        to-do get [
-            ready get [
-                quot process-ready
-            ] slurp-deque
-            quot process-to-do
-        ] slurp-deque
-    ] with-scope ;
-
-: parallel-copy ( mapping -- ) i [ ##copy ] parallel-mapping ;

basis/compiler/cfg/parallel-copy/parallel-copy.factor

@@ -2,45 +2,59 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs compiler.cfg.hats compiler.cfg.instructions
 deques dlists fry kernel locals namespaces sequences
-sets hashtables ;
+hashtables ;
 IN: compiler.cfg.parallel-copy
 
-SYMBOLS: mapping dependency-graph work-list ;
+! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency
+! http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf,
+! Algorithm 1
 
-: build-dependency-graph ( mapping -- deps )
+<PRIVATE
-    H{ } clone [ '[ _ conjoin-at ] assoc-each ] keep ;
 
-: build-work-list ( mapping graph -- work-list )
+SYMBOLS: temp locs preds to-do ready ;
-    [ keys ] dip '[ _ key? not ] filter <dlist> [ push-all-front ] keep ;
 
-: init ( mapping -- work-list )
+: init-to-do ( bs -- )
-    dup build-dependency-graph
+    to-do get push-all-back ;
-    [ [ >hashtable mapping set ] [ dependency-graph set ] bi* ]
-    [ build-work-list dup work-list set ]
-    2bi ;
 
-:: retire-copy ( dst src -- )
+: init-ready ( bs -- )
-    dst mapping get delete-at
+    locs get '[ _ key? not ] filter ready get push-all-front ;
-    src dependency-graph get at :> deps
-    dst deps delete-at
-    deps assoc-empty? [
-        src mapping get key? [
-            src work-list get push-front
-        ] when
-    ] when ;
 
-: perform-copy ( dst -- )
+: init ( mapping temp -- )
-    dup mapping get at
+    temp set
-    [ ##copy ] [ retire-copy ] 2bi ;
+    <dlist> to-do set
+    <dlist> ready set
+    [  preds set ]
+    [ [ nip dup ] H{ } assoc-map-as locs set ]
+    [ keys [ init-to-do ] [ init-ready ] bi ] tri ;
 
-: break-cycle ( dst src -- dst src' )
+:: process-ready ( b quot -- )
-    [ i dup ] dip ##copy ;
+    b preds get at :> a
+    a locs get at :> c
+    b c quot call
+    b a locs get set-at
+    a c = a preds get at and [ a ready get push-front ] when ; inline
 
-: break-cycles ( mapping -- )
+:: process-to-do ( b quot -- )
-    >alist [ break-cycle ] { } assoc-map-as [ ##copy ] assoc-each ;
+    ! Note that we check if b = loc(b), not b = loc(pred(b)) as the
+    ! paper suggests. Confirmed by one of the authors at
+    ! http://www.reddit.com/comments/93253/some_lecture_notes_on_ssa_form/c0bco4f
+    b locs get at b = [
+        temp get b quot call
+        temp get b locs get set-at
+        b ready get push-front
+    ] when ; inline
 
-: parallel-copy ( mapping -- )
+PRIVATE>
+
+:: parallel-mapping ( mapping temp quot -- )
     [
-        init [ perform-copy ] slurp-deque
+        mapping temp init
-        mapping get dup assoc-empty? [ drop ] [ break-cycles ] if
+        to-do get [
-    ] with-scope ;
+            ready get [
+                quot process-ready
+            ] slurp-deque
+            quot process-to-do
+        ] slurp-deque
+    ] with-scope ; inline
+
+: parallel-copy ( mapping -- ) i [ ##copy ] parallel-mapping ;