+++ /dev/null
-
-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