compiler/nativeGen/GraphOps.hs

   1
   2 -- | Basic operations on graphs.
   3 --
   4
   5 {-# OPTIONS_GHC -w #-}
   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
  10 -- for details
  11
  12 module GraphOps (
  13         addNode,        delNode,        getNode,        lookupNode,     modNode,
  14         size,
  15         union,
  16         addConflict,    delConflict,    addConflicts,
  17         addCoalesce,    delCoalesce,
  18         addExclusion,
  19         addPreference,
  20         coalesceGraph,
  21         coalesceNodes,
  22         setColor,
  23         validateGraph,
  24         slurpNodeConflictCount
  25 )
  26 where
  27
  28 import GraphBase
  29
  30 import Outputable
  31 import Unique
  32 import UniqSet
  33 import UniqFM
  34
  35 import Data.List        hiding (union)
  36 import Data.Maybe
  37
  38
  39 -- | Lookup a node from the graph.
  40 lookupNode
  41         :: Uniquable k
  42         => Graph k cls color
  43         -> k -> Maybe (Node  k cls color)
  44
  45 lookupNode graph k
  46         = lookupUFM (graphMap graph) k
  47
  48
  49 -- | Get a node from the graph, throwing an error if it's not there
  50 getNode
  51         :: Uniquable k
  52         => Graph k cls color
  53         -> k -> Node k cls color
  54
  55 getNode graph k
  56  = case lookupUFM (graphMap graph) k of
  57         Just node       -> node
  58         Nothing         -> panic "ColorOps.getNode: not found"
  59
  60
  61 -- | Add a node to the graph, linking up its edges
  62 addNode :: Uniquable k
  63         => k -> Node k cls color
  64         -> Graph k cls color -> Graph k cls color
  65
  66 addNode k node graph
  67  = let
  68         -- add back conflict edges from other nodes to this one
  69         map_conflict
  70                 = foldUniqSet
  71                         (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k}))
  72                         (graphMap graph)
  73                         (nodeConflicts node)
  74
  75         -- add back coalesce edges from other nodes to this one
  76         map_coalesce
  77                 = foldUniqSet
  78                         (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k}))
  79                         map_conflict
  80                         (nodeCoalesce node)
  81
  82   in    graph
  83         { graphMap      = addToUFM map_coalesce k node}
  84
  85
  86
  87 -- | Delete a node and all its edges from the graph.
  88 --      Throws an error if it's not there.
  89 delNode :: Uniquable k
  90         => k -> Graph k cls color -> Graph k cls color
  91
  92 delNode k graph
  93  = let  Just node       = lookupNode graph k
  94
  95         -- delete conflict edges from other nodes to this one.
  96         graph1          = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
  97                         $ uniqSetToList (nodeConflicts node)
  98
  99         -- delete coalesce edge from other nodes to this one.
 100         graph2          = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
 101                         $ uniqSetToList (nodeCoalesce node)
 102
 103         -- delete the node
 104         graph3          = graphMapModify (\fm -> delFromUFM fm k) graph2
 105
 106   in    graph3
 107
 108
 109 -- | Modify a node in the graph.
 110 --      returns Nothing if the node isn't present.
 111 --
 112 modNode :: Uniquable k
 113         => (Node k cls color -> Node k cls color)
 114         -> k -> Graph k cls color -> Maybe (Graph k cls color)
 115
 116 modNode f k graph
 117  = case lookupNode graph k of
 118         Just Node{}
 119          -> Just
 120          $  graphMapModify
 121                  (\fm   -> let  Just node       = lookupUFM fm k
 122                                 node'           = f node
 123                            in   addToUFM fm k node')
 124                 graph
 125
 126         Nothing -> Nothing
 127
 128 -- | Get the size of the graph, O(n)
 129 size    :: Uniquable k
 130         => Graph k cls color -> Int
 131
 132 size graph
 133         = sizeUFM $ graphMap graph
 134
 135
 136 -- | Union two graphs together.
 137 union   :: Uniquable k
 138         => Graph k cls color -> Graph k cls color -> Graph k cls color
 139
 140 union   graph1 graph2
 141         = Graph
 142         { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }
 143
 144
 145
 146
 147 -- | Add a conflict between nodes to the graph, creating the nodes required.
 148 --      Conflicts are virtual regs which need to be colored differently.
 149 addConflict
 150         :: Uniquable k
 151         => (k, cls) -> (k, cls)
 152         -> Graph k cls color -> Graph k cls color
 153
 154 addConflict (u1, c1) (u2, c2)
 155  = let  addNeighbor u c u'
 156                 = adjustWithDefaultUFM
 157                         (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
 158                         (newNode u c)  { nodeConflicts = unitUniqSet u' }
 159                         u
 160
 161    in   graphMapModify
 162         ( addNeighbor u1 c1 u2
 163         . addNeighbor u2 c2 u1)
 164
 165
 166 -- | Delete a conflict edge. k1 -> k2
 167 --      returns Nothing if the node isn't in the graph
 168 delConflict
 169         :: Uniquable k
 170         => k -> k
 171         -> Graph k cls color -> Maybe (Graph k cls color)
 172
 173 delConflict k1 k2
 174         = modNode
 175                 (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
 176                 k1
 177
 178
 179 -- | Add some conflicts to the graph, creating nodes if required.
 180 --      All the nodes in the set are taken to conflict with each other.
 181 addConflicts
 182         :: Uniquable k
 183         => UniqSet k -> (k -> cls)
 184         -> Graph k cls color -> Graph k cls color
 185
 186 addConflicts conflicts getClass
 187
 188         -- just a single node, but no conflicts, create the node anyway.
 189         | (u : [])      <- uniqSetToList conflicts
 190         = graphMapModify
 191         $ adjustWithDefaultUFM
 192                 id
 193                 (newNode u (getClass u))
 194                 u
 195
 196         | otherwise
 197         = graphMapModify
 198         $ (\fm -> foldr (\u -> addConflictSet1 u getClass conflicts) fm
 199                 $ uniqSetToList conflicts)
 200
 201
 202 addConflictSet1 u getClass set
 203  = let  set'    = delOneFromUniqSet set u
 204    in   adjustWithDefaultUFM
 205                 (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
 206                 (newNode u (getClass u))        { nodeConflicts = set' }
 207                 u
 208
 209
 210 -- | Add an exclusion to the graph, creating nodes if required.
 211 --      These are extra colors that the node cannot use.
 212 addExclusion
 213         :: (Uniquable k, Uniquable color)
 214         => k -> (k -> cls) -> color
 215         -> Graph k cls color -> Graph k cls color
 216
 217 addExclusion u getClass color
 218         = graphMapModify
 219         $ adjustWithDefaultUFM
 220                 (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
 221                 (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }
 222                 u
 223
 224
 225 -- | Add a coalescence edge to the graph, creating nodes if requried.
 226 --      It is considered adventageous to assign the same color to nodes in a coalesence.
 227 addCoalesce
 228         :: Uniquable k
 229         => (k, cls) -> (k, cls)
 230         -> Graph k cls color -> Graph k cls color
 231
 232 addCoalesce (u1, c1) (u2, c2)
 233  = let  addCoalesce u c u'
 234          =      adjustWithDefaultUFM
 235                         (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
 236                         (newNode u c)  { nodeCoalesce = unitUniqSet u' }
 237                         u
 238
 239    in   graphMapModify
 240         ( addCoalesce u1 c1 u2
 241         . addCoalesce u2 c2 u1)
 242
 243
 244 -- | Delete a coalescence edge (k1 -> k2) from the graph.
 245 delCoalesce
 246         :: Uniquable k
 247         => k -> k
 248         -> Graph k cls color    -> Maybe (Graph k cls color)
 249
 250 delCoalesce k1 k2
 251         = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
 252                 k1
 253
 254
 255 -- | Add a color preference to the graph, creating nodes if required.
 256 --      The most recently added preference is the most prefered.
 257 --      The algorithm tries to assign a node it's prefered color if possible.
 258 --
 259 addPreference
 260         :: Uniquable k
 261         => (k, cls) -> color
 262         -> Graph k cls color -> Graph k cls color
 263
 264 addPreference (u, c) color
 265         = graphMapModify
 266         $ adjustWithDefaultUFM
 267                 (\node -> node { nodePreference = color : (nodePreference node) })
 268                 (newNode u c)  { nodePreference = [color] }
 269                 u
 270
 271
 272 -- | Do agressive coalescing on this graph.
 273 --      returns the new graph and the list of pairs of nodes that got coaleced together.
 274 --      for each pair, the resulting node will have the least key and be second in the pair.
 275 --
 276 coalesceGraph
 277         :: (Uniquable k, Ord k, Eq cls, Outputable k)
 278         =>  Graph k cls color
 279         -> (Graph k cls color, [(k, k)])
 280
 281 coalesceGraph graph
 282  = let
 283         -- find all the nodes that have coalescence edges
 284         cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
 285                 $ eltsUFM $ graphMap graph
 286
 287         -- build a list of pairs of keys for node's we'll try and coalesce
 288         --      every pair of nodes will appear twice in this list
 289         --      ie [(k1, k2), (k2, k1) ... ]
 290         --      This is ok, GrapOps.coalesceNodes handles this and it's convenient for
 291         --      build a list of what nodes get coalesced together for later on.
 292         --
 293         cList   = [ (nodeId node1, k2)
 294                         | node1 <- cNodes
 295                         , k2    <- uniqSetToList $ nodeCoalesce node1 ]
 296
 297         -- do the coalescing, returning the new graph and a list of pairs of keys
 298         --      that got coalesced together.
 299         (graph', mPairs)
 300                 = mapAccumL coalesceNodes graph cList
 301
 302    in   (graph', catMaybes mPairs)
 303
 304
 305 -- | Coalesce this pair of nodes unconditionally / agressively.
 306 --      The resulting node is the one with the least key.
 307 --
 308 --      returns: Just    the pair of keys if the nodes were coalesced
 309 --                       the second element of the pair being the least one
 310 --
 311 --               Nothing if either of the nodes weren't in the graph
 312
 313 coalesceNodes
 314         :: (Uniquable k, Ord k, Eq cls, Outputable k)
 315         => Graph k cls color
 316         -> (k, k)               -- ^ keys of the nodes to be coalesced
 317         -> (Graph k cls color, Maybe (k, k))
 318
 319 coalesceNodes graph (k1, k2)
 320         | (kMin, kMax)  <- if k1 < k2
 321                                 then (k1, k2)
 322                                 else (k2, k1)
 323
 324         -- nodes must be in the graph
 325         , Just nMin     <- lookupNode graph kMin
 326         , Just nMax     <- lookupNode graph kMax
 327
 328         -- can't coalesce conflicting nodes
 329         , not $ elementOfUniqSet kMin (nodeConflicts nMax)
 330         , not $ elementOfUniqSet kMax (nodeConflicts nMin)
 331
 332         = coalesceNodes' graph kMin kMax nMin nMax
 333
 334
 335
 336         -- one of the nodes wasn't in the graph anymore
 337         | otherwise
 338         = (graph, Nothing)
 339
 340 coalesceNodes' graph kMin kMax nMin nMax
 341
 342         -- sanity checks
 343         | nodeClass nMin /= nodeClass nMax
 344         = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
 345
 346         | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
 347         = error "GraphOps.coalesceNodes: can't coalesce colored nodes."
 348
 349         ---
 350         | otherwise
 351         = let
 352                 -- the new node gets all the edges from its two components
 353                 node    =
 354                  Node   { nodeId                = kMin
 355                         , nodeClass             = nodeClass nMin
 356                         , nodeColor             = Nothing
 357
 358                         -- nodes don't conflict with themselves..
 359                         , nodeConflicts
 360                                 = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
 361                                         `delOneFromUniqSet` kMin
 362                                         `delOneFromUniqSet` kMax
 363
 364                         , nodeExclusions        = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
 365                         , nodePreference        = nodePreference nMin ++ nodePreference nMax
 366
 367                         -- nodes don't coalesce with themselves..
 368                         , nodeCoalesce
 369                                 = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
 370                                         `delOneFromUniqSet` kMin
 371                                         `delOneFromUniqSet` kMax
 372                         }
 373
 374                 -- delete the old nodes from the graph and add the new one
 375                 graph'  = addNode kMin node
 376                         $ delNode kMin
 377                         $ delNode kMax
 378                         $ graph
 379
 380           in    (graph', Just (kMax, kMin))
 381
 382
 383 -- | validate the internal structure of a graph
 384 --      all its edges should point to valid nodes
 385 --      if they don't then throw an error
 386 --
 387 validateGraph
 388         :: (Uniquable k, Outputable k)
 389         => SDoc
 390         -> Graph k cls color
 391         -> Graph k cls color
 392
 393 validateGraph doc graph
 394  = let  edges   = unionUniqSets
 395                         (unionManyUniqSets
 396                                 (map nodeConflicts $ eltsUFM $ graphMap graph))
 397                         (unionManyUniqSets
 398                                 (map nodeCoalesce  $ eltsUFM $ graphMap graph))
 399
 400         nodes   = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
 401
 402         badEdges = minusUniqSet edges nodes
 403
 404   in    if isEmptyUniqSet badEdges
 405          then   graph
 406          else   pprPanic "GraphOps.validateGraph"
 407                 ( text  "-- bad edges"
 408                 $$ vcat (map ppr $ uniqSetToList badEdges)
 409                 $$ text "----------------------------"
 410                 $$ doc)
 411
 412
 413 -- | Slurp out a map of how many nodes had a certain number of conflict neighbours
 414
 415 slurpNodeConflictCount
 416         :: Uniquable k
 417         => Graph k cls color
 418         -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)
 419
 420 slurpNodeConflictCount graph
 421         = addListToUFM_C
 422                 (\(c1, n1) (c2, n2) -> (c1, n1 + n2))
 423                 emptyUFM
 424         $ map   (\node
 425                   -> let count  = sizeUniqSet $ nodeConflicts node
 426                      in  (count, (count, 1)))
 427         $ eltsUFM
 428         $ graphMap graph
 429
 430
 431 -- | Set the color of a certain node
 432 setColor
 433         :: Uniquable k
 434         => k -> color
 435         -> Graph k cls color -> Graph k cls color
 436
 437 setColor u color
 438         = graphMapModify
 439         $ adjustUFM
 440                 (\n -> n { nodeColor = Just color })
 441                 u
 442
 443
 444 adjustWithDefaultUFM
 445         :: Uniquable k
 446         => (a -> a) -> a -> k
 447         -> UniqFM a -> UniqFM a
 448
 449 adjustWithDefaultUFM f def k map
 450         = addToUFM_C
 451                 (\old new -> f old)
 452                 map
 453                 k def
 454
 455
 456 adjustUFM
 457         :: Uniquable k
 458         => (a -> a)
 459         -> k -> UniqFM a -> UniqFM a
 460
 461 adjustUFM f k map
 462  = case lookupUFM map k of
 463         Nothing -> map
 464         Just a  -> addToUFM map k (f a)
 465
 466