compiler/nativeGen/GraphOps.hs

   1
   2 -- | Basic operations on graphs.
   3 --
   4 module GraphOps (
   5         addNode,        delNode,        getNode,        lookupNode,     modNode,
   6         size,
   7         union,
   8         addConflict,    delConflict,    addConflicts,
   9         addCoalesce,    delCoalesce,
  10         addExclusion,
  11         addPreference,
  12         setColor,
  13         verify,
  14         slurpNodeConflictCount
  15 )
  16 where
  17
  18 import GraphBase
  19
  20 import Outputable
  21 import Unique
  22 import UniqSet
  23 import UniqFM
  24
  25 import Data.List        hiding (union)
  26 import Data.Maybe
  27
  28
  29 -- | Lookup a node from the graph.
  30 lookupNode
  31         :: Uniquable k
  32         => Graph k cls color
  33         -> k -> Maybe (Node  k cls color)
  34
  35 lookupNode graph k
  36         = lookupUFM (graphMap graph) k
  37
  38
  39 -- | Get a node from the graph, throwing an error if it's not there
  40 getNode
  41         :: Uniquable k
  42         => Graph k cls color
  43         -> k -> Node k cls color
  44
  45 getNode graph k
  46  = case lookupUFM (graphMap graph) k of
  47         Just node       -> node
  48         Nothing         -> panic "ColorOps.getNode: not found"
  49
  50
  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
  55
  56 addNode k node graph
  57  = let
  58         -- add back conflict edges from other nodes to this one
  59         map_conflict
  60                 = foldUniqSet
  61                         (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
  62                         (graphMap graph)
  63                         (nodeConflicts node)
  64
  65         -- add back coalesce edges from other nodes to this one
  66         map_coalesce
  67                 = foldUniqSet
  68                         (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
  69                         map_conflict
  70                         (nodeCoalesce node)
  71
  72   in    graph
  73         { graphMap      = addToUFM map_coalesce k node}
  74
  75
  76
  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
  81
  82 delNode k graph
  83  = let  Just node       = lookupNode graph k
  84
  85         -- delete conflict edges from other nodes to this one.
  86         graph1          = foldl' (\g k1 -> delConflict k1 k g) graph
  87                         $ uniqSetToList (nodeConflicts node)
  88
  89         -- delete coalesce edge from other nodes to this one.
  90         graph2          = foldl' (\g k1 -> delCoalesce k1 k g) graph1
  91                         $ uniqSetToList (nodeCoalesce node)
  92
  93         -- delete the node
  94         graph3          = graphMapModify (\fm -> delFromUFM fm k) graph2
  95
  96   in    graph3
  97
  98
  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
 103
 104 modNode f k graph
 105  = case getNode graph k of
 106         Node{} -> graphMapModify
 107                  (\fm   -> let  Just node       = lookupUFM fm k
 108                                 node'           = f node
 109                            in   addToUFM fm k node')
 110                 graph
 111
 112
 113 -- | Get the size of the graph, O(n)
 114 size    :: Uniquable k
 115         => Graph k cls color -> Int
 116
 117 size graph
 118         = sizeUFM $ graphMap graph
 119
 120
 121 -- | Union two graphs together.
 122 union   :: Uniquable k
 123         => Graph k cls color -> Graph k cls color -> Graph k cls color
 124
 125 union   graph1 graph2
 126         = Graph
 127         { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }
 128
 129
 130
 131
 132 -- | Add a conflict between nodes to the graph, creating the nodes required.
 133 --      Conflicts are virtual regs which need to be colored differently.
 134 addConflict
 135         :: Uniquable k
 136         => (k, cls) -> (k, cls)
 137         -> Graph k cls color -> Graph k cls color
 138
 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' }
 144                         u
 145
 146    in   graphMapModify
 147         ( addNeighbor u1 c1 u2
 148         . addNeighbor u2 c2 u1)
 149
 150
 151 -- | Delete a conflict edge. k1 -> k2
 152 delConflict
 153         :: Uniquable k
 154         => k -> k
 155         -> Graph k cls color -> Graph k cls color
 156
 157 delConflict k1 k2
 158         = modNode
 159                 (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
 160                 k1
 161
 162
 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.
 165 addConflicts
 166         :: Uniquable k
 167         => UniqSet k -> (k -> cls)
 168         -> Graph k cls color -> Graph k cls color
 169
 170 addConflicts conflicts getClass
 171
 172         -- just a single node, but no conflicts, create the node anyway.
 173         | (u : [])      <- uniqSetToList conflicts
 174         = graphMapModify
 175         $ adjustWithDefaultUFM
 176                 id
 177                 (newNode u (getClass u))
 178                 u
 179
 180         | otherwise
 181         = graphMapModify
 182         $ (\fm -> foldr (\u -> addConflictSet1 u getClass conflicts) fm
 183                 $ uniqSetToList conflicts)
 184
 185
 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' }
 191                 u
 192
 193
 194 -- | Add an exclusion to the graph, creating nodes if required.
 195 --      These are extra colors that the node cannot use.
 196 addExclusion
 197         :: (Uniquable k, Uniquable color)
 198         => k -> (k -> cls) -> color
 199         -> Graph k cls color -> Graph k cls color
 200
 201 addExclusion u getClass color
 202         = graphMapModify
 203         $ adjustWithDefaultUFM
 204                 (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
 205                 (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }
 206                 u
 207
 208
 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.
 211 addCoalesce
 212         :: Uniquable k
 213         => (k, cls) -> (k, cls)
 214         -> Graph k cls color -> Graph k cls color
 215
 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' }
 221                         u
 222
 223    in   graphMapModify
 224         ( addCoalesce u1 c1 u2
 225         . addCoalesce u2 c2 u1)
 226
 227
 228 -- | Delete a coalescence edge (k1 -> k2) from the graph.
 229 delCoalesce
 230         :: Uniquable k
 231         => k -> k
 232         -> Graph k cls color    -> Graph k cls color
 233
 234 delCoalesce k1 k2
 235         = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
 236                 k1
 237
 238
 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.
 242 --
 243 addPreference
 244         :: Uniquable k
 245         => (k, cls) -> color
 246         -> Graph k cls color -> Graph k cls color
 247
 248 addPreference (u, c) color
 249         = graphMapModify
 250         $ adjustWithDefaultUFM
 251                 (\node -> node { nodePreference = color : (nodePreference node) })
 252                 (newNode u c)  { nodePreference = [color] }
 253                 u
 254
 255
 256 -- | Verify the internal structure of a graph
 257 --      all its edges should point to valid nodes
 258 --
 259 verify  :: Uniquable k
 260         => Graph k cls color
 261         -> Bool
 262
 263 verify graph
 264  = let  edges   = unionUniqSets
 265                         (unionManyUniqSets
 266                                 (map nodeConflicts $ eltsUFM $ graphMap graph))
 267                         (unionManyUniqSets
 268                                 (map nodeCoalesce  $ eltsUFM $ graphMap graph))
 269
 270         nodes   = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
 271
 272         badEdges = minusUniqSet edges nodes
 273
 274   in    if isEmptyUniqSet badEdges
 275          then   True
 276          else   False
 277
 278
 279 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
 280
 281 slurpNodeConflictCount
 282         :: Uniquable k
 283         => Graph k cls color
 284         -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)
 285
 286 slurpNodeConflictCount graph
 287         = addListToUFM_C
 288                 (\(c1, n1) (c2, n2) -> (c1, n1 + n2))
 289                 emptyUFM
 290         $ map   (\node
 291                   -> let count  = sizeUniqSet $ nodeConflicts node
 292                      in  (count, (count, 1)))
 293         $ eltsUFM
 294         $ graphMap graph
 295
 296
 297 -- | Set the color of a certain node
 298 setColor
 299         :: Uniquable k
 300         => k -> color
 301         -> Graph k cls color -> Graph k cls color
 302
 303 setColor u color
 304         = graphMapModify
 305         $ adjustUFM
 306                 (\n -> n { nodeColor = Just color })
 307                 u
 308
 309
 310 adjustWithDefaultUFM
 311         :: Uniquable k
 312         => (a -> a) -> a -> k
 313         -> UniqFM a -> UniqFM a
 314
 315 adjustWithDefaultUFM f def k map
 316         = addToUFM_C
 317                 (\old new -> f old)
 318                 map
 319                 k def
 320
 321
 322 adjustUFM
 323         :: Uniquable k
 324         => (a -> a)
 325         -> k -> UniqFM a -> UniqFM a
 326
 327 adjustUFM f k map
 328  = case lookupUFM map k of
 329         Nothing -> map
 330         Just a  -> addToUFM map k (f a)
 331
 332