2 -- | Basic operations on graphs.
5 addNode, delNode, getNode, lookupNode, modNode,
8 addConflict, delConflict, addConflicts,
9 addCoalesce, delCoalesce,
14 slurpNodeConflictCount
25 import Data.List hiding (union)
29 -- | Lookup a node from the graph.
33 -> k -> Maybe (Node k cls color)
36 = lookupUFM (graphMap graph) k
39 -- | Get a node from the graph, throwing an error if it's not there
43 -> k -> Node k cls color
46 = case lookupUFM (graphMap graph) k of
48 Nothing -> panic "ColorOps.getNode: not found"
51 -- | Add a node to the graph, linking up its edges
52 addNode :: Uniquable k
53 => k -> Node k cls color
54 -> Graph k cls color -> Graph k cls color
58 -- add back conflict edges from other nodes to this one
61 (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
65 -- add back coalesce edges from other nodes to this one
68 (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
73 { graphMap = addToUFM map_coalesce k node}
77 -- | Delete a node and all its edges from the graph.
78 -- Throws an error if it's not there.
79 delNode :: Uniquable k
80 => k -> Graph k cls color -> Graph k cls color
83 = let Just node = lookupNode graph k
85 -- delete conflict edges from other nodes to this one.
86 graph1 = foldl' (\g k1 -> delConflict k1 k g) graph
87 $ uniqSetToList (nodeConflicts node)
89 -- delete coalesce edge from other nodes to this one.
90 graph2 = foldl' (\g k1 -> delCoalesce k1 k g) graph1
91 $ uniqSetToList (nodeCoalesce node)
94 graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2
99 -- | Modify a node in the graph
100 modNode :: Uniquable k
101 => (Node k cls color -> Node k cls color)
102 -> k -> Graph k cls color -> Graph k cls color
105 = case getNode graph k of
106 Node{} -> graphMapModify
107 (\fm -> let Just node = lookupUFM fm k
109 in addToUFM fm k node')
113 -- | Get the size of the graph, O(n)
115 => Graph k cls color -> Int
118 = sizeUFM $ graphMap graph
121 -- | Union two graphs together.
123 => Graph k cls color -> Graph k cls color -> Graph k cls color
127 { graphMap = plusUFM (graphMap graph1) (graphMap graph2) }
132 -- | Add a conflict between nodes to the graph, creating the nodes required.
133 -- Conflicts are virtual regs which need to be colored differently.
136 => (k, cls) -> (k, cls)
137 -> Graph k cls color -> Graph k cls color
139 addConflict (u1, c1) (u2, c2)
140 = let addNeighbor u c u'
141 = adjustWithDefaultUFM
142 (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
143 (newNode u c) { nodeConflicts = unitUniqSet u' }
147 ( addNeighbor u1 c1 u2
148 . addNeighbor u2 c2 u1)
151 -- | Delete a conflict edge. k1 -> k2
155 -> Graph k cls color -> Graph k cls color
159 (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
163 -- | Add some conflicts to the graph, creating nodes if required.
164 -- All the nodes in the set are taken to conflict with each other.
167 => UniqSet k -> (k -> cls)
168 -> Graph k cls color -> Graph k cls color
170 addConflicts conflicts getClass
172 -- just a single node, but no conflicts, create the node anyway.
173 | (u : []) <- uniqSetToList conflicts
175 $ adjustWithDefaultUFM
177 (newNode u (getClass u))
182 $ (\fm -> foldr (\u -> addConflictSet1 u getClass conflicts) fm
183 $ uniqSetToList conflicts)
186 addConflictSet1 u getClass set
187 = let set' = delOneFromUniqSet set u
188 in adjustWithDefaultUFM
189 (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
190 (newNode u (getClass u)) { nodeConflicts = set' }
194 -- | Add an exclusion to the graph, creating nodes if required.
195 -- These are extra colors that the node cannot use.
197 :: (Uniquable k, Uniquable color)
198 => k -> (k -> cls) -> color
199 -> Graph k cls color -> Graph k cls color
201 addExclusion u getClass color
203 $ adjustWithDefaultUFM
204 (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
205 (newNode u (getClass u)) { nodeExclusions = unitUniqSet color }
209 -- | Add a coalescence edge to the graph, creating nodes if requried.
210 -- It is considered adventageous to assign the same color to nodes in a coalesence.
213 => (k, cls) -> (k, cls)
214 -> Graph k cls color -> Graph k cls color
216 addCoalesce (u1, c1) (u2, c2)
217 = let addCoalesce u c u'
218 = adjustWithDefaultUFM
219 (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
220 (newNode u c) { nodeCoalesce = unitUniqSet u' }
224 ( addCoalesce u1 c1 u2
225 . addCoalesce u2 c2 u1)
228 -- | Delete a coalescence edge (k1 -> k2) from the graph.
232 -> Graph k cls color -> Graph k cls color
235 = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
239 -- | Add a color preference to the graph, creating nodes if required.
240 -- The most recently added preference is the most prefered.
241 -- The algorithm tries to assign a node it's prefered color if possible.
246 -> Graph k cls color -> Graph k cls color
248 addPreference (u, c) color
250 $ adjustWithDefaultUFM
251 (\node -> node { nodePreference = color : (nodePreference node) })
252 (newNode u c) { nodePreference = [color] }
256 -- | Verify the internal structure of a graph
257 -- all its edges should point to valid nodes
259 verify :: Uniquable k
264 = let edges = unionUniqSets
266 (map nodeConflicts $ eltsUFM $ graphMap graph))
268 (map nodeCoalesce $ eltsUFM $ graphMap graph))
270 nodes = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
272 badEdges = minusUniqSet edges nodes
274 in if isEmptyUniqSet badEdges
279 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
281 slurpNodeConflictCount
284 -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts)
286 slurpNodeConflictCount graph
288 (\(c1, n1) (c2, n2) -> (c1, n1 + n2))
291 -> let count = sizeUniqSet $ nodeConflicts node
292 in (count, (count, 1)))
297 -- | Set the color of a certain node
301 -> Graph k cls color -> Graph k cls color
306 (\n -> n { nodeColor = Just color })
312 => (a -> a) -> a -> k
313 -> UniqFM a -> UniqFM a
315 adjustWithDefaultUFM f def k map
325 -> k -> UniqFM a -> UniqFM a
328 = case lookupUFM map k of
330 Just a -> addToUFM map k (f a)