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/Commentary/CodingStyle#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)
280 -> (Graph k cls color, [(k, k)])
282 coalesceGraph triv graph
284 -- find all the nodes that have coalescence edges
285 cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
286 $ eltsUFM $ graphMap graph
288 -- build a list of pairs of keys for node's we'll try and coalesce
289 -- every pair of nodes will appear twice in this list
290 -- ie [(k1, k2), (k2, k1) ... ]
291 -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for
292 -- build a list of what nodes get coalesced together for later on.
294 cList = [ (nodeId node1, k2)
296 , k2 <- uniqSetToList $ nodeCoalesce node1 ]
298 -- do the coalescing, returning the new graph and a list of pairs of keys
299 -- that got coalesced together.
301 = mapAccumL (coalesceNodes False triv) graph cList
303 in (graph', catMaybes mPairs)
306 -- | Coalesce this pair of nodes unconditionally / agressively.
307 -- The resulting node is the one with the least key.
309 -- returns: Just the pair of keys if the nodes were coalesced
310 -- the second element of the pair being the least one
312 -- Nothing if either of the nodes weren't in the graph
315 :: (Uniquable k, Ord k, Eq cls, Outputable k)
316 => Bool -- ^ If True, coalesce nodes even if this might make the graph
317 -- less colorable (aggressive coalescing)
320 -> (k, k) -- ^ keys of the nodes to be coalesced
321 -> (Graph k cls color, Maybe (k, k))
323 coalesceNodes aggressive triv graph (k1, k2)
324 | (kMin, kMax) <- if k1 < k2
328 -- the nodes being coalesced must be in the graph
329 , Just nMin <- lookupNode graph kMin
330 , Just nMax <- lookupNode graph kMax
332 -- can't coalesce conflicting modes
333 , not $ elementOfUniqSet kMin (nodeConflicts nMax)
334 , not $ elementOfUniqSet kMax (nodeConflicts nMin)
336 = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
338 -- don't do the coalescing after all
342 coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
345 | nodeClass nMin /= nodeClass nMax
346 = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
348 | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
349 = error "GraphOps.coalesceNodes: can't coalesce colored nodes."
354 -- the new node gets all the edges from its two components
357 , nodeClass = nodeClass nMin
358 , nodeColor = Nothing
360 -- nodes don't conflict with themselves..
362 = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
363 `delOneFromUniqSet` kMin
364 `delOneFromUniqSet` kMax
366 , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
367 , nodePreference = nodePreference nMin ++ nodePreference nMax
369 -- nodes don't coalesce with themselves..
371 = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
372 `delOneFromUniqSet` kMin
373 `delOneFromUniqSet` kMax
376 in coalesceNodes_check aggressive triv graph kMin kMax node
378 coalesceNodes_check aggressive triv graph kMin kMax node
380 -- Unless we're coalescing aggressively, if the result node is not trivially
381 -- colorable then don't do the coalescing.
383 , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
387 = let -- delete the old nodes from the graph and add the new one
388 graph' = addNode kMin node
393 in (graph', Just (kMax, kMin))
396 -- | validate the internal structure of a graph
397 -- all its edges should point to valid nodes
398 -- if they don't then throw an error
401 :: (Uniquable k, Outputable k)
406 validateGraph doc graph
407 = let edges = unionUniqSets
409 (map nodeConflicts $ eltsUFM $ graphMap graph))
411 (map nodeCoalesce $ eltsUFM $ graphMap graph))
413 nodes = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
415 badEdges = minusUniqSet edges nodes
417 in if isEmptyUniqSet badEdges
419 else pprPanic "GraphOps.validateGraph"
420 ( text "-- bad edges"
421 $$ vcat (map ppr $ uniqSetToList badEdges)
422 $$ text "----------------------------"
426 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
428 slurpNodeConflictCount
431 -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts)
433 slurpNodeConflictCount graph
435 (\(c1, n1) (c2, n2) -> (c1, n1 + n2))
438 -> let count = sizeUniqSet $ nodeConflicts node
439 in (count, (count, 1)))
444 -- | Set the color of a certain node
448 -> Graph k cls color -> Graph k cls color
453 (\n -> n { nodeColor = Just color })
459 => (a -> a) -> a -> k
460 -> UniqFM a -> UniqFM a
462 adjustWithDefaultUFM f def k map
472 -> k -> UniqFM a -> UniqFM a
475 = case lookupUFM map k of
477 Just a -> addToUFM map k (f a)