2 -- | Basic operations on graphs.
6 -- The above warning supression flag is a temporary kludge.
7 -- While working on this module you are encouraged to remove it and fix
8 -- any warnings in the module. See
9 -- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
13 addNode, delNode, getNode, lookupNode, modNode,
16 addConflict, delConflict, addConflicts,
17 addCoalesce, delCoalesce,
24 slurpNodeConflictCount
35 import Data.List hiding (union)
39 -- | Lookup a node from the graph.
43 -> k -> Maybe (Node k cls color)
46 = lookupUFM (graphMap graph) k
49 -- | Get a node from the graph, throwing an error if it's not there
53 -> k -> Node k cls color
56 = case lookupUFM (graphMap graph) k of
58 Nothing -> panic "ColorOps.getNode: not found"
61 -- | Add a node to the graph, linking up its edges
62 addNode :: Uniquable k
63 => k -> Node k cls color
64 -> Graph k cls color -> Graph k cls color
68 -- add back conflict edges from other nodes to this one
71 (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
75 -- add back coalesce edges from other nodes to this one
78 (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
83 { graphMap = addToUFM map_coalesce k node}
87 -- | Delete a node and all its edges from the graph.
88 -- Throws an error if it's not there.
89 delNode :: Uniquable k
90 => k -> Graph k cls color -> Graph k cls color
93 = let Just node = lookupNode graph k
95 -- delete conflict edges from other nodes to this one.
96 graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
97 $ uniqSetToList (nodeConflicts node)
99 -- delete coalesce edge from other nodes to this one.
100 graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
101 $ uniqSetToList (nodeCoalesce node)
104 graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2
109 -- | Modify a node in the graph.
110 -- returns Nothing if the node isn't present.
112 modNode :: Uniquable k
113 => (Node k cls color -> Node k cls color)
114 -> k -> Graph k cls color -> Maybe (Graph k cls color)
117 = case lookupNode graph k of
121 (\fm -> let Just node = lookupUFM fm k
123 in addToUFM fm k node')
128 -- | Get the size of the graph, O(n)
130 => Graph k cls color -> Int
133 = sizeUFM $ graphMap graph
136 -- | Union two graphs together.
138 => Graph k cls color -> Graph k cls color -> Graph k cls color
142 { graphMap = plusUFM (graphMap graph1) (graphMap graph2) }
147 -- | Add a conflict between nodes to the graph, creating the nodes required.
148 -- Conflicts are virtual regs which need to be colored differently.
151 => (k, cls) -> (k, cls)
152 -> Graph k cls color -> Graph k cls color
154 addConflict (u1, c1) (u2, c2)
155 = let addNeighbor u c u'
156 = adjustWithDefaultUFM
157 (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
158 (newNode u c) { nodeConflicts = unitUniqSet u' }
162 ( addNeighbor u1 c1 u2
163 . addNeighbor u2 c2 u1)
166 -- | Delete a conflict edge. k1 -> k2
167 -- returns Nothing if the node isn't in the graph
171 -> Graph k cls color -> Maybe (Graph k cls color)
175 (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
179 -- | Add some conflicts to the graph, creating nodes if required.
180 -- All the nodes in the set are taken to conflict with each other.
183 => UniqSet k -> (k -> cls)
184 -> Graph k cls color -> Graph k cls color
186 addConflicts conflicts getClass
188 -- just a single node, but no conflicts, create the node anyway.
189 | (u : []) <- uniqSetToList conflicts
191 $ adjustWithDefaultUFM
193 (newNode u (getClass u))
198 $ (\fm -> foldr (\u -> addConflictSet1 u getClass conflicts) fm
199 $ uniqSetToList conflicts)
202 addConflictSet1 u getClass set
203 = let set' = delOneFromUniqSet set u
204 in adjustWithDefaultUFM
205 (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
206 (newNode u (getClass u)) { nodeConflicts = set' }
210 -- | Add an exclusion to the graph, creating nodes if required.
211 -- These are extra colors that the node cannot use.
213 :: (Uniquable k, Uniquable color)
214 => k -> (k -> cls) -> color
215 -> Graph k cls color -> Graph k cls color
217 addExclusion u getClass color
219 $ adjustWithDefaultUFM
220 (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
221 (newNode u (getClass u)) { nodeExclusions = unitUniqSet color }
225 -- | Add a coalescence edge to the graph, creating nodes if requried.
226 -- It is considered adventageous to assign the same color to nodes in a coalesence.
229 => (k, cls) -> (k, cls)
230 -> Graph k cls color -> Graph k cls color
232 addCoalesce (u1, c1) (u2, c2)
233 = let addCoalesce u c u'
234 = adjustWithDefaultUFM
235 (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
236 (newNode u c) { nodeCoalesce = unitUniqSet u' }
240 ( addCoalesce u1 c1 u2
241 . addCoalesce u2 c2 u1)
244 -- | Delete a coalescence edge (k1 -> k2) from the graph.
248 -> Graph k cls color -> Maybe (Graph k cls color)
251 = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
255 -- | Add a color preference to the graph, creating nodes if required.
256 -- The most recently added preference is the most prefered.
257 -- The algorithm tries to assign a node it's prefered color if possible.
262 -> Graph k cls color -> Graph k cls color
264 addPreference (u, c) color
266 $ adjustWithDefaultUFM
267 (\node -> node { nodePreference = color : (nodePreference node) })
268 (newNode u c) { nodePreference = [color] }
272 -- | Do agressive coalescing on this graph.
273 -- returns the new graph and the list of pairs of nodes that got coaleced together.
274 -- for each pair, the resulting node will have the least key and be second in the pair.
277 :: (Uniquable k, Ord k, Eq cls, Outputable k)
279 -> (Graph k cls color, [(k, k)])
283 -- find all the nodes that have coalescence edges
284 cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
285 $ eltsUFM $ graphMap graph
287 -- build a list of pairs of keys for node's we'll try and coalesce
288 -- every pair of nodes will appear twice in this list
289 -- ie [(k1, k2), (k2, k1) ... ]
290 -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for
291 -- build a list of what nodes get coalesced together for later on.
293 cList = [ (nodeId node1, k2)
295 , k2 <- uniqSetToList $ nodeCoalesce node1 ]
297 -- do the coalescing, returning the new graph and a list of pairs of keys
298 -- that got coalesced together.
300 = mapAccumL coalesceNodes graph cList
302 in (graph', catMaybes mPairs)
305 -- | Coalesce this pair of nodes unconditionally / agressively.
306 -- The resulting node is the one with the least key.
308 -- returns: Just the pair of keys if the nodes were coalesced
309 -- the second element of the pair being the least one
311 -- Nothing if either of the nodes weren't in the graph
314 :: (Uniquable k, Ord k, Eq cls, Outputable k)
316 -> (k, k) -- ^ keys of the nodes to be coalesced
317 -> (Graph k cls color, Maybe (k, k))
319 coalesceNodes graph (k1, k2)
320 | (kMin, kMax) <- if k1 < k2
324 -- nodes must be in the graph
325 , Just nMin <- lookupNode graph kMin
326 , Just nMax <- lookupNode graph kMax
328 -- can't coalesce conflicting nodes
329 , not $ elementOfUniqSet kMin (nodeConflicts nMax)
330 , not $ elementOfUniqSet kMax (nodeConflicts nMin)
332 = coalesceNodes' graph kMin kMax nMin nMax
336 -- one of the nodes wasn't in the graph anymore
340 coalesceNodes' graph kMin kMax nMin nMax
343 | nodeClass nMin /= nodeClass nMax
344 = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
346 | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
347 = error "GraphOps.coalesceNodes: can't coalesce colored nodes."
352 -- the new node gets all the edges from its two components
355 , nodeClass = nodeClass nMin
356 , nodeColor = Nothing
358 -- nodes don't conflict with themselves..
360 = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
361 `delOneFromUniqSet` kMin
362 `delOneFromUniqSet` kMax
364 , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
365 , nodePreference = nodePreference nMin ++ nodePreference nMax
367 -- nodes don't coalesce with themselves..
369 = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
370 `delOneFromUniqSet` kMin
371 `delOneFromUniqSet` kMax
374 -- delete the old nodes from the graph and add the new one
375 graph' = addNode kMin node
380 in (graph', Just (kMax, kMin))
383 -- | validate the internal structure of a graph
384 -- all its edges should point to valid nodes
385 -- if they don't then throw an error
388 :: (Uniquable k, Outputable k)
393 validateGraph doc graph
394 = let edges = unionUniqSets
396 (map nodeConflicts $ eltsUFM $ graphMap graph))
398 (map nodeCoalesce $ eltsUFM $ graphMap graph))
400 nodes = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
402 badEdges = minusUniqSet edges nodes
404 in if isEmptyUniqSet badEdges
406 else pprPanic "GraphOps.validateGraph"
407 ( text "-- bad edges"
408 $$ vcat (map ppr $ uniqSetToList badEdges)
409 $$ text "----------------------------"
413 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
415 slurpNodeConflictCount
418 -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts)
420 slurpNodeConflictCount graph
422 (\(c1, n1) (c2, n2) -> (c1, n1 + n2))
425 -> let count = sizeUniqSet $ nodeConflicts node
426 in (count, (count, 1)))
431 -- | Set the color of a certain node
435 -> Graph k cls color -> Graph k cls color
440 (\n -> n { nodeColor = Just color })
446 => (a -> a) -> a -> k
447 -> UniqFM a -> UniqFM a
449 adjustWithDefaultUFM f def k map
459 -> k -> UniqFM a -> UniqFM a
462 = case lookupUFM map k of
464 Just a -> addToUFM map k (f a)