use reject instead of [ ... not ] filter.

[factor.git] / basis / compiler / cfg / parallel-copy / parallel-copy.factor

diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy.factor b/basis/compiler/cfg/parallel-copy/parallel-copy.factor
index ff309c45ad22917a011e5dce08da21473ffaa37a..1a7be5d8fd76f9bdc46f9172a447d4d448011721 100644 (file)
--- a/basis/compiler/cfg/parallel-copy/parallel-copy.factor
+++ b/basis/compiler/cfg/parallel-copy/parallel-copy.factor
@@ -1,46 +1,71 @@
 ! 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
-sets hashtables ;
+USING: assocs compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.ssa.destruction.leaders cpu.architecture deques
+dlists fry kernel locals make namespaces sequences ;
+FROM: sets => conjoin ;
 IN: compiler.cfg.parallel-copy
 
-SYMBOLS: mapping dependency-graph work-list ;
+<PRIVATE
 
-: build-dependency-graph ( mapping -- deps )
-    H{ } clone [ '[ _ conjoin-at ] assoc-each ] keep ;
+SYMBOLS: locs preds to-do ready ;
 
-: build-work-list ( mapping graph -- work-list )
-    [ keys ] dip '[ _ key? not ] filter <dlist> [ push-all-front ] keep ;
+: init-to-do ( bs -- )
+    to-do get push-all-back ;
 
-: init ( mapping -- work-list )
-    dup build-dependency-graph
-    [ [ >hashtable mapping set ] [ dependency-graph set ] bi* ]
-    [ build-work-list dup work-list set ]
-    2bi ;
+: init-ready ( bs -- )
+    locs get '[ _ key? ] reject ready get push-all-front ;
 
-:: retire-copy ( dst src -- )
-    dst mapping get delete-at
-    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 ;
+: init ( mapping -- )
+    <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 ;
 
-: perform-copy ( dst -- )
-    dup mapping get at
-    [ ##copy ] [ retire-copy ] 2bi ;
+:: process-ready ( b quot: ( dst src -- ) -- )
+    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-cycle ( dst src -- dst src' )
-    [ i dup ] dip ##copy ;
+:: process-to-do ( b temp: ( src -- dst ) quot: ( dst src -- ) -- )
+    b locs get at b = [
+        b temp call :> temp
+        temp b quot call
+        temp b locs get set-at
+        b ready get push-front
+    ] when ; inline
 
-: break-cycles ( mapping -- )
-    >alist [ break-cycle ] { } assoc-map-as [ ##copy ] assoc-each ;
+PRIVATE>
 
-: parallel-copy ( mapping -- )
+:: parallel-mapping ( mapping temp: ( src -- dst ) quot: ( dst src -- ) -- )
     [
-        init [ perform-copy ] slurp-deque
-        mapping get dup assoc-empty? [ drop ] [ break-cycles ] if
-    ] with-scope ;
\ No newline at end of file
+        mapping init
+        to-do get [
+            ready get [
+                quot process-ready
+            ] slurp-deque
+            temp quot process-to-do
+        ] slurp-deque
+    ] with-scope ; inline
+
+: parallel-copy ( mapping -- insns )
+    [ next-vreg '[ drop _ ] [ any-rep ##copy, ] parallel-mapping ] { } make ;
+
+<PRIVATE
+
+SYMBOL: temp-vregs
+
+: temp-vreg ( rep -- vreg )
+    temp-vregs get [ next-vreg-rep ] cache
+    [ leader-map get conjoin ] keep ;
+
+PRIVATE>
+
+: parallel-copy-rep ( mapping -- insns )
+    [
+        H{ } clone temp-vregs set
+        [ rep-of temp-vreg ] [ dup rep-of ##copy, ] parallel-mapping
+    ] { } make ;