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,
22 slurpNodeConflictCount
33 import Data.List hiding (union)
37 -- | Lookup a node from the graph.
41 -> k -> Maybe (Node k cls color)
44 = lookupUFM (graphMap graph) k
47 -- | Get a node from the graph, throwing an error if it's not there
51 -> k -> Node k cls color
54 = case lookupUFM (graphMap graph) k of
56 Nothing -> panic "ColorOps.getNode: not found"
59 -- | Add a node to the graph, linking up its edges
60 addNode :: Uniquable k
61 => k -> Node k cls color
62 -> Graph k cls color -> Graph k cls color
66 -- add back conflict edges from other nodes to this one
69 (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
73 -- add back coalesce edges from other nodes to this one
76 (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
81 { graphMap = addToUFM map_coalesce k node}
85 -- | Delete a node and all its edges from the graph.
86 -- Throws an error if it's not there.
87 delNode :: Uniquable k
88 => k -> Graph k cls color -> Graph k cls color
91 = let Just node = lookupNode graph k
93 -- delete conflict edges from other nodes to this one.
94 graph1 = foldl' (\g k1 -> delConflict k1 k g) graph
95 $ uniqSetToList (nodeConflicts node)
97 -- delete coalesce edge from other nodes to this one.
98 graph2 = foldl' (\g k1 -> delCoalesce k1 k g) graph1
99 $ uniqSetToList (nodeCoalesce node)
102 graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2
107 -- | Modify a node in the graph
108 modNode :: Uniquable k
109 => (Node k cls color -> Node k cls color)
110 -> k -> Graph k cls color -> Graph k cls color
113 = case getNode graph k of
114 Node{} -> graphMapModify
115 (\fm -> let Just node = lookupUFM fm k
117 in addToUFM fm k node')
121 -- | Get the size of the graph, O(n)
123 => Graph k cls color -> Int
126 = sizeUFM $ graphMap graph
129 -- | Union two graphs together.
131 => Graph k cls color -> Graph k cls color -> Graph k cls color
135 { graphMap = plusUFM (graphMap graph1) (graphMap graph2) }
140 -- | Add a conflict between nodes to the graph, creating the nodes required.
141 -- Conflicts are virtual regs which need to be colored differently.
144 => (k, cls) -> (k, cls)
145 -> Graph k cls color -> Graph k cls color
147 addConflict (u1, c1) (u2, c2)
148 = let addNeighbor u c u'
149 = adjustWithDefaultUFM
150 (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
151 (newNode u c) { nodeConflicts = unitUniqSet u' }
155 ( addNeighbor u1 c1 u2
156 . addNeighbor u2 c2 u1)
159 -- | Delete a conflict edge. k1 -> k2
163 -> Graph k cls color -> 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 -> 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 -- | Verify the internal structure of a graph
265 -- all its edges should point to valid nodes
267 verify :: Uniquable k
272 = let edges = unionUniqSets
274 (map nodeConflicts $ eltsUFM $ graphMap graph))
276 (map nodeCoalesce $ eltsUFM $ graphMap graph))
278 nodes = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
280 badEdges = minusUniqSet edges nodes
282 in if isEmptyUniqSet badEdges
287 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
289 slurpNodeConflictCount
292 -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts)
294 slurpNodeConflictCount graph
296 (\(c1, n1) (c2, n2) -> (c1, n1 + n2))
299 -> let count = sizeUniqSet $ nodeConflicts node
300 in (count, (count, 1)))
305 -- | Set the color of a certain node
309 -> Graph k cls color -> Graph k cls color
314 (\n -> n { nodeColor = Just color })
320 => (a -> a) -> a -> k
321 -> UniqFM a -> UniqFM a
323 adjustWithDefaultUFM f def k map
333 -> k -> UniqFM a -> UniqFM a
336 = case lookupUFM map k of
338 Just a -> addToUFM map k (f a)