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
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
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
graphAddConflictSet :: RegSet -> IGraph -> IGraph
graphAddConflictSet set graph = GraphOps.addConflicts set slotClass graph
slotClass :: LocalReg -> SlotClass
slotClass (LocalReg _ ty) =
case typeWidth ty of
W8 -> SlotClass32
W16 -> SlotClass32
W32 -> SlotClass32
W64 -> SlotClass64
W128 -> SlotClass128
W80 -> SlotClass64
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