1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
2 module StackColor where
5 import qualified GraphColor as Color
9 import qualified GraphOps
21 type M = ExtendWithSpills Middle
24 foldConflicts :: (RegSet -> a -> a) -> a -> LGraph M Last -> a
26 let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> allFacts)
27 lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
28 f' dual z = f (on_stack dual) z
29 in fold_edge_facts_b f' dualLiveness g lookup z
32 type IGraph = Color.Graph LocalReg SlotClass StackPlacement
33 type ClassCount = [(SlotClass, Int)]
35 buildIGraphAndCounts :: LGraph M Last -> (IGraph, ClassCount)
36 buildIGraphAndCounts g = igraph_and_counts
37 where igraph_and_counts = foldConflicts add (Color.initGraph, zero) g
38 zero = map (\c -> (c, 0)) allSlotClasses
39 add live (igraph, counts) = (graphAddConflictSet live igraph,
40 addSimulCounts (classCounts live) counts)
42 zipWith (\(c, n) (c', n') -> if c == c' then (c, max n n')
43 else panic "slot classes out of order")
44 classCounts regs = foldUniqSet addReg zero regs
46 let cls = slotClass reg in
47 map (\(c, n) -> (c, if c == cls then n + 1 else n)) counts
50 -- | Add some conflict edges to the graph.
51 -- Conflicts between virtual and real regs are recorded as exclusions.
54 graphAddConflictSet :: RegSet -> IGraph -> IGraph
55 graphAddConflictSet set graph = GraphOps.addConflicts set slotClass graph
57 slotClass :: LocalReg -> SlotClass
58 slotClass (LocalReg _ machRep _) =
59 case machRep of -- the horror, the horror
70 colorMe :: (IGraph, ClassCount) -> (IGraph, UniqSet LocalReg)
71 colorMe (igraph, counts) = Color.colorGraph starter_colors triv spill_max_degree igraph
72 where starter_colors = allocate [] counts allStackSlots
73 allocate prev [] colors = insert prev colors
74 allocate prev ((c, n) : counts) colors =
75 let go prev 0 colors = allocate prev counts colors
76 go prev n colors = let (p, colors') = getStackSlot c colors in
77 go (p:prev) (n-1) colors'
79 insert :: [StackPlacement] -> SlotSet -> SlotSet
80 insert [] colors = colors
81 insert (p:ps) colors = insert ps (extendSlotSet colors p)
82 triv :: Color.Triv LocalReg SlotClass StackPlacement
83 triv = trivColorable (mkSizeOf counts)
85 spill_max_degree :: IGraph -> LocalReg
86 spill_max_degree igraph = Color.nodeId node
87 where node = maximumBy (\n1 n2 -> compare
88 (sizeUniqSet $ Color.nodeConflicts n1)
89 (sizeUniqSet $ Color.nodeConflicts n2)) $
90 eltsUFM $ Color.graphMap igraph
93 type Worst = SlotClass -> (Int, Int, Int) -> Int
95 trivColorable :: (SlotClass -> Int) ->
96 SlotClass -> UniqSet LocalReg -> UniqSet StackPlacement -> Bool
97 trivColorable sizeOf classN conflicts exclusions = squeeze < sizeOf classN
98 where squeeze = worst classN counts
99 counts = if isEmptyUniqSet exclusions then foldUniqSet acc zero conflicts
100 else panic "exclusions in stack slots?!"
102 acc r (word, dbl, quad) =
104 SlotClass32 -> (word+1, dbl, quad)
105 SlotClass64 -> (word, dbl+1, quad)
106 SlotClass128 -> (word, dbl, quad+1)
107 worst SlotClass128 (_, _, q) = q
108 worst SlotClass64 (_, d, q) = d + 2 * q
109 worst SlotClass32 (w, d, q) = w + 2 * d + 4 * q
112 -- | number of placements available is from class and all larger classes
113 mkSizeOf :: ClassCount -> (SlotClass -> Int)
114 mkSizeOf counts = sizeOf
115 where sizeOf SlotClass32 = n32
116 sizeOf SlotClass64 = n64
117 sizeOf SlotClass128 = n128
118 n128 = (lookup SlotClass128 counts `orElse` 0)
119 n64 = (lookup SlotClass64 counts `orElse` 0) + 2 * n128
120 n32 = (lookup SlotClass32 counts `orElse` 0) + 2 * n32