2 module StackColor where
6 import qualified GraphColor as Color
10 import qualified GraphOps
22 LastNode l => (DualLive -> a -> a) -> BackwardTransfers m l DualLive -> LGraph m l
23 -> (BlockId -> DualLive) -> a -> a
24 fold_edge_facts_b f comp graph env z =
25 foldl fold_block_facts z (postorder_dfs graph)
27 fold_block_facts z b =
28 let (h, l) = goto_end (ZipCfg.unzip b)
29 last_in _ LastExit = fact_bot dualLiveLattice
30 last_in env (LastOther l) = bt_last_in comp l env
31 in head_fold h (last_in env l) z
32 head_fold (ZHead h m) out z = head_fold h (bt_middle_in comp m out) (f out z)
33 head_fold (ZFirst id) out z = f (bt_first_in comp id out) (f out z)
35 foldConflicts :: (RegSet -> a -> a) -> a -> LGraph Middle Last -> FuelMonad a
36 foldConflicts f z g@(LGraph entry _) =
37 do env <- dualLiveness emptyBlockSet g
38 let lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
39 f' dual z = f (on_stack dual) z
40 return $ fold_edge_facts_b f' (dualLiveTransfers entry emptyBlockSet) g lookup z
41 --let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> getAllFacts)
42 -- lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
43 -- f' dual z = f (on_stack dual) z
44 --in fold_edge_facts_b f' dualLiveness g lookup z
47 type IGraph = Color.Graph LocalReg SlotClass StackPlacement
48 type ClassCount = [(SlotClass, Int)]
50 buildIGraphAndCounts :: LGraph Middle Last -> FuelMonad (IGraph, ClassCount)
51 buildIGraphAndCounts g = igraph_and_counts
52 where igraph_and_counts = foldConflicts add (Color.initGraph, zero) g
53 zero = map (\c -> (c, 0)) allSlotClasses
54 add live (igraph, counts) = (graphAddConflictSet live igraph,
55 addSimulCounts (classCounts live) counts)
57 zipWith (\(c, n) (c', n') -> if c == c' then (c, max n n')
58 else panic "slot classes out of order")
59 classCounts regs = foldUniqSet addReg zero regs
61 let cls = slotClass reg in
62 map (\(c, n) -> (c, if c == cls then n + 1 else n)) counts
65 -- | Add some conflict edges to the graph.
66 -- Conflicts between virtual and real regs are recorded as exclusions.
69 graphAddConflictSet :: RegSet -> IGraph -> IGraph
70 graphAddConflictSet set graph = GraphOps.addConflicts set slotClass graph
72 slotClass :: LocalReg -> SlotClass
73 slotClass (LocalReg _ ty) =
74 case typeWidth ty of -- the horror, the horror
83 colorMe :: (IGraph, ClassCount) -> (IGraph, UniqSet LocalReg)
84 colorMe (igraph, counts) = Color.colorGraph starter_colors triv spill_max_degree igraph
85 where starter_colors = allocate [] counts allStackSlots
86 allocate prev [] colors = insert prev colors
87 allocate prev ((c, n) : counts) colors =
88 let go prev 0 colors = allocate prev counts colors
89 go prev n colors = let (p, colors') = getStackSlot c colors in
90 go (p:prev) (n-1) colors'
92 insert :: [StackPlacement] -> SlotSet -> SlotSet
93 insert [] colors = colors
94 insert (p:ps) colors = insert ps (extendSlotSet colors p)
95 triv :: Color.Triv LocalReg SlotClass StackPlacement
96 triv = trivColorable (mkSizeOf counts)
98 spill_max_degree :: IGraph -> LocalReg
99 spill_max_degree igraph = Color.nodeId node
100 where node = maximumBy (\n1 n2 -> compare
101 (sizeUniqSet $ Color.nodeConflicts n1)
102 (sizeUniqSet $ Color.nodeConflicts n2)) $
103 eltsUFM $ Color.graphMap igraph
106 type Worst = SlotClass -> (Int, Int, Int) -> Int
108 trivColorable :: (SlotClass -> Int) ->
109 SlotClass -> UniqSet LocalReg -> UniqSet StackPlacement -> Bool
110 trivColorable sizeOf classN conflicts exclusions = squeeze < sizeOf classN
111 where squeeze = worst classN counts
112 counts = if isEmptyUniqSet exclusions then foldUniqSet acc zero conflicts
113 else panic "exclusions in stack slots?!"
115 acc r (word, dbl, quad) =
117 SlotClass32 -> (word+1, dbl, quad)
118 SlotClass64 -> (word, dbl+1, quad)
119 SlotClass128 -> (word, dbl, quad+1)
120 worst SlotClass128 (_, _, q) = q
121 worst SlotClass64 (_, d, q) = d + 2 * q
122 worst SlotClass32 (w, d, q) = w + 2 * d + 4 * q
125 -- | number of placements available is from class and all larger classes
126 mkSizeOf :: ClassCount -> (SlotClass -> Int)
127 mkSizeOf counts = sizeOf
128 where sizeOf SlotClass32 = n32
129 sizeOf SlotClass64 = n64
130 sizeOf SlotClass128 = n128
131 n128 = (lookup SlotClass128 counts `orElse` 0)
132 n64 = (lookup SlotClass64 counts `orElse` 0) + 2 * n128
133 n32 = (lookup SlotClass32 counts `orElse` 0) + 2 * n32