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