X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FStackColor.hs;fp=compiler%2Fcmm%2FStackColor.hs;h=0000000000000000000000000000000000000000;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hp=bf5f9a0fdad05a4a0c6f1efd956de91f995f0ac6;hpb=f1a90f54590e5a7a32a9c3ef2950740922b1f425;p=ghc-hetmet.git

diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs
deleted file mode 100644
index bf5f9a0..0000000
--- a/compiler/cmm/StackColor.hs
+++ /dev/null
@@ -1,133 +0,0 @@
-
-module StackColor where
-
-import BlockId
-import StackPlacements
-import qualified GraphColor as Color
-import CmmExpr
-import CmmSpillReload
-import DFMonad
-import qualified GraphOps
-import ZipCfg
-import ZipCfgCmmRep
-import ZipDataflow
-
-import Maybes
-import Panic
-import UniqSet
-
--- 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)]
-
-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
-          add live (igraph, counts) = (graphAddConflictSet live igraph,
-                                       addSimulCounts (classCounts live) counts)
-          addSimulCounts =
-            zipWith (\(c, n) (c', n') -> if c == c' then (c, max n n')
-                                         else panic "slot classes out of order")
-          classCounts regs = foldUniqSet addReg zero regs
-          addReg reg counts =
-              let cls = slotClass reg in
-              map (\(c, n) -> (c, if c == cls then n + 1 else n)) counts
-                           
-
--- | Add some conflict edges to the graph.
---	Conflicts between virtual and real regs are recorded as exclusions.
---
-
-graphAddConflictSet :: RegSet -> IGraph -> IGraph
-graphAddConflictSet set graph = GraphOps.addConflicts set slotClass graph
-
-slotClass :: LocalReg -> SlotClass
-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, counts) = Color.colorGraph starter_colors triv spill_max_degree igraph
-    where starter_colors = allocate [] counts allStackSlots
-          allocate prev [] colors = insert prev colors
-          allocate prev ((c, n) : counts) colors =
-              let go prev 0 colors = allocate prev counts colors
-                  go prev n colors = let (p, colors') = getStackSlot c colors in
-                                     go (p:prev) (n-1) colors'
-              in  go prev n colors
-          insert :: [StackPlacement] -> SlotSet -> SlotSet
-          insert [] colors = colors
-          insert (p:ps) colors = insert ps (extendSlotSet colors p)
-          triv :: Color.Triv LocalReg SlotClass StackPlacement
-          triv = trivColorable (mkSizeOf counts)
-
-spill_max_degree :: IGraph -> LocalReg
-spill_max_degree igraph = Color.nodeId node
-    where node	= maximumBy (\n1 n2 -> compare 
- 				(sizeUniqSet $ Color.nodeConflicts n1) 
-				(sizeUniqSet $ Color.nodeConflicts n2)) $
- 		  eltsUFM $ Color.graphMap igraph
-
-
-type Worst = SlotClass -> (Int, Int, Int) -> Int
-
-trivColorable :: (SlotClass -> Int) -> 
-                 SlotClass -> UniqSet LocalReg -> UniqSet StackPlacement -> Bool
-trivColorable sizeOf classN conflicts exclusions = squeeze < sizeOf classN
-  where	squeeze = worst classN counts
-        counts   = if isEmptyUniqSet exclusions then foldUniqSet acc zero conflicts
-                   else panic "exclusions in stack slots?!"
-        zero = (0, 0, 0)
-	acc r (word, dbl, quad)	=
-            case slotClass r of
-              SlotClass32  -> (word+1, dbl, quad)
-              SlotClass64  -> (word, dbl+1, quad)
-              SlotClass128 -> (word, dbl, quad+1)
-        worst SlotClass128 (_, _, q) = q
-        worst SlotClass64  (_, d, q) = d + 2 * q
-        worst SlotClass32  (w, d, q) = w + 2 * d + 4 * q
--}
-
--- | number of placements available is from class and all larger classes
-mkSizeOf :: ClassCount -> (SlotClass -> Int)
-mkSizeOf counts = sizeOf
-    where sizeOf SlotClass32  = n32
-          sizeOf SlotClass64  = n64
-          sizeOf SlotClass128 = n128
-          n128 = (lookup SlotClass128 counts `orElse` 0)
-          n64  = (lookup SlotClass64  counts `orElse` 0) + 2 * n128
-          n32  = (lookup SlotClass32  counts `orElse` 0) + 2 * n32