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