1 -- | Basic operations on graphs.
3 {-# OPTIONS -fno-warn-missing-signatures #-}
6 addNode, delNode, getNode, lookupNode, modNode,
9 addConflict, delConflict, addConflicts,
10 addCoalesce, delCoalesce,
17 slurpNodeConflictCount
28 import Data.List hiding (union)
31 -- | Lookup a node from the graph.
35 -> k -> Maybe (Node k cls color)
38 = lookupUFM (graphMap graph) k
41 -- | Get a node from the graph, throwing an error if it's not there
45 -> k -> Node k cls color
48 = case lookupUFM (graphMap graph) k of
50 Nothing -> panic "ColorOps.getNode: not found"
53 -- | Add a node to the graph, linking up its edges
54 addNode :: Uniquable k
55 => k -> Node k cls color
56 -> Graph k cls color -> Graph k cls color
60 -- add back conflict edges from other nodes to this one
63 (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
67 -- add back coalesce edges from other nodes to this one
70 (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
75 { graphMap = addToUFM map_coalesce k node}
79 -- | Delete a node and all its edges from the graph.
80 -- Throws an error if it's not there.
81 delNode :: Uniquable k
82 => k -> Graph k cls color -> Graph k cls color
85 = let Just node = lookupNode graph k
87 -- delete conflict edges from other nodes to this one.
88 graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
89 $ uniqSetToList (nodeConflicts node)
91 -- delete coalesce edge from other nodes to this one.
92 graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
93 $ uniqSetToList (nodeCoalesce node)
96 graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2
101 -- | Modify a node in the graph.
102 -- returns Nothing if the node isn't present.
104 modNode :: Uniquable k
105 => (Node k cls color -> Node k cls color)
106 -> k -> Graph k cls color -> Maybe (Graph k cls color)
109 = case lookupNode graph k of
113 (\fm -> let Just node = lookupUFM fm k
115 in addToUFM fm k node')
120 -- | Get the size of the graph, O(n)
122 => Graph k cls color -> Int
125 = sizeUFM $ graphMap graph
128 -- | Union two graphs together.
130 => Graph k cls color -> Graph k cls color -> Graph k cls color
134 { graphMap = plusUFM (graphMap graph1) (graphMap graph2) }
139 -- | Add a conflict between nodes to the graph, creating the nodes required.
140 -- Conflicts are virtual regs which need to be colored differently.
143 => (k, cls) -> (k, cls)
144 -> Graph k cls color -> Graph k cls color
146 addConflict (u1, c1) (u2, c2)
147 = let addNeighbor u c u'
148 = adjustWithDefaultUFM
149 (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
150 (newNode u c) { nodeConflicts = unitUniqSet u' }
154 ( addNeighbor u1 c1 u2
155 . addNeighbor u2 c2 u1)
158 -- | Delete a conflict edge. k1 -> k2
159 -- returns Nothing if the node isn't in the graph
163 -> Graph k cls color -> Maybe (Graph k cls color)
167 (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
171 -- | Add some conflicts to the graph, creating nodes if required.
172 -- All the nodes in the set are taken to conflict with each other.
175 => UniqSet k -> (k -> cls)
176 -> Graph k cls color -> Graph k cls color
178 addConflicts conflicts getClass
180 -- just a single node, but no conflicts, create the node anyway.
181 | (u : []) <- uniqSetToList conflicts
183 $ adjustWithDefaultUFM
185 (newNode u (getClass u))
190 $ (\fm -> foldr (\u -> addConflictSet1 u getClass conflicts) fm
191 $ uniqSetToList conflicts)
194 addConflictSet1 u getClass set
195 = let set' = delOneFromUniqSet set u
196 in adjustWithDefaultUFM
197 (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
198 (newNode u (getClass u)) { nodeConflicts = set' }
202 -- | Add an exclusion to the graph, creating nodes if required.
203 -- These are extra colors that the node cannot use.
205 :: (Uniquable k, Uniquable color)
206 => k -> (k -> cls) -> color
207 -> Graph k cls color -> Graph k cls color
209 addExclusion u getClass color
211 $ adjustWithDefaultUFM
212 (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
213 (newNode u (getClass u)) { nodeExclusions = unitUniqSet color }
217 -- | Add a coalescence edge to the graph, creating nodes if requried.
218 -- It is considered adventageous to assign the same color to nodes in a coalesence.
221 => (k, cls) -> (k, cls)
222 -> Graph k cls color -> Graph k cls color
224 addCoalesce (u1, c1) (u2, c2)
225 = let addCoalesce u c u'
226 = adjustWithDefaultUFM
227 (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
228 (newNode u c) { nodeCoalesce = unitUniqSet u' }
232 ( addCoalesce u1 c1 u2
233 . addCoalesce u2 c2 u1)
236 -- | Delete a coalescence edge (k1 -> k2) from the graph.
240 -> Graph k cls color -> Maybe (Graph k cls color)
243 = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
247 -- | Add a color preference to the graph, creating nodes if required.
248 -- The most recently added preference is the most prefered.
249 -- The algorithm tries to assign a node it's prefered color if possible.
254 -> Graph k cls color -> Graph k cls color
256 addPreference (u, c) color
258 $ adjustWithDefaultUFM
259 (\node -> node { nodePreference = color : (nodePreference node) })
260 (newNode u c) { nodePreference = [color] }
264 -- | Do agressive coalescing on this graph.
265 -- returns the new graph and the list of pairs of nodes that got coaleced together.
266 -- for each pair, the resulting node will have the least key and be second in the pair.
269 :: (Uniquable k, Ord k, Eq cls, Outputable k)
272 -> (Graph k cls color, [(k, k)])
274 coalesceGraph triv graph
276 -- find all the nodes that have coalescence edges
277 cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
278 $ eltsUFM $ graphMap graph
280 -- build a list of pairs of keys for node's we'll try and coalesce
281 -- every pair of nodes will appear twice in this list
282 -- ie [(k1, k2), (k2, k1) ... ]
283 -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for
284 -- build a list of what nodes get coalesced together for later on.
286 cList = [ (nodeId node1, k2)
288 , k2 <- uniqSetToList $ nodeCoalesce node1 ]
290 -- do the coalescing, returning the new graph and a list of pairs of keys
291 -- that got coalesced together.
293 = mapAccumL (coalesceNodes False triv) graph cList
295 in (graph', catMaybes mPairs)
298 -- | Coalesce this pair of nodes unconditionally / agressively.
299 -- The resulting node is the one with the least key.
301 -- returns: Just the pair of keys if the nodes were coalesced
302 -- the second element of the pair being the least one
304 -- Nothing if either of the nodes weren't in the graph
307 :: (Uniquable k, Ord k, Eq cls, Outputable k)
308 => Bool -- ^ If True, coalesce nodes even if this might make the graph
309 -- less colorable (aggressive coalescing)
312 -> (k, k) -- ^ keys of the nodes to be coalesced
313 -> (Graph k cls color, Maybe (k, k))
315 coalesceNodes aggressive triv graph (k1, k2)
316 | (kMin, kMax) <- if k1 < k2
320 -- the nodes being coalesced must be in the graph
321 , Just nMin <- lookupNode graph kMin
322 , Just nMax <- lookupNode graph kMax
324 -- can't coalesce conflicting modes
325 , not $ elementOfUniqSet kMin (nodeConflicts nMax)
326 , not $ elementOfUniqSet kMax (nodeConflicts nMin)
328 = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
330 -- don't do the coalescing after all
334 coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
337 | nodeClass nMin /= nodeClass nMax
338 = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
340 | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
341 = error "GraphOps.coalesceNodes: can't coalesce colored nodes."
346 -- the new node gets all the edges from its two components
349 , nodeClass = nodeClass nMin
350 , nodeColor = Nothing
352 -- nodes don't conflict with themselves..
354 = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
355 `delOneFromUniqSet` kMin
356 `delOneFromUniqSet` kMax
358 , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
359 , nodePreference = nodePreference nMin ++ nodePreference nMax
361 -- nodes don't coalesce with themselves..
363 = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
364 `delOneFromUniqSet` kMin
365 `delOneFromUniqSet` kMax
368 in coalesceNodes_check aggressive triv graph kMin kMax node
370 coalesceNodes_check aggressive triv graph kMin kMax node
372 -- Unless we're coalescing aggressively, if the result node is not trivially
373 -- colorable then don't do the coalescing.
375 , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
379 = let -- delete the old nodes from the graph and add the new one
380 graph' = addNode kMin node
385 in (graph', Just (kMax, kMin))
388 -- | validate the internal structure of a graph
389 -- all its edges should point to valid nodes
390 -- if they don't then throw an error
393 :: (Uniquable k, Outputable k)
398 validateGraph doc graph
399 = let edges = unionUniqSets
401 (map nodeConflicts $ eltsUFM $ graphMap graph))
403 (map nodeCoalesce $ eltsUFM $ graphMap graph))
405 nodes = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
407 badEdges = minusUniqSet edges nodes
409 in if isEmptyUniqSet badEdges
411 else pprPanic "GraphOps.validateGraph"
412 ( text "-- bad edges"
413 $$ vcat (map ppr $ uniqSetToList badEdges)
414 $$ text "----------------------------"
418 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
420 slurpNodeConflictCount
423 -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts)
425 slurpNodeConflictCount graph
427 (\(c1, n1) (_, n2) -> (c1, n1 + n2))
430 -> let count = sizeUniqSet $ nodeConflicts node
431 in (count, (count, 1)))
436 -- | Set the color of a certain node
440 -> Graph k cls color -> Graph k cls color
445 (\n -> n { nodeColor = Just color })
449 {-# INLINE adjustWithDefaultUFM #-}
452 => (a -> a) -> a -> k
453 -> UniqFM a -> UniqFM a
455 adjustWithDefaultUFM f def k map
461 {-# INLINE adjustUFM #-}
465 -> k -> UniqFM a -> UniqFM a
468 = case lookupUFM map k of
470 Just a -> addToUFM map k (f a)