Modules: Utils and Data (#13009)

Update Haddock submodule

Metric Increase:
   haddock.compiler

6 files changed, 2022 insertions, 0 deletions

diff --git a/compiler/GHC/Data/Graph/Base.hs b/compiler/GHC/Data/Graph/Base.hs
new file mode 100644
index 0000000000..3c40645660
--- /dev/null
+++ b/compiler/GHC/Data/Graph/Base.hs
@@ -0,0 +1,107 @@
+
+-- | Types for the general graph colorer.
+module GHC.Data.Graph.Base (
+        Triv,
+        Graph (..),
+        initGraph,
+        graphMapModify,
+
+        Node  (..),     newNode,
+)
+
+
+where
+
+import GHC.Prelude
+
+import GHC.Types.Unique.Set
+import GHC.Types.Unique.FM
+
+
+-- | A fn to check if a node is trivially colorable
+--      For graphs who's color classes are disjoint then a node is 'trivially colorable'
+--      when it has less neighbors and exclusions than available colors for that node.
+--
+--      For graph's who's color classes overlap, ie some colors alias other colors, then
+--      this can be a bit more tricky. There is a general way to calculate this, but
+--      it's likely be too slow for use in the code. The coloring algorithm takes
+--      a canned function which can be optimised by the user to be specific to the
+--      specific graph being colored.
+--
+--      for details, see  "A Generalised Algorithm for Graph-Coloring Register Allocation"
+--                              Smith, Ramsey, Holloway - PLDI 2004.
+--
+type Triv k cls color
+        =  cls                  -- the class of the node we're trying to color.
+        -> UniqSet k            -- the node's neighbors.
+        -> UniqSet color        -- the node's exclusions.
+        -> Bool
+
+
+-- | The Interference graph.
+--      There used to be more fields, but they were turfed out in a previous revision.
+--      maybe we'll want more later..
+--
+data Graph k cls color
+        = Graph {
+        -- | All active nodes in the graph.
+          graphMap              :: UniqFM (Node k cls color)  }
+
+
+-- | An empty graph.
+initGraph :: Graph k cls color
+initGraph
+        = Graph
+        { graphMap              = emptyUFM }
+
+
+-- | Modify the finite map holding the nodes in the graph.
+graphMapModify
+        :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color))
+        -> Graph k cls color -> Graph k cls color
+
+graphMapModify f graph
+        = graph { graphMap      = f (graphMap graph) }
+
+
+
+-- | Graph nodes.
+--      Represents a thing that can conflict with another thing.
+--      For the register allocater the nodes represent registers.
+--
+data Node k cls color
+        = Node {
+        -- | A unique identifier for this node.
+          nodeId                :: k
+
+        -- | The class of this node,
+        --      determines the set of colors that can be used.
+        , nodeClass             :: cls
+
+        -- | The color of this node, if any.
+        , nodeColor             :: Maybe color
+
+        -- | Neighbors which must be colored differently to this node.
+        , nodeConflicts         :: UniqSet k
+
+        -- | Colors that cannot be used by this node.
+        , nodeExclusions        :: UniqSet color
+
+        -- | Colors that this node would prefer to be, in descending order.
+        , nodePreference        :: [color]
+
+        -- | Neighbors that this node would like to be colored the same as.
+        , nodeCoalesce          :: UniqSet k }
+
+
+-- | An empty node.
+newNode :: k -> cls -> Node k cls color
+newNode k cls
+        = Node
+        { nodeId                = k
+        , nodeClass             = cls
+        , nodeColor             = Nothing
+        , nodeConflicts         = emptyUniqSet
+        , nodeExclusions        = emptyUniqSet
+        , nodePreference        = []
+        , nodeCoalesce          = emptyUniqSet }
diff --git a/compiler/GHC/Data/Graph/Color.hs b/compiler/GHC/Data/Graph/Color.hs
new file mode 100644
index 0000000000..948447da58
--- /dev/null
+++ b/compiler/GHC/Data/Graph/Color.hs
@@ -0,0 +1,375 @@
+-- | Graph Coloring.
+--      This is a generic graph coloring library, abstracted over the type of
+--      the node keys, nodes and colors.
+--
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module GHC.Data.Graph.Color (
+        module GHC.Data.Graph.Base,
+        module GHC.Data.Graph.Ops,
+        module GHC.Data.Graph.Ppr,
+        colorGraph
+)
+
+where
+
+import GHC.Prelude
+
+import GHC.Data.Graph.Base
+import GHC.Data.Graph.Ops
+import GHC.Data.Graph.Ppr
+
+import GHC.Types.Unique
+import GHC.Types.Unique.FM
+import GHC.Types.Unique.Set
+import GHC.Utils.Outputable
+
+import Data.Maybe
+import Data.List
+
+
+-- | Try to color a graph with this set of colors.
+--      Uses Chaitin's algorithm to color the graph.
+--      The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
+--      are pushed onto a stack and removed from the graph.
+--      Once this process is complete the graph can be colored by removing nodes from
+--      the stack (ie in reverse order) and assigning them colors different to their neighbors.
+--
+colorGraph
+        :: ( Uniquable  k, Uniquable cls,  Uniquable  color
+           , Eq cls, Ord k
+           , Outputable k, Outputable cls, Outputable color)
+        => Bool                         -- ^ whether to do iterative coalescing
+        -> Int                          -- ^ how many times we've tried to color this graph so far.
+        -> UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
+        -> Triv   k cls color           -- ^ fn to decide whether a node is trivially colorable.
+        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
+        -> Graph  k cls color           -- ^ the graph to color.
+
+        -> ( Graph k cls color          -- the colored graph.
+           , UniqSet k                  -- the set of nodes that we couldn't find a color for.
+           , UniqFM  k )                -- map of regs (r1 -> r2) that were coalesced
+                                        --       r1 should be replaced by r2 in the source
+
+colorGraph iterative spinCount colors triv spill graph0
+ = let
+        -- If we're not doing iterative coalescing then do an aggressive coalescing first time
+        --      around and then conservative coalescing for subsequent passes.
+        --
+        --      Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if
+        --      there is a lot of register pressure and we do it on every round then it can make the
+        --      graph less colorable and prevent the algorithm from converging in a sensible number
+        --      of cycles.
+        --
+        (graph_coalesced, kksCoalesce1)
+         = if iterative
+                then (graph0, [])
+                else if spinCount == 0
+                        then coalesceGraph True  triv graph0
+                        else coalesceGraph False triv graph0
+
+        -- run the scanner to slurp out all the trivially colorable nodes
+        --      (and do coalescing if iterative coalescing is enabled)
+        (ksTriv, ksProblems, kksCoalesce2)
+                = colorScan iterative triv spill graph_coalesced
+
+        -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.
+        --      We need to apply all the coalescences found by the scanner to the original
+        --      graph before doing assignColors.
+        --
+        --      Because we've got the whole, non-pruned graph here we turn on aggressive coalescing
+        --      to force all the (conservative) coalescences found during scanning.
+        --
+        (graph_scan_coalesced, _)
+                = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2
+
+        -- color the trivially colorable nodes
+        --      during scanning, keys of triv nodes were added to the front of the list as they were found
+        --      this colors them in the reverse order, as required by the algorithm.
+        (graph_triv, ksNoTriv)
+                = assignColors colors graph_scan_coalesced ksTriv
+
+        -- try and color the problem nodes
+        --      problem nodes are the ones that were left uncolored because they weren't triv.
+        --      theres a change we can color them here anyway.
+        (graph_prob, ksNoColor)
+                = assignColors colors graph_triv ksProblems
+
+        -- if the trivially colorable nodes didn't color then something is probably wrong
+        --      with the provided triv function.
+        --
+   in   if not $ null ksNoTriv
+         then   pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty
+                        (  empty
+                        $$ text "ksTriv    = " <> ppr ksTriv
+                        $$ text "ksNoTriv  = " <> ppr ksNoTriv
+                        $$ text "colors    = " <> ppr colors
+                        $$ empty
+                        $$ dotGraph (\_ -> text "white") triv graph_triv)
+
+         else   ( graph_prob
+                , mkUniqSet ksNoColor   -- the nodes that didn't color (spills)
+                , if iterative
+                        then (listToUFM kksCoalesce2)
+                        else (listToUFM kksCoalesce1))
+
+
+-- | Scan through the conflict graph separating out trivially colorable and
+--      potentially uncolorable (problem) nodes.
+--
+--      Checking whether a node is trivially colorable or not is a reasonably expensive operation,
+--      so after a triv node is found and removed from the graph it's no good to return to the 'start'
+--      of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.
+--
+--      To ward against this, during each pass through the graph we collect up a list of triv nodes
+--      that were found, and only remove them once we've finished the pass. The more nodes we can delete
+--      at once the more likely it is that nodes we've already checked will become trivially colorable
+--      for the next pass.
+--
+--      TODO:   add work lists to finding triv nodes is easier.
+--              If we've just scanned the graph, and removed triv nodes, then the only
+--              nodes that we need to rescan are the ones we've removed edges from.
+
+colorScan
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Ord k,       Eq cls
+           , Outputable k, Outputable cls)
+        => Bool                         -- ^ whether to do iterative coalescing
+        -> Triv k cls color             -- ^ fn to decide whether a node is trivially colorable
+        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
+        -> Graph k cls color            -- ^ the graph to scan
+
+        -> ([k], [k], [(k, k)])         --  triv colorable nodes, problem nodes, pairs of nodes to coalesce
+
+colorScan iterative triv spill graph
+        = colorScan_spin iterative triv spill graph [] [] []
+
+colorScan_spin
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Ord k,       Eq cls
+           , Outputable k, Outputable cls)
+        => Bool
+        -> Triv k cls color
+        -> (Graph k cls color -> k)
+        -> Graph k cls color
+        -> [k]
+        -> [k]
+        -> [(k, k)]
+        -> ([k], [k], [(k, k)])
+
+colorScan_spin iterative triv spill graph
+        ksTriv ksSpill kksCoalesce
+
+        -- if the graph is empty then we're done
+        | isNullUFM $ graphMap graph
+        = (ksTriv, ksSpill, reverse kksCoalesce)
+
+        -- Simplify:
+        --      Look for trivially colorable nodes.
+        --      If we can find some then remove them from the graph and go back for more.
+        --
+        | nsTrivFound@(_:_)
+                <-  scanGraph   (\node -> triv  (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+
+                                  -- for iterative coalescing we only want non-move related
+                                  --    nodes here
+                                  && (not iterative || isEmptyUniqSet (nodeCoalesce node)))
+                        $ graph
+
+        , ksTrivFound   <- map nodeId nsTrivFound
+        , graph2        <- foldr (\k g -> let Just g' = delNode k g
+                                          in  g')
+                                graph ksTrivFound
+
+        = colorScan_spin iterative triv spill graph2
+                (ksTrivFound ++ ksTriv)
+                ksSpill
+                kksCoalesce
+
+        -- Coalesce:
+        --      If we're doing iterative coalescing and no triv nodes are available
+        --      then it's time for a coalescing pass.
+        | iterative
+        = case coalesceGraph False triv graph of
+
+                -- we were able to coalesce something
+                --      go back to Simplify and see if this frees up more nodes to be trivially colorable.
+                (graph2, kksCoalesceFound@(_:_))
+                 -> colorScan_spin iterative triv spill graph2
+                        ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce)
+
+                -- Freeze:
+                -- nothing could be coalesced (or was triv),
+                --      time to choose a node to freeze and give up on ever coalescing it.
+                (graph2, [])
+                 -> case freezeOneInGraph graph2 of
+
+                        -- we were able to freeze something
+                        --      hopefully this will free up something for Simplify
+                        (graph3, True)
+                         -> colorScan_spin iterative triv spill graph3
+                                ksTriv ksSpill kksCoalesce
+
+                        -- we couldn't find something to freeze either
+                        --      time for a spill
+                        (graph3, False)
+                         -> colorScan_spill iterative triv spill graph3
+                                ksTriv ksSpill kksCoalesce
+
+        -- spill time
+        | otherwise
+        = colorScan_spill iterative triv spill graph
+                ksTriv ksSpill kksCoalesce
+
+
+-- Select:
+-- we couldn't find any triv nodes or things to freeze or coalesce,
+--      and the graph isn't empty yet.. We'll have to choose a spill
+--      candidate and leave it uncolored.
+--
+colorScan_spill
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Ord k,       Eq cls
+           , Outputable k, Outputable cls)
+        => Bool
+        -> Triv k cls color
+        -> (Graph k cls color -> k)
+        -> Graph k cls color
+        -> [k]
+        -> [k]
+        -> [(k, k)]
+        -> ([k], [k], [(k, k)])
+
+colorScan_spill iterative triv spill graph
+        ksTriv ksSpill kksCoalesce
+
+ = let  kSpill          = spill graph
+        Just graph'     = delNode kSpill graph
+   in   colorScan_spin iterative triv spill graph'
+                ksTriv (kSpill : ksSpill) kksCoalesce
+
+
+-- | Try to assign a color to all these nodes.
+
+assignColors
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Outputable cls)
+        => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
+        -> Graph k cls color            -- ^ the graph
+        -> [k]                          -- ^ nodes to assign a color to.
+        -> ( Graph k cls color          -- the colored graph
+           , [k])                       -- the nodes that didn't color.
+
+assignColors colors graph ks
+        = assignColors' colors graph [] ks
+
+ where  assignColors' _ graph prob []
+                = (graph, prob)
+
+        assignColors' colors graph prob (k:ks)
+         = case assignColor colors k graph of
+
+                -- couldn't color this node
+                Nothing         -> assignColors' colors graph (k : prob) ks
+
+                -- this node colored ok, so do the rest
+                Just graph'     -> assignColors' colors graph' prob ks
+
+
+        assignColor colors u graph
+                | Just c        <- selectColor colors graph u
+                = Just (setColor u c graph)
+
+                | otherwise
+                = Nothing
+
+
+
+-- | Select a color for a certain node
+--      taking into account preferences, neighbors and exclusions.
+--      returns Nothing if no color can be assigned to this node.
+--
+selectColor
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Outputable cls)
+        => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
+        -> Graph k cls color            -- ^ the graph
+        -> k                            -- ^ key of the node to select a color for.
+        -> Maybe color
+
+selectColor colors graph u
+ = let  -- lookup the node
+        Just node       = lookupNode graph u
+
+        -- lookup the available colors for the class of this node.
+        colors_avail
+         = case lookupUFM colors (nodeClass node) of
+                Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node))
+                Just cs -> cs
+
+        -- find colors we can't use because they're already being used
+        --      by a node that conflicts with this one.
+        Just nsConflicts
+                        = sequence
+                        $ map (lookupNode graph)
+                        $ nonDetEltsUniqSet
+                        $ nodeConflicts node
+                        -- See Note [Unique Determinism and code generation]
+
+        colors_conflict = mkUniqSet
+                        $ catMaybes
+                        $ map nodeColor nsConflicts
+
+        -- the prefs of our neighbors
+        colors_neighbor_prefs
+                        = mkUniqSet
+                        $ concatMap nodePreference nsConflicts
+
+        -- colors that are still valid for us
+        colors_ok_ex    = minusUniqSet colors_avail (nodeExclusions node)
+        colors_ok       = minusUniqSet colors_ok_ex colors_conflict
+
+        -- the colors that we prefer, and are still ok
+        colors_ok_pref  = intersectUniqSets
+                                (mkUniqSet $ nodePreference node) colors_ok
+
+        -- the colors that we could choose while being nice to our neighbors
+        colors_ok_nice  = minusUniqSet
+                                colors_ok colors_neighbor_prefs
+
+        -- the best of all possible worlds..
+        colors_ok_pref_nice
+                        = intersectUniqSets
+                                colors_ok_nice colors_ok_pref
+
+        -- make the decision
+        chooseColor
+
+                -- everyone is happy, yay!
+                | not $ isEmptyUniqSet colors_ok_pref_nice
+                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice)
+                                        (nodePreference node)
+                = Just c
+
+                -- we've got one of our preferences
+                | not $ isEmptyUniqSet colors_ok_pref
+                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref)
+                                        (nodePreference node)
+                = Just c
+
+                -- it wasn't a preference, but it was still ok
+                | not $ isEmptyUniqSet colors_ok
+                , c : _         <- nonDetEltsUniqSet colors_ok
+                -- See Note [Unique Determinism and code generation]
+                = Just c
+
+                -- no colors were available for us this time.
+                --      looks like we're going around the loop again..
+                | otherwise
+                = Nothing
+
+   in   chooseColor
+
+
+
diff --git a/compiler/GHC/Data/Graph/Directed.hs b/compiler/GHC/Data/Graph/Directed.hs
new file mode 100644
index 0000000000..c3f397051a
--- /dev/null
+++ b/compiler/GHC/Data/Graph/Directed.hs
@@ -0,0 +1,524 @@
+-- (c) The University of Glasgow 2006
+
+{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module GHC.Data.Graph.Directed (
+        Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
+
+        SCC(..), Node(..), flattenSCC, flattenSCCs,
+        stronglyConnCompG,
+        topologicalSortG,
+        verticesG, edgesG, hasVertexG,
+        reachableG, reachablesG, transposeG,
+        emptyG,
+
+        findCycle,
+
+        -- For backwards compatibility with the simpler version of Digraph
+        stronglyConnCompFromEdgedVerticesOrd,
+        stronglyConnCompFromEdgedVerticesOrdR,
+        stronglyConnCompFromEdgedVerticesUniq,
+        stronglyConnCompFromEdgedVerticesUniqR,
+
+        -- Simple way to classify edges
+        EdgeType(..), classifyEdges
+    ) where
+
+#include "HsVersions.h"
+
+------------------------------------------------------------------------------
+-- A version of the graph algorithms described in:
+--
+-- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''
+--   by David King and John Launchbury
+--
+-- Also included is some additional code for printing tree structures ...
+--
+-- If you ever find yourself in need of algorithms for classifying edges,
+-- or finding connected/biconnected components, consult the history; Sigbjorn
+-- Finne contributed some implementations in 1997, although we've since
+-- removed them since they were not used anywhere in GHC.
+------------------------------------------------------------------------------
+
+
+import GHC.Prelude
+
+import GHC.Utils.Misc ( minWith, count )
+import GHC.Utils.Outputable
+import GHC.Data.Maybe ( expectJust )
+
+-- std interfaces
+import Data.Maybe
+import Data.Array
+import Data.List hiding (transpose)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import qualified Data.Graph as G
+import Data.Graph hiding (Graph, Edge, transposeG, reachable)
+import Data.Tree
+import GHC.Types.Unique
+import GHC.Types.Unique.FM
+
+{-
+************************************************************************
+*                                                                      *
+*      Graphs and Graph Construction
+*                                                                      *
+************************************************************************
+
+Note [Nodes, keys, vertices]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * A 'node' is a big blob of client-stuff
+
+ * Each 'node' has a unique (client) 'key', but the latter
+        is in Ord and has fast comparison
+
+ * Digraph then maps each 'key' to a Vertex (Int) which is
+        arranged densely in 0.n
+-}
+
+data Graph node = Graph {
+    gr_int_graph      :: IntGraph,
+    gr_vertex_to_node :: Vertex -> node,
+    gr_node_to_vertex :: node -> Maybe Vertex
+  }
+
+data Edge node = Edge node node
+
+{-| Representation for nodes of the Graph.
+
+ * The @payload@ is user data, just carried around in this module
+
+ * The @key@ is the node identifier.
+   Key has an Ord instance for performance reasons.
+
+ * The @[key]@ are the dependencies of the node;
+   it's ok to have extra keys in the dependencies that
+   are not the key of any Node in the graph
+-}
+data Node key payload = DigraphNode {
+      node_payload :: payload, -- ^ User data
+      node_key :: key, -- ^ User defined node id
+      node_dependencies :: [key] -- ^ Dependencies/successors of the node
+  }
+
+
+instance (Outputable a, Outputable b) => Outputable (Node  a b) where
+  ppr (DigraphNode a b c) = ppr (a, b, c)
+
+emptyGraph :: Graph a
+emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
+
+-- See Note [Deterministic SCC]
+graphFromEdgedVertices
+        :: ReduceFn key payload
+        -> [Node key payload]           -- The graph; its ok for the
+                                        -- out-list to contain keys which aren't
+                                        -- a vertex key, they are ignored
+        -> Graph (Node key payload)
+graphFromEdgedVertices _reduceFn []            = emptyGraph
+graphFromEdgedVertices reduceFn edged_vertices =
+  Graph graph vertex_fn (key_vertex . key_extractor)
+  where key_extractor = node_key
+        (bounds, vertex_fn, key_vertex, numbered_nodes) =
+          reduceFn edged_vertices key_extractor
+        graph = array bounds [ (v, sort $ mapMaybe key_vertex ks)
+                             | (v, (node_dependencies -> ks)) <- numbered_nodes]
+                -- We normalize outgoing edges by sorting on node order, so
+                -- that the result doesn't depend on the order of the edges
+
+-- See Note [Deterministic SCC]
+-- See Note [reduceNodesIntoVertices implementations]
+graphFromEdgedVerticesOrd
+        :: Ord key
+        => [Node key payload]           -- The graph; its ok for the
+                                        -- out-list to contain keys which aren't
+                                        -- a vertex key, they are ignored
+        -> Graph (Node key payload)
+graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd
+
+-- See Note [Deterministic SCC]
+-- See Note [reduceNodesIntoVertices implementations]
+graphFromEdgedVerticesUniq
+        :: Uniquable key
+        => [Node key payload]           -- The graph; its ok for the
+                                        -- out-list to contain keys which aren't
+                                        -- a vertex key, they are ignored
+        -> Graph (Node key payload)
+graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq
+
+type ReduceFn key payload =
+  [Node key payload] -> (Node key payload -> key) ->
+    (Bounds, Vertex -> Node key payload
+    , key -> Maybe Vertex, [(Vertex, Node key payload)])
+
+{-
+Note [reduceNodesIntoVertices implementations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+reduceNodesIntoVertices is parameterized by the container type.
+This is to accommodate key types that don't have an Ord instance
+and hence preclude the use of Data.Map. An example of such type
+would be Unique, there's no way to implement Ord Unique
+deterministically.
+
+For such types, there's a version with a Uniquable constraint.
+This leaves us with two versions of every function that depends on
+reduceNodesIntoVertices, one with Ord constraint and the other with
+Uniquable constraint.
+For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq.
+
+The Uniq version should be a tiny bit more efficient since it uses
+Data.IntMap internally.
+-}
+reduceNodesIntoVertices
+  :: ([(key, Vertex)] -> m)
+  -> (key -> m -> Maybe Vertex)
+  -> ReduceFn key payload
+reduceNodesIntoVertices fromList lookup nodes key_extractor =
+  (bounds, (!) vertex_map, key_vertex, numbered_nodes)
+  where
+    max_v           = length nodes - 1
+    bounds          = (0, max_v) :: (Vertex, Vertex)
+
+    -- Keep the order intact to make the result depend on input order
+    -- instead of key order
+    numbered_nodes  = zip [0..] nodes
+    vertex_map      = array bounds numbered_nodes
+
+    key_map = fromList
+      [ (key_extractor node, v) | (v, node) <- numbered_nodes ]
+    key_vertex k = lookup k key_map
+
+-- See Note [reduceNodesIntoVertices implementations]
+reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload
+reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup
+
+-- See Note [reduceNodesIntoVertices implementations]
+reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload
+reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM)
+
+{-
+************************************************************************
+*                                                                      *
+*      SCC
+*                                                                      *
+************************************************************************
+-}
+
+type WorkItem key payload
+  = (Node key payload,  -- Tip of the path
+     [payload])         -- Rest of the path;
+                        --  [a,b,c] means c depends on b, b depends on a
+
+-- | Find a reasonably short cycle a->b->c->a, in a strongly
+-- connected component.  The input nodes are presumed to be
+-- a SCC, so you can start anywhere.
+findCycle :: forall payload key. Ord key
+          => [Node key payload]     -- The nodes.  The dependencies can
+                                    -- contain extra keys, which are ignored
+          -> Maybe [payload]        -- A cycle, starting with node
+                                    -- so each depends on the next
+findCycle graph
+  = go Set.empty (new_work root_deps []) []
+  where
+    env :: Map.Map key (Node key payload)
+    env = Map.fromList [ (node_key node, node) | node <- graph ]
+
+    -- Find the node with fewest dependencies among the SCC modules
+    -- This is just a heuristic to find some plausible root module
+    root :: Node key payload
+    root = fst (minWith snd [ (node, count (`Map.member` env)
+                                           (node_dependencies node))
+                            | node <- graph ])
+    DigraphNode root_payload root_key root_deps = root
+
+
+    -- 'go' implements Dijkstra's algorithm, more or less
+    go :: Set.Set key   -- Visited
+       -> [WorkItem key payload]        -- Work list, items length n
+       -> [WorkItem key payload]        -- Work list, items length n+1
+       -> Maybe [payload]               -- Returned cycle
+       -- Invariant: in a call (go visited ps qs),
+       --            visited = union (map tail (ps ++ qs))
+
+    go _       [] [] = Nothing  -- No cycles
+    go visited [] qs = go visited qs []
+    go visited (((DigraphNode payload key deps), path) : ps) qs
+       | key == root_key           = Just (root_payload : reverse path)
+       | key `Set.member` visited  = go visited ps qs
+       | key `Map.notMember` env   = go visited ps qs
+       | otherwise                 = go (Set.insert key visited)
+                                        ps (new_qs ++ qs)
+       where
+         new_qs = new_work deps (payload : path)
+
+    new_work :: [key] -> [payload] -> [WorkItem key payload]
+    new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]
+
+{-
+************************************************************************
+*                                                                      *
+*      Strongly Connected Component wrappers for Graph
+*                                                                      *
+************************************************************************
+
+Note: the components are returned topologically sorted: later components
+depend on earlier ones, but not vice versa i.e. later components only have
+edges going from them to earlier ones.
+-}
+
+{-
+Note [Deterministic SCC]
+~~~~~~~~~~~~~~~~~~~~~~~~
+stronglyConnCompFromEdgedVerticesUniq,
+stronglyConnCompFromEdgedVerticesUniqR,
+stronglyConnCompFromEdgedVerticesOrd and
+stronglyConnCompFromEdgedVerticesOrdR
+provide a following guarantee:
+Given a deterministically ordered list of nodes it returns a deterministically
+ordered list of strongly connected components, where the list of vertices
+in an SCC is also deterministically ordered.
+Note that the order of edges doesn't need to be deterministic for this to work.
+We use the order of nodes to normalize the order of edges.
+-}
+
+stronglyConnCompG :: Graph node -> [SCC node]
+stronglyConnCompG graph = decodeSccs graph forest
+  where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph)
+
+decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
+decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest
+  = map decode forest
+  where
+    decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
+                       | otherwise         = AcyclicSCC (vertex_fn v)
+    decode other = CyclicSCC (dec other [])
+      where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
+    mentions_itself v = v `elem` (graph ! v)
+
+
+-- The following two versions are provided for backwards compatibility:
+-- See Note [Deterministic SCC]
+-- See Note [reduceNodesIntoVertices implementations]
+stronglyConnCompFromEdgedVerticesOrd
+        :: Ord key
+        => [Node key payload]
+        -> [SCC payload]
+stronglyConnCompFromEdgedVerticesOrd
+  = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR
+
+-- The following two versions are provided for backwards compatibility:
+-- See Note [Deterministic SCC]
+-- See Note [reduceNodesIntoVertices implementations]
+stronglyConnCompFromEdgedVerticesUniq
+        :: Uniquable key
+        => [Node key payload]
+        -> [SCC payload]
+stronglyConnCompFromEdgedVerticesUniq
+  = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR
+
+-- The "R" interface is used when you expect to apply SCC to
+-- (some of) the result of SCC, so you don't want to lose the dependency info
+-- See Note [Deterministic SCC]
+-- See Note [reduceNodesIntoVertices implementations]
+stronglyConnCompFromEdgedVerticesOrdR
+        :: Ord key
+        => [Node key payload]
+        -> [SCC (Node key payload)]
+stronglyConnCompFromEdgedVerticesOrdR =
+  stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd
+
+-- The "R" interface is used when you expect to apply SCC to
+-- (some of) the result of SCC, so you don't want to lose the dependency info
+-- See Note [Deterministic SCC]
+-- See Note [reduceNodesIntoVertices implementations]
+stronglyConnCompFromEdgedVerticesUniqR
+        :: Uniquable key
+        => [Node key payload]
+        -> [SCC (Node key payload)]
+stronglyConnCompFromEdgedVerticesUniqR =
+  stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq
+
+{-
+************************************************************************
+*                                                                      *
+*      Misc wrappers for Graph
+*                                                                      *
+************************************************************************
+-}
+
+topologicalSortG :: Graph node -> [node]
+topologicalSortG graph = map (gr_vertex_to_node graph) result
+  where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)
+
+reachableG :: Graph node -> node -> [node]
+reachableG graph from = map (gr_vertex_to_node graph) result
+  where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
+        result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex]
+
+-- | Given a list of roots return all reachable nodes.
+reachablesG :: Graph node -> [node] -> [node]
+reachablesG graph froms = map (gr_vertex_to_node graph) result
+  where result = {-# SCC "Digraph.reachable" #-}
+                 reachable (gr_int_graph graph) vs
+        vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
+
+hasVertexG :: Graph node -> node -> Bool
+hasVertexG graph node = isJust $ gr_node_to_vertex graph node
+
+verticesG :: Graph node -> [node]
+verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)
+
+edgesG :: Graph node -> [Edge node]
+edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)
+  where v2n = gr_vertex_to_node graph
+
+transposeG :: Graph node -> Graph node
+transposeG graph = Graph (G.transposeG (gr_int_graph graph))
+                         (gr_vertex_to_node graph)
+                         (gr_node_to_vertex graph)
+
+emptyG :: Graph node -> Bool
+emptyG g = graphEmpty (gr_int_graph g)
+
+{-
+************************************************************************
+*                                                                      *
+*      Showing Graphs
+*                                                                      *
+************************************************************************
+-}
+
+instance Outputable node => Outputable (Graph node) where
+    ppr graph = vcat [
+                  hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),
+                  hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))
+                ]
+
+instance Outputable node => Outputable (Edge node) where
+    ppr (Edge from to) = ppr from <+> text "->" <+> ppr to
+
+graphEmpty :: G.Graph -> Bool
+graphEmpty g = lo > hi
+  where (lo, hi) = bounds g
+
+{-
+************************************************************************
+*                                                                      *
+*      IntGraphs
+*                                                                      *
+************************************************************************
+-}
+
+type IntGraph = G.Graph
+
+{-
+------------------------------------------------------------
+-- Depth first search numbering
+------------------------------------------------------------
+-}
+
+-- Data.Tree has flatten for Tree, but nothing for Forest
+preorderF           :: Forest a -> [a]
+preorderF ts         = concatMap flatten ts
+
+{-
+------------------------------------------------------------
+-- Finding reachable vertices
+------------------------------------------------------------
+-}
+
+-- This generalizes reachable which was found in Data.Graph
+reachable    :: IntGraph -> [Vertex] -> [Vertex]
+reachable g vs = preorderF (dfs g vs)
+
+{-
+************************************************************************
+*                                                                      *
+*                         Classify Edge Types
+*                                                                      *
+************************************************************************
+-}
+
+-- Remark: While we could generalize this algorithm this comes at a runtime
+-- cost and with no advantages. If you find yourself using this with graphs
+-- not easily represented using Int nodes please consider rewriting this
+-- using the more general Graph type.
+
+-- | Edge direction based on DFS Classification
+data EdgeType
+  = Forward
+  | Cross
+  | Backward -- ^ Loop back towards the root node.
+             -- Eg backjumps in loops
+  | SelfLoop -- ^ v -> v
+   deriving (Eq,Ord)
+
+instance Outputable EdgeType where
+  ppr Forward = text "Forward"
+  ppr Cross = text "Cross"
+  ppr Backward = text "Backward"
+  ppr SelfLoop = text "SelfLoop"
+
+newtype Time = Time Int deriving (Eq,Ord,Num,Outputable)
+
+--Allow for specialization
+{-# INLINEABLE classifyEdges #-}
+
+-- | Given a start vertex, a way to get successors from a node
+-- and a list of (directed) edges classify the types of edges.
+classifyEdges :: forall key. Uniquable key => key -> (key -> [key])
+              -> [(key,key)] -> [((key, key), EdgeType)]
+classifyEdges root getSucc edges =
+    --let uqe (from,to) = (getUnique from, getUnique to)
+    --in pprTrace "Edges:" (ppr $ map uqe edges) $
+    zip edges $ map classify edges
+  where
+    (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root
+    classify :: (key,key) -> EdgeType
+    classify (from,to)
+      | startFrom < startTo
+      , endFrom   > endTo
+      = Forward
+      | startFrom > startTo
+      , endFrom   < endTo
+      = Backward
+      | startFrom > startTo
+      , endFrom   > endTo
+      = Cross
+      | getUnique from == getUnique to
+      = SelfLoop
+      | otherwise
+      = pprPanic "Failed to classify edge of Graph"
+                 (ppr (getUnique from, getUnique to))
+
+      where
+        getTime event node
+          | Just time <- lookupUFM event node
+          = time
+          | otherwise
+          = pprPanic "Failed to classify edge of CFG - not not timed"
+            (text "edges" <> ppr (getUnique from, getUnique to)
+                          <+> ppr starts <+> ppr ends )
+        startFrom = getTime starts from
+        startTo   = getTime starts to
+        endFrom   = getTime ends   from
+        endTo     = getTime ends   to
+
+    addTimes :: (Time, UniqFM Time, UniqFM Time) -> key
+             -> (Time, UniqFM Time, UniqFM Time)
+    addTimes (time,starts,ends) n
+      --Dont reenter nodes
+      | elemUFM n starts
+      = (time,starts,ends)
+      | otherwise =
+        let
+          starts' = addToUFM starts n time
+          time' = time + 1
+          succs = getSucc n :: [key]
+          (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs
+          ends'' = addToUFM ends' n time''
+        in
+        (time'' + 1, starts'', ends'')
diff --git a/compiler/GHC/Data/Graph/Ops.hs b/compiler/GHC/Data/Graph/Ops.hs
new file mode 100644
index 0000000000..7d9ce669c6
--- /dev/null
+++ b/compiler/GHC/Data/Graph/Ops.hs
@@ -0,0 +1,698 @@
+-- | Basic operations on graphs.
+--
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module GHC.Data.Graph.Ops
+   ( addNode
+   , delNode
+   , getNode
+   , lookupNode
+   , modNode
+
+   , size
+   , union
+
+   , addConflict
+   , delConflict
+   , addConflicts
+
+   , addCoalesce
+   , delCoalesce
+
+   , addExclusion
+   , addExclusions
+
+   , addPreference
+   , coalesceNodes
+   , coalesceGraph
+   , freezeNode
+   , freezeOneInGraph
+   , freezeAllInGraph
+   , scanGraph
+   , setColor
+   , validateGraph
+   , slurpNodeConflictCount
+   )
+where
+
+import GHC.Prelude
+
+import GHC.Data.Graph.Base
+
+import GHC.Utils.Outputable
+import GHC.Types.Unique
+import GHC.Types.Unique.Set
+import GHC.Types.Unique.FM
+
+import Data.List        hiding (union)
+import Data.Maybe
+
+-- | Lookup a node from the graph.
+lookupNode
+        :: Uniquable k
+        => Graph k cls color
+        -> k -> Maybe (Node  k cls color)
+
+lookupNode graph k
+        = lookupUFM (graphMap graph) k
+
+
+-- | Get a node from the graph, throwing an error if it's not there
+getNode
+        :: Uniquable k
+        => Graph k cls color
+        -> k -> Node k cls color
+
+getNode graph k
+ = case lookupUFM (graphMap graph) k of
+        Just node       -> node
+        Nothing         -> panic "ColorOps.getNode: not found"
+
+
+-- | Add a node to the graph, linking up its edges
+addNode :: Uniquable k
+        => k -> Node k cls color
+        -> Graph k cls color -> Graph k cls color
+
+addNode k node graph
+ = let
+        -- add back conflict edges from other nodes to this one
+        map_conflict =
+          nonDetFoldUniqSet
+            -- It's OK to use nonDetFoldUFM here because the
+            -- operation is commutative
+            (adjustUFM_C (\n -> n { nodeConflicts =
+                                      addOneToUniqSet (nodeConflicts n) k}))
+            (graphMap graph)
+            (nodeConflicts node)
+
+        -- add back coalesce edges from other nodes to this one
+        map_coalesce =
+          nonDetFoldUniqSet
+            -- It's OK to use nonDetFoldUFM here because the
+            -- operation is commutative
+            (adjustUFM_C (\n -> n { nodeCoalesce =
+                                      addOneToUniqSet (nodeCoalesce n) k}))
+            map_conflict
+            (nodeCoalesce node)
+
+  in    graph
+        { graphMap      = addToUFM map_coalesce k node}
+
+
+-- | Delete a node and all its edges from the graph.
+delNode :: (Uniquable k)
+        => k -> Graph k cls color -> Maybe (Graph k cls color)
+
+delNode k graph
+        | Just node     <- lookupNode graph k
+        = let   -- delete conflict edges from other nodes to this one.
+                graph1  = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
+                        $ nonDetEltsUniqSet (nodeConflicts node)
+
+                -- delete coalesce edge from other nodes to this one.
+                graph2  = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
+                        $ nonDetEltsUniqSet (nodeCoalesce node)
+                        -- See Note [Unique Determinism and code generation]
+
+                -- delete the node
+                graph3  = graphMapModify (\fm -> delFromUFM fm k) graph2
+
+          in    Just graph3
+
+        | otherwise
+        = Nothing
+
+
+-- | Modify a node in the graph.
+--      returns Nothing if the node isn't present.
+--
+modNode :: Uniquable k
+        => (Node k cls color -> Node k cls color)
+        -> k -> Graph k cls color -> Maybe (Graph k cls color)
+
+modNode f k graph
+ = case lookupNode graph k of
+        Just Node{}
+         -> Just
+         $  graphMapModify
+                 (\fm   -> let  Just node       = lookupUFM fm k
+                                node'           = f node
+                           in   addToUFM fm k node')
+                graph
+
+        Nothing -> Nothing
+
+
+-- | Get the size of the graph, O(n)
+size    :: Graph k cls color -> Int
+
+size graph
+        = sizeUFM $ graphMap graph
+
+
+-- | Union two graphs together.
+union   :: Graph k cls color -> Graph k cls color -> Graph k cls color
+
+union   graph1 graph2
+        = Graph
+        { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }
+
+
+-- | Add a conflict between nodes to the graph, creating the nodes required.
+--      Conflicts are virtual regs which need to be colored differently.
+addConflict
+        :: Uniquable k
+        => (k, cls) -> (k, cls)
+        -> Graph k cls color -> Graph k cls color
+
+addConflict (u1, c1) (u2, c2)
+ = let  addNeighbor u c u'
+                = adjustWithDefaultUFM
+                        (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
+                        (newNode u c)  { nodeConflicts = unitUniqSet u' }
+                        u
+
+   in   graphMapModify
+        ( addNeighbor u1 c1 u2
+        . addNeighbor u2 c2 u1)
+
+
+-- | Delete a conflict edge. k1 -> k2
+--      returns Nothing if the node isn't in the graph
+delConflict
+        :: Uniquable k
+        => k -> k
+        -> Graph k cls color -> Maybe (Graph k cls color)
+
+delConflict k1 k2
+        = modNode
+                (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
+                k1
+
+
+-- | Add some conflicts to the graph, creating nodes if required.
+--      All the nodes in the set are taken to conflict with each other.
+addConflicts
+        :: Uniquable k
+        => UniqSet k -> (k -> cls)
+        -> Graph k cls color -> Graph k cls color
+
+addConflicts conflicts getClass
+
+        -- just a single node, but no conflicts, create the node anyway.
+        | (u : [])      <- nonDetEltsUniqSet conflicts
+        = graphMapModify
+        $ adjustWithDefaultUFM
+                id
+                (newNode u (getClass u))
+                u
+
+        | otherwise
+        = graphMapModify
+        $ \fm -> foldl' (\g u  -> addConflictSet1 u getClass conflicts g) fm
+                $ nonDetEltsUniqSet conflicts
+                -- See Note [Unique Determinism and code generation]
+
+
+addConflictSet1 :: Uniquable k
+                => k -> (k -> cls) -> UniqSet k
+                -> UniqFM (Node k cls color)
+                -> UniqFM (Node k cls color)
+addConflictSet1 u getClass set
+ = case delOneFromUniqSet set u of
+    set' -> adjustWithDefaultUFM
+                (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
+                (newNode u (getClass u))        { nodeConflicts = set' }
+                u
+
+
+-- | Add an exclusion to the graph, creating nodes if required.
+--      These are extra colors that the node cannot use.
+addExclusion
+        :: (Uniquable k, Uniquable color)
+        => k -> (k -> cls) -> color
+        -> Graph k cls color -> Graph k cls color
+
+addExclusion u getClass color
+        = graphMapModify
+        $ adjustWithDefaultUFM
+                (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
+                (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }
+                u
+
+addExclusions
+        :: (Uniquable k, Uniquable color)
+        => k -> (k -> cls) -> [color]
+        -> Graph k cls color -> Graph k cls color
+
+addExclusions u getClass colors graph
+        = foldr (addExclusion u getClass) graph colors
+
+
+-- | Add a coalescence edge to the graph, creating nodes if required.
+--      It is considered adventageous to assign the same color to nodes in a coalesence.
+addCoalesce
+        :: Uniquable k
+        => (k, cls) -> (k, cls)
+        -> Graph k cls color -> Graph k cls color
+
+addCoalesce (u1, c1) (u2, c2)
+ = let  addCoalesce u c u'
+         =      adjustWithDefaultUFM
+                        (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
+                        (newNode u c)  { nodeCoalesce = unitUniqSet u' }
+                        u
+
+   in   graphMapModify
+        ( addCoalesce u1 c1 u2
+        . addCoalesce u2 c2 u1)
+
+
+-- | Delete a coalescence edge (k1 -> k2) from the graph.
+delCoalesce
+        :: Uniquable k
+        => k -> k
+        -> Graph k cls color    -> Maybe (Graph k cls color)
+
+delCoalesce k1 k2
+        = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
+                k1
+
+
+-- | Add a color preference to the graph, creating nodes if required.
+--      The most recently added preference is the most preferred.
+--      The algorithm tries to assign a node it's preferred color if possible.
+--
+addPreference
+        :: Uniquable k
+        => (k, cls) -> color
+        -> Graph k cls color -> Graph k cls color
+
+addPreference (u, c) color
+        = graphMapModify
+        $ adjustWithDefaultUFM
+                (\node -> node { nodePreference = color : (nodePreference node) })
+                (newNode u c)  { nodePreference = [color] }
+                u
+
+
+-- | Do aggressive coalescing on this graph.
+--      returns the new graph and the list of pairs of nodes that got coalesced together.
+--      for each pair, the resulting node will have the least key and be second in the pair.
+--
+coalesceGraph
+        :: (Uniquable k, Ord k, Eq cls, Outputable k)
+        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
+                                --      less colorable (aggressive coalescing)
+        -> Triv k cls color
+        -> Graph k cls color
+        -> ( Graph k cls color
+           , [(k, k)])          -- pairs of nodes that were coalesced, in the order that the
+                                --      coalescing was applied.
+
+coalesceGraph aggressive triv graph
+        = coalesceGraph' aggressive triv graph []
+
+coalesceGraph'
+        :: (Uniquable k, Ord k, Eq cls, Outputable k)
+        => Bool
+        -> Triv k cls color
+        -> Graph k cls color
+        -> [(k, k)]
+        -> ( Graph k cls color
+           , [(k, k)])
+coalesceGraph' aggressive triv graph kkPairsAcc
+ = let
+        -- find all the nodes that have coalescence edges
+        cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
+                $ nonDetEltsUFM $ graphMap graph
+                -- See Note [Unique Determinism and code generation]
+
+        -- build a list of pairs of keys for node's we'll try and coalesce
+        --      every pair of nodes will appear twice in this list
+        --      ie [(k1, k2), (k2, k1) ... ]
+        --      This is ok, GrapOps.coalesceNodes handles this and it's convenient for
+        --      build a list of what nodes get coalesced together for later on.
+        --
+        cList   = [ (nodeId node1, k2)
+                        | node1 <- cNodes
+                        , k2    <- nonDetEltsUniqSet $ nodeCoalesce node1 ]
+                        -- See Note [Unique Determinism and code generation]
+
+        -- do the coalescing, returning the new graph and a list of pairs of keys
+        --      that got coalesced together.
+        (graph', mPairs)
+                = mapAccumL (coalesceNodes aggressive triv) graph cList
+
+        -- keep running until there are no more coalesces can be found
+   in   case catMaybes mPairs of
+         []     -> (graph', reverse kkPairsAcc)
+         pairs  -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)
+
+
+-- | Coalesce this pair of nodes unconditionally \/ aggressively.
+--      The resulting node is the one with the least key.
+--
+--      returns: Just    the pair of keys if the nodes were coalesced
+--                       the second element of the pair being the least one
+--
+--               Nothing if either of the nodes weren't in the graph
+
+coalesceNodes
+        :: (Uniquable k, Ord k, Eq cls)
+        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
+                                --      less colorable (aggressive coalescing)
+        -> Triv  k cls color
+        -> Graph k cls color
+        -> (k, k)               -- ^ keys of the nodes to be coalesced
+        -> (Graph k cls color, Maybe (k, k))
+
+coalesceNodes aggressive triv graph (k1, k2)
+        | (kMin, kMax)  <- if k1 < k2
+                                then (k1, k2)
+                                else (k2, k1)
+
+        -- the nodes being coalesced must be in the graph
+        , Just nMin     <- lookupNode graph kMin
+        , Just nMax     <- lookupNode graph kMax
+
+        -- can't coalesce conflicting modes
+        , not $ elementOfUniqSet kMin (nodeConflicts nMax)
+        , not $ elementOfUniqSet kMax (nodeConflicts nMin)
+
+        -- can't coalesce the same node
+        , nodeId nMin /= nodeId nMax
+
+        = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
+
+        -- don't do the coalescing after all
+        | otherwise
+        = (graph, Nothing)
+
+coalesceNodes_merge
+        :: (Uniquable k, Eq cls)
+        => Bool
+        -> Triv  k cls color
+        -> Graph k cls color
+        -> k -> k
+        -> Node k cls color
+        -> Node k cls color
+        -> (Graph k cls color, Maybe (k, k))
+
+coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
+
+        -- sanity checks
+        | nodeClass nMin /= nodeClass nMax
+        = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce nodes of different classes."
+
+        | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
+        = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce colored nodes."
+
+        ---
+        | otherwise
+        = let
+                -- the new node gets all the edges from its two components
+                node    =
+                 Node   { nodeId                = kMin
+                        , nodeClass             = nodeClass nMin
+                        , nodeColor             = Nothing
+
+                        -- nodes don't conflict with themselves..
+                        , nodeConflicts
+                                = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
+                                        `delOneFromUniqSet` kMin
+                                        `delOneFromUniqSet` kMax
+
+                        , nodeExclusions        = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
+                        , nodePreference        = nodePreference nMin ++ nodePreference nMax
+
+                        -- nodes don't coalesce with themselves..
+                        , nodeCoalesce
+                                = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
+                                        `delOneFromUniqSet` kMin
+                                        `delOneFromUniqSet` kMax
+                        }
+
+          in    coalesceNodes_check aggressive triv graph kMin kMax node
+
+coalesceNodes_check
+        :: Uniquable k
+        => Bool
+        -> Triv  k cls color
+        -> Graph k cls color
+        -> k -> k
+        -> Node k cls color
+        -> (Graph k cls color, Maybe (k, k))
+
+coalesceNodes_check aggressive triv graph kMin kMax node
+
+        -- Unless we're coalescing aggressively, if the result node is not trivially
+        --      colorable then don't do the coalescing.
+        | not aggressive
+        , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+        = (graph, Nothing)
+
+        | otherwise
+        = let -- delete the old nodes from the graph and add the new one
+                Just graph1     = delNode kMax graph
+                Just graph2     = delNode kMin graph1
+                graph3          = addNode kMin node graph2
+
+          in    (graph3, Just (kMax, kMin))
+
+
+-- | Freeze a node
+--      This is for the iterative coalescer.
+--      By freezing a node we give up on ever coalescing it.
+--      Move all its coalesce edges into the frozen set - and update
+--      back edges from other nodes.
+--
+freezeNode
+        :: Uniquable k
+        => k                    -- ^ key of the node to freeze
+        -> Graph k cls color    -- ^ the graph
+        -> Graph k cls color    -- ^ graph with that node frozen
+
+freezeNode k
+  = graphMapModify
+  $ \fm ->
+    let -- freeze all the edges in the node to be frozen
+        Just node = lookupUFM fm k
+        node'   = node
+                { nodeCoalesce          = emptyUniqSet }
+
+        fm1     = addToUFM fm k node'
+
+        -- update back edges pointing to this node
+        freezeEdge k node
+         = if elementOfUniqSet k (nodeCoalesce node)
+                then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k }
+                else node       -- panic "GHC.Data.Graph.Ops.freezeNode: edge to freeze wasn't in the coalesce set"
+                                -- If the edge isn't actually in the coelesce set then just ignore it.
+
+        fm2     = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1
+                    -- It's OK to use nonDetFoldUFM here because the operation
+                    -- is commutative
+                        $ nodeCoalesce node
+
+    in  fm2
+
+
+-- | Freeze one node in the graph
+--      This if for the iterative coalescer.
+--      Look for a move related node of low degree and freeze it.
+--
+--      We probably don't need to scan the whole graph looking for the node of absolute
+--      lowest degree. Just sample the first few and choose the one with the lowest
+--      degree out of those. Also, we don't make any distinction between conflicts of different
+--      classes.. this is just a heuristic, after all.
+--
+--      IDEA:   freezing a node might free it up for Simplify.. would be good to check for triv
+--              right here, and add it to a worklist if known triv\/non-move nodes.
+--
+freezeOneInGraph
+        :: (Uniquable k)
+        => Graph k cls color
+        -> ( Graph k cls color          -- the new graph
+           , Bool )                     -- whether we found a node to freeze
+
+freezeOneInGraph graph
+ = let  compareNodeDegree n1 n2
+                = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2)
+
+        candidates
+                = sortBy compareNodeDegree
+                $ take 5        -- 5 isn't special, it's just a small number.
+                $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph
+
+   in   case candidates of
+
+         -- there wasn't anything available to freeze
+         []     -> (graph, False)
+
+         -- we found something to freeze
+         (n : _)
+          -> ( freezeNode (nodeId n) graph
+             , True)
+
+
+-- | Freeze all the nodes in the graph
+--      for debugging the iterative allocator.
+--
+freezeAllInGraph
+        :: (Uniquable k)
+        => Graph k cls color
+        -> Graph k cls color
+
+freezeAllInGraph graph
+        = foldr freezeNode graph
+                $ map nodeId
+                $ nonDetEltsUFM $ graphMap graph
+                -- See Note [Unique Determinism and code generation]
+
+
+-- | Find all the nodes in the graph that meet some criteria
+--
+scanGraph
+        :: (Node k cls color -> Bool)
+        -> Graph k cls color
+        -> [Node k cls color]
+
+scanGraph match graph
+        = filter match $ nonDetEltsUFM $ graphMap graph
+          -- See Note [Unique Determinism and code generation]
+
+
+-- | validate the internal structure of a graph
+--      all its edges should point to valid nodes
+--      If they don't then throw an error
+--
+validateGraph
+        :: (Uniquable k, Outputable k, Eq color)
+        => SDoc                         -- ^ extra debugging info to display on error
+        -> Bool                         -- ^ whether this graph is supposed to be colored.
+        -> Graph k cls color            -- ^ graph to validate
+        -> Graph k cls color            -- ^ validated graph
+
+validateGraph doc isColored graph
+
+        -- Check that all edges point to valid nodes.
+        | edges         <- unionManyUniqSets
+                                (  (map nodeConflicts       $ nonDetEltsUFM $ graphMap graph)
+                                ++ (map nodeCoalesce        $ nonDetEltsUFM $ graphMap graph))
+
+        , nodes         <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph
+        , badEdges      <- minusUniqSet edges nodes
+        , not $ isEmptyUniqSet badEdges
+        = pprPanic "GHC.Data.Graph.Ops.validateGraph"
+                (  text "Graph has edges that point to non-existent nodes"
+                $$ text "  bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr)
+                $$ doc )
+
+        -- Check that no conflicting nodes have the same color
+        | badNodes      <- filter (not . (checkNode graph))
+                        $ nonDetEltsUFM $ graphMap graph
+                           -- See Note [Unique Determinism and code generation]
+        , not $ null badNodes
+        = pprPanic "GHC.Data.Graph.Ops.validateGraph"
+                (  text "Node has same color as one of it's conflicts"
+                $$ text "  bad nodes: " <> hcat (map (ppr . nodeId) badNodes)
+                $$ doc)
+
+        -- If this is supposed to be a colored graph,
+        --      check that all nodes have a color.
+        | isColored
+        , badNodes      <- filter (\n -> isNothing $ nodeColor n)
+                        $  nonDetEltsUFM $ graphMap graph
+        , not $ null badNodes
+        = pprPanic "GHC.Data.Graph.Ops.validateGraph"
+                (  text "Supposably colored graph has uncolored nodes."
+                $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)
+                $$ doc )
+
+
+        -- graph looks ok
+        | otherwise
+        = graph
+
+
+-- | If this node is colored, check that all the nodes which
+--      conflict with it have different colors.
+checkNode
+        :: (Uniquable k, Eq color)
+        => Graph k cls color
+        -> Node  k cls color
+        -> Bool                 -- ^ True if this node is ok
+
+checkNode graph node
+        | Just color            <- nodeColor node
+        , Just neighbors        <- sequence $ map (lookupNode graph)
+                                $  nonDetEltsUniqSet $ nodeConflicts node
+            -- See Note [Unique Determinism and code generation]
+
+        , neighbourColors       <- catMaybes $ map nodeColor neighbors
+        , elem color neighbourColors
+        = False
+
+        | otherwise
+        = True
+
+
+
+-- | Slurp out a map of how many nodes had a certain number of conflict neighbours
+
+slurpNodeConflictCount
+        :: Graph k cls color
+        -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)
+
+slurpNodeConflictCount graph
+        = addListToUFM_C
+                (\(c1, n1) (_, n2) -> (c1, n1 + n2))
+                emptyUFM
+        $ map   (\node
+                  -> let count  = sizeUniqSet $ nodeConflicts node
+                     in  (count, (count, 1)))
+        $ nonDetEltsUFM
+        -- See Note [Unique Determinism and code generation]
+        $ graphMap graph
+
+
+-- | Set the color of a certain node
+setColor
+        :: Uniquable k
+        => k -> color
+        -> Graph k cls color -> Graph k cls color
+
+setColor u color
+        = graphMapModify
+        $ adjustUFM_C
+                (\n -> n { nodeColor = Just color })
+                u
+
+
+{-# INLINE adjustWithDefaultUFM #-}
+adjustWithDefaultUFM
+        :: Uniquable k
+        => (a -> a) -> a -> k
+        -> UniqFM a -> UniqFM a
+
+adjustWithDefaultUFM f def k map
+        = addToUFM_C
+                (\old _ -> f old)
+                map
+                k def
+
+-- Argument order different from UniqFM's adjustUFM
+{-# INLINE adjustUFM_C #-}
+adjustUFM_C
+        :: Uniquable k
+        => (a -> a)
+        -> k -> UniqFM a -> UniqFM a
+
+adjustUFM_C f k map
+ = case lookupUFM map k of
+        Nothing -> map
+        Just a  -> addToUFM map k (f a)
+
diff --git a/compiler/GHC/Data/Graph/Ppr.hs b/compiler/GHC/Data/Graph/Ppr.hs
new file mode 100644
index 0000000000..020284ea7e
--- /dev/null
+++ b/compiler/GHC/Data/Graph/Ppr.hs
@@ -0,0 +1,173 @@
+
+-- | Pretty printing of graphs.
+
+module GHC.Data.Graph.Ppr
+   ( dumpGraph
+   , dotGraph
+   )
+where
+
+import GHC.Prelude
+
+import GHC.Data.Graph.Base
+
+import GHC.Utils.Outputable
+import GHC.Types.Unique
+import GHC.Types.Unique.Set
+import GHC.Types.Unique.FM
+
+import Data.List (mapAccumL)
+import Data.Maybe
+
+
+-- | Pretty print a graph in a somewhat human readable format.
+dumpGraph
+        :: (Outputable k, Outputable color)
+        => Graph k cls color -> SDoc
+
+dumpGraph graph
+        =  text "Graph"
+        $$ pprUFM (graphMap graph) (vcat . map dumpNode)
+
+dumpNode
+        :: (Outputable k, Outputable color)
+        => Node k cls color -> SDoc
+
+dumpNode node
+        =  text "Node " <> ppr (nodeId node)
+        $$ text "conflicts "
+                <> parens (int (sizeUniqSet $ nodeConflicts node))
+                <> text " = "
+                <> ppr (nodeConflicts node)
+
+        $$ text "exclusions "
+                <> parens (int (sizeUniqSet $ nodeExclusions node))
+                <> text " = "
+                <> ppr (nodeExclusions node)
+
+        $$ text "coalesce "
+                <> parens (int (sizeUniqSet $ nodeCoalesce node))
+                <> text " = "
+                <> ppr (nodeCoalesce node)
+
+        $$ space
+
+
+
+-- | Pretty print a graph in graphviz .dot format.
+--      Conflicts get solid edges.
+--      Coalescences get dashed edges.
+dotGraph
+        :: ( Uniquable k
+           , Outputable k, Outputable cls, Outputable color)
+        => (color -> SDoc)  -- ^ What graphviz color to use for each node color
+                            --  It's usually safe to return X11 style colors here,
+                            --  ie "red", "green" etc or a hex triplet #aaff55 etc
+        -> Triv k cls color
+        -> Graph k cls color -> SDoc
+
+dotGraph colorMap triv graph
+ = let  nodes   = nonDetEltsUFM $ graphMap graph
+                  -- See Note [Unique Determinism and code generation]
+   in   vcat
+                (  [ text "graph G {" ]
+                ++ map (dotNode colorMap triv) nodes
+                ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
+                ++ [ text "}"
+                   , space ])
+
+
+dotNode :: ( Outputable k, Outputable cls, Outputable color)
+        => (color -> SDoc)
+        -> Triv k cls color
+        -> Node k cls color -> SDoc
+
+dotNode colorMap triv node
+ = let  name    = ppr $ nodeId node
+        cls     = ppr $ nodeClass node
+
+        excludes
+                = hcat $ punctuate space
+                $ map (\n -> text "-" <> ppr n)
+                $ nonDetEltsUniqSet $ nodeExclusions node
+                -- See Note [Unique Determinism and code generation]
+
+        preferences
+                = hcat $ punctuate space
+                $ map (\n -> text "+" <> ppr n)
+                $ nodePreference node
+
+        expref  = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]
+                        then empty
+                        else text "\\n" <> (excludes <+> preferences)
+
+        -- if the node has been colored then show that,
+        --      otherwise indicate whether it looks trivially colorable.
+        color
+                | Just c        <- nodeColor node
+                = text "\\n(" <> ppr c <> text ")"
+
+                | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+                = text "\\n(" <> text "triv" <> text ")"
+
+                | otherwise
+                = text "\\n(" <> text "spill?" <> text ")"
+
+        label   =  name <> text " :: " <> cls
+                <> expref
+                <> color
+
+        pcolorC = case nodeColor node of
+                        Nothing -> text "style=filled fillcolor=white"
+                        Just c  -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)
+
+
+        pout    = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"
+                <> space <> doubleQuotes name
+                <> text ";"
+
+ in     pout
+
+
+-- | Nodes in the graph are doubly linked, but we only want one edge for each
+--      conflict if the graphviz graph. Traverse over the graph, but make sure
+--      to only print the edges for each node once.
+
+dotNodeEdges
+        :: ( Uniquable k
+           , Outputable k)
+        => UniqSet k
+        -> Node k cls color
+        -> (UniqSet k, Maybe SDoc)
+
+dotNodeEdges visited node
+        | elementOfUniqSet (nodeId node) visited
+        = ( visited
+          , Nothing)
+
+        | otherwise
+        = let   dconflicts
+                        = map (dotEdgeConflict (nodeId node))
+                        $ nonDetEltsUniqSet
+                        -- See Note [Unique Determinism and code generation]
+                        $ minusUniqSet (nodeConflicts node) visited
+
+                dcoalesces
+                        = map (dotEdgeCoalesce (nodeId node))
+                        $ nonDetEltsUniqSet
+                        -- See Note [Unique Determinism and code generation]
+                        $ minusUniqSet (nodeCoalesce node) visited
+
+                out     =  vcat dconflicts
+                        $$ vcat dcoalesces
+
+          in    ( addOneToUniqSet visited (nodeId node)
+                , Just out)
+
+        where   dotEdgeConflict u1 u2
+                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
+                        <> text ";"
+
+                dotEdgeCoalesce u1 u2
+                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
+                        <> space <> text "[ style = dashed ];"
diff --git a/compiler/GHC/Data/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs
new file mode 100644
index 0000000000..4d1657ce62
--- /dev/null
+++ b/compiler/GHC/Data/Graph/UnVar.hs
@@ -0,0 +1,145 @@
+{-
+
+Copyright (c) 2014 Joachim Breitner
+
+A data structure for undirected graphs of variables
+(or in plain terms: Sets of unordered pairs of numbers)
+
+
+This is very specifically tailored for the use in CallArity. In particular it
+stores the graph as a union of complete and complete bipartite graph, which
+would be very expensive to store as sets of edges or as adjanceny lists.
+
+It does not normalize the graphs. This means that g `unionUnVarGraph` g is
+equal to g, but twice as expensive and large.
+
+-}
+module GHC.Data.Graph.UnVar
+    ( UnVarSet
+    , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
+    , delUnVarSet
+    , elemUnVarSet, isEmptyUnVarSet
+    , UnVarGraph
+    , emptyUnVarGraph
+    , unionUnVarGraph, unionUnVarGraphs
+    , completeGraph, completeBipartiteGraph
+    , neighbors
+    , hasLoopAt
+    , delNode
+    ) where
+
+import GHC.Prelude
+
+import GHC.Types.Id
+import GHC.Types.Var.Env
+import GHC.Types.Unique.FM
+import GHC.Utils.Outputable
+import GHC.Data.Bag
+import GHC.Types.Unique
+
+import qualified Data.IntSet as S
+
+-- We need a type for sets of variables (UnVarSet).
+-- We do not use VarSet, because for that we need to have the actual variable
+-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.
+-- Therefore, use a IntSet directly (which is likely also a bit more efficient).
+
+-- Set of uniques, i.e. for adjancet nodes
+newtype UnVarSet = UnVarSet (S.IntSet)
+    deriving Eq
+
+k :: Var -> Int
+k v = getKey (getUnique v)
+
+emptyUnVarSet :: UnVarSet
+emptyUnVarSet = UnVarSet S.empty
+
+elemUnVarSet :: Var -> UnVarSet -> Bool
+elemUnVarSet v (UnVarSet s) = k v `S.member` s
+
+
+isEmptyUnVarSet :: UnVarSet -> Bool
+isEmptyUnVarSet (UnVarSet s) = S.null s
+
+delUnVarSet :: UnVarSet -> Var -> UnVarSet
+delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s
+
+mkUnVarSet :: [Var] -> UnVarSet
+mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs
+
+varEnvDom :: VarEnv a -> UnVarSet
+varEnvDom ae = UnVarSet $ ufmToSet_Directly ae
+
+unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
+unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)
+
+unionUnVarSets :: [UnVarSet] -> UnVarSet
+unionUnVarSets = foldr unionUnVarSet emptyUnVarSet
+
+instance Outputable UnVarSet where
+    ppr (UnVarSet s) = braces $
+        hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]
+
+
+-- The graph type. A list of complete bipartite graphs
+data Gen = CBPG UnVarSet UnVarSet -- complete bipartite
+         | CG   UnVarSet          -- complete
+newtype UnVarGraph = UnVarGraph (Bag Gen)
+
+emptyUnVarGraph :: UnVarGraph
+emptyUnVarGraph = UnVarGraph emptyBag
+
+unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph
+{-
+Premature optimisation, it seems.
+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
+    | s1 == s3 && s2 == s4
+    = pprTrace "unionUnVarGraph fired" empty $
+      completeGraph (s1 `unionUnVarSet` s2)
+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
+    | s2 == s3 && s1 == s4
+    = pprTrace "unionUnVarGraph fired2" empty $
+      completeGraph (s1 `unionUnVarSet` s2)
+-}
+unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2)
+    = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $
+      UnVarGraph (g1 `unionBags` g2)
+
+unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph
+unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph
+
+-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }
+completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph
+completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2
+
+completeGraph :: UnVarSet -> UnVarGraph
+completeGraph s = prune $ UnVarGraph $ unitBag $ CG s
+
+neighbors :: UnVarGraph -> Var -> UnVarSet
+neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g
+  where go (CG s)       = (if v `elemUnVarSet` s then [s] else [])
+        go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++
+                          (if v `elemUnVarSet` s2 then [s1] else [])
+
+-- hasLoopAt G v <=> v--v ∈ G
+hasLoopAt :: UnVarGraph -> Var -> Bool
+hasLoopAt (UnVarGraph g) v = any go $ bagToList g
+  where go (CG s)       = v `elemUnVarSet` s
+        go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2
+
+
+delNode :: UnVarGraph -> Var -> UnVarGraph
+delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g
+  where go (CG s)       = CG (s `delUnVarSet` v)
+        go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v)
+
+prune :: UnVarGraph -> UnVarGraph
+prune (UnVarGraph g) = UnVarGraph $ filterBag go g
+  where go (CG s)       = not (isEmptyUnVarSet s)
+        go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2)
+
+instance Outputable Gen where
+    ppr (CG s)       = ppr s  <> char '²'
+    ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2
+instance Outputable UnVarGraph where
+    ppr (UnVarGraph g) = ppr g