X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FStackColor.hs;h=4d544bdbc870bfde10e195c3718dda81766e3127;hb=0f5e104c36b1dc3d8deeec5fef3d65e7b3a1b5ad;hp=2f97a1887751c58be131ae60b0cbef055c51b761;hpb=1241c26f3552a2037263769e5ef7fa68d9f3be36;p=ghc-hetmet.git

diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs
index 2f97a18..4d544bd 100644
--- a/compiler/cmm/StackColor.hs
+++ b/compiler/cmm/StackColor.hs
@@ -1,6 +1,7 @@
 
 module StackColor where
 
+import BlockId
 import StackPlacements
 import qualified GraphColor as Color
 import CmmExpr
@@ -20,19 +21,36 @@ import Data.List
 
 type M = ExtendWithSpills Middle
 
-
-foldConflicts :: (RegSet -> a -> a) -> a -> LGraph M Last -> a
+fold_edge_facts_b ::
+  LastNode l => (DualLive -> a -> a) -> BackwardTransfers m l DualLive -> LGraph m l
+                                     -> (BlockId -> DualLive) -> a -> a
+fold_edge_facts_b f comp graph env z =
+    foldl fold_block_facts z (postorder_dfs graph)
+  where
+    fold_block_facts z b =              
+      let (h, l) = goto_end (ZipCfg.unzip b) 
+          last_in _ LastExit = fact_bot dualLiveLattice
+          last_in env (LastOther l) = bt_last_in comp env l
+      in head_fold h (last_in env l) z
+    head_fold (ZHead h m) out z = head_fold h (bt_middle_in comp out m) (f out z)
+    head_fold (ZFirst id) out z = f (bt_first_in comp out id) (f out z)
+
+foldConflicts :: (RegSet -> a -> a) -> a -> LGraph M Last -> FuelMonad a
 foldConflicts f z g =
-  let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> allFacts)
-      lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
-      f' dual z = f (on_stack dual) z
-  in  fold_edge_facts_b f' dualLiveness g lookup z
+  do env <- dualLiveness emptyBlockSet $ graphOfLGraph g
+     let lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
+         f' dual z = f (on_stack dual) z
+     return $ fold_edge_facts_b f' (dualLiveTransfers emptyBlockSet) g lookup z
+  --let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> getAllFacts)
+  --    lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
+  --    f' dual z = f (on_stack dual) z
+  --in  fold_edge_facts_b f' dualLiveness g lookup z
 
 
 type IGraph = Color.Graph LocalReg SlotClass StackPlacement
 type ClassCount = [(SlotClass, Int)]
 
-buildIGraphAndCounts :: LGraph M Last -> (IGraph, ClassCount)
+buildIGraphAndCounts :: LGraph M Last -> FuelMonad (IGraph, ClassCount)
 buildIGraphAndCounts g = igraph_and_counts
     where igraph_and_counts = foldConflicts add (Color.initGraph, zero) g
           zero = map (\c -> (c, 0)) allSlotClasses