Comments and Cmm notes

[ghc-hetmet.git] / compiler / cmm / StackColor.hs

diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs
index e3b6ba8..bf5f9a0 100644 (file)
--- a/compiler/cmm/StackColor.hs
+++ b/compiler/cmm/StackColor.hs
@@ -1,38 +1,53 @@
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+

 module StackColor where
 
 module StackColor where
 

+import BlockId

 import StackPlacements
 import qualified GraphColor as Color
 import CmmExpr
 import CmmSpillReload
 import DFMonad
 import qualified GraphOps
 import StackPlacements
 import qualified GraphColor as Color
 import CmmExpr
 import CmmSpillReload
 import DFMonad
 import qualified GraphOps

-import MachOp

 import ZipCfg
 import ZipCfg

-import ZipCfgCmm
+import ZipCfgCmmRep

 import ZipDataflow
 
 import Maybes
 import Panic
 import UniqSet
 
 import ZipDataflow
 
 import Maybes
 import Panic
 import UniqSet
 

-import Data.List
-
-type M = ExtendWithSpills Middle
-
-
-foldConflicts :: (RegSet -> a -> a) -> a -> LGraph M Last -> 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
+-- import Data.List
+
+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 l env
+      in head_fold h (last_in env l) z
+    head_fold (ZHead h m)   out z = head_fold h (bt_middle_in comp m out) (f out z)
+    head_fold (ZFirst id) out z = f (bt_first_in comp id out) (f out z)
+
+foldConflicts :: (RegSet -> a -> a) -> a -> LGraph Middle Last -> FuelMonad a
+foldConflicts f z g@(LGraph entry _) =
+  do env <- dualLiveness emptyBlockSet 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 entry 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)]
 
 
 
 type IGraph = Color.Graph LocalReg SlotClass StackPlacement
 type ClassCount = [(SlotClass, Int)]
 

-buildIGraphAndCounts :: LGraph M Last -> (IGraph, ClassCount)
+buildIGraphAndCounts :: LGraph Middle 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
 buildIGraphAndCounts g = igraph_and_counts
     where igraph_and_counts = foldConflicts add (Color.initGraph, zero) g
           zero = map (\c -> (c, 0)) allSlotClasses

@@ -55,16 +70,14 @@ graphAddConflictSet :: RegSet -> IGraph -> IGraph
 graphAddConflictSet set graph = GraphOps.addConflicts set slotClass graph
 
 slotClass :: LocalReg -> SlotClass
 graphAddConflictSet set graph = GraphOps.addConflicts set slotClass graph
 
 slotClass :: LocalReg -> SlotClass

-slotClass (LocalReg _ machRep _) = 
-    case machRep of -- the horror, the horror
-      I8   -> SlotClass32
-      I16  -> SlotClass32
-      I32  -> SlotClass32
-      I64  -> SlotClass64
-      I128 -> SlotClass128
-      F32  -> SlotClass32
-      F64  -> SlotClass64
-      F80  -> SlotClass64
+slotClass (LocalReg _ ty) = 
+    case typeWidth ty of -- the horror, the horror
+      W8   -> SlotClass32
+      W16  -> SlotClass32
+      W32  -> SlotClass32
+      W64  -> SlotClass64
+      W128 -> SlotClass128
+      W80  -> SlotClass64

 
 {-
 colorMe :: (IGraph, ClassCount) -> (IGraph, UniqSet LocalReg)
 
 {-
 colorMe :: (IGraph, ClassCount) -> (IGraph, UniqSet LocalReg)