add the two key graph modules from Martin Erwig's FGL

Martin Erwig's FGL (Functional Graph Library) provides an "inductive"
representation of graphs.  A general graph has labeled nodes and
labeled edges.  The key operation on a graph is to decompose it by
removing one node, together with the edges that connect the node to
the rest of the graph.  There is also an inverse composition
operation.

The decomposition and composition operations make this representation
of graphs exceptionally well suited to implement graph algorithms in
which the graph is continually changing, as alluded to in #21259.

This commit adds `GHC.Data.Graph.Inductive.Graph`, which defines the
interface, and `GHC.Data.Graph.Inductive.PatriciaTree`, which provides
an implementation.  Both modules are taken from `fgl-5.7.0.3` on
Hackage, with these changes:

  - Copyright and license text have been copied into the files
    themselves, not stored separately.

  - Some calls to `error` have been replaced with calls to `panic`.

  - Conditional-compilation support for older versions of GHC,
    `containers`, and `base` has been removed.

3 files changed, 983 insertions, 0 deletions

diff --git a/compiler/GHC/Data/Graph/Inductive/Graph.hs b/compiler/GHC/Data/Graph/Inductive/Graph.hs
new file mode 100644
index 0000000000..8a72c30d7a
--- /dev/null
+++ b/compiler/GHC/Data/Graph/Inductive/Graph.hs
@@ -0,0 +1,640 @@
+-- (c) 1999-2005 by Martin Erwig (see copyright at bottom)
+-- | Static and Dynamic Inductive Graphs
+module GHC.Data.Graph.Inductive.Graph (
+    -- * General Type Defintions
+    -- ** Node and Edge Types
+    Node,LNode,UNode,
+    Edge,LEdge,UEdge,
+    -- ** Types Supporting Inductive Graph View
+    Adj,Context,MContext,Decomp,GDecomp,UContext,UDecomp,
+    Path,LPath(..),UPath,
+    -- * Graph Type Classes
+    -- | We define two graph classes:
+    --
+    --   Graph: static, decomposable graphs.
+    --    Static means that a graph itself cannot be changed
+    --
+    --   DynGraph: dynamic, extensible graphs.
+    --             Dynamic graphs inherit all operations from static graphs
+    --             but also offer operations to extend and change graphs.
+    --
+    -- Each class contains in addition to its essential operations those
+    -- derived operations that might be overwritten by a more efficient
+    -- implementation in an instance definition.
+    --
+    -- Note that labNodes is essentially needed because the default definition
+    -- for matchAny is based on it: we need some node from the graph to define
+    -- matchAny in terms of match. Alternatively, we could have made matchAny
+    -- essential and have labNodes defined in terms of ufold and matchAny.
+    -- However, in general, labNodes seems to be (at least) as easy to define
+    -- as matchAny. We have chosen labNodes instead of the function nodes since
+    -- nodes can be easily derived from labNodes, but not vice versa.
+    Graph(..),
+    DynGraph(..),
+    -- * Operations
+    order,
+    size,
+    -- ** Graph Folds and Maps
+    ufold,gmap,nmap,emap,nemap,
+    -- ** Graph Projection
+    nodes,edges,toEdge,edgeLabel,toLEdge,newNodes,gelem,
+    -- ** Graph Construction and Destruction
+    insNode,insEdge,delNode,delEdge,delLEdge,delAllLEdge,
+    insNodes,insEdges,delNodes,delEdges,
+    buildGr,mkUGraph,
+    -- ** Subgraphs
+    gfiltermap,nfilter,labnfilter,labfilter,subgraph,
+    -- ** Graph Inspection
+    context,lab,neighbors,lneighbors,
+    suc,pre,lsuc,lpre,
+    out,inn,outdeg,indeg,deg,
+    hasEdge,hasNeighbor,hasLEdge,hasNeighborAdj,
+    equal,
+    -- ** Context Inspection
+    node',lab',labNode',neighbors',lneighbors',
+    suc',pre',lpre',lsuc',
+    out',inn',outdeg',indeg',deg',
+    -- * Pretty-printing
+    prettify,
+    prettyPrint,
+    -- * Ordering of Graphs
+    OrdGr(..)
+) where
+
+import GHC.Prelude
+
+import           Control.Arrow (first)
+import           Data.Function (on)
+import qualified Data.IntSet   as IntSet
+import           Data.List     (delete, groupBy, sort, sortBy, (\\))
+import           Data.Maybe    (fromMaybe, isJust)
+
+import GHC.Utils.Panic
+
+-- | Unlabeled node
+type  Node   = Int
+-- | Labeled node
+type LNode a = (Node,a)
+-- | Quasi-unlabeled node
+type UNode   = LNode ()
+
+-- | Unlabeled edge
+type  Edge   = (Node,Node)
+-- | Labeled edge
+type LEdge b = (Node,Node,b)
+-- | Quasi-unlabeled edge
+type UEdge   = LEdge ()
+
+-- | Unlabeled path
+type Path    = [Node]
+-- | Labeled path
+newtype LPath a = LP { unLPath :: [LNode a] }
+
+instance (Show a) => Show (LPath a) where
+  show (LP xs) = show xs
+
+instance (Eq a) => Eq (LPath a) where
+  (LP [])        == (LP [])        = True
+  (LP ((_,x):_)) == (LP ((_,y):_)) = x==y
+  (LP _)         == (LP _)         = False
+
+instance (Ord a) => Ord (LPath a) where
+  compare (LP [])        (LP [])        = EQ
+  compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y
+  compare _ _ = panic "LPath: cannot compare two empty paths"
+
+-- | Quasi-unlabeled path
+type UPath   = [UNode]
+
+-- | Labeled links to or from a 'Node'.
+type Adj b        = [(b,Node)]
+-- | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'.
+--
+--   In other words, this captures all information regarding the
+--   specified 'Node' within a graph.
+type Context a b  = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node
+type MContext a b = Maybe (Context a b)
+-- | 'Graph' decomposition - the context removed from a 'Graph', and the rest
+-- of the 'Graph'.
+type Decomp g a b = (MContext a b,g a b)
+-- | The same as 'Decomp', only more sure of itself.
+type GDecomp g a b  = (Context a b,g a b)
+
+-- | Unlabeled context.
+type UContext     = ([Node],Node,[Node])
+-- | Unlabeled decomposition.
+type UDecomp g    = (Maybe UContext,g)
+
+-- | Minimum implementation: 'empty', 'isEmpty', 'match', 'mkGraph', 'labNodes'
+class Graph gr where
+  {-# MINIMAL empty, isEmpty, match, mkGraph, labNodes #-}
+
+  -- | An empty 'Graph'.
+  empty     :: gr a b
+
+  -- | True if the given 'Graph' is empty.
+  isEmpty   :: gr a b -> Bool
+
+  -- | Decompose a 'Graph' into the 'MContext' found for the given node and the
+  -- remaining 'Graph'.
+  match     :: Node -> gr a b -> Decomp gr a b
+
+  -- | Create a 'Graph' from the list of 'LNode's and 'LEdge's.
+  --
+  --   For graphs that are also instances of 'DynGraph', @mkGraph ns
+  --   es@ should be equivalent to @('insEdges' es . 'insNodes' ns)
+  --   'empty'@.
+  mkGraph   :: [LNode a] -> [LEdge b] -> gr a b
+
+  -- | A list of all 'LNode's in the 'Graph'.
+  labNodes  :: gr a b -> [LNode a]
+
+  -- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node'
+  -- and the remaining 'Graph'.
+  matchAny  :: gr a b -> GDecomp gr a b
+  matchAny g = case labNodes g of
+                 []      -> panic "Match Exception, Empty Graph"
+                 (v,_):_ | (Just c,g') <- match v g -> (c,g')
+                 _       -> panic "This can't happen: failed to match node in graph"
+
+
+  -- | The number of 'Node's in a 'Graph'.
+  noNodes   :: gr a b -> Int
+  noNodes = length . labNodes
+
+  -- | The minimum and maximum 'Node' in a 'Graph'.
+  nodeRange :: gr a b -> (Node,Node)
+  nodeRange g
+    | isEmpty g = panic "nodeRange of empty graph"
+    | otherwise = (minimum vs, maximum vs)
+    where
+      vs = nodes g
+
+  -- | A list of all 'LEdge's in the 'Graph'.
+  labEdges  :: gr a b -> [LEdge b]
+  labEdges = ufold (\(_,v,_,s)->(map (\(l,w)->(v,w,l)) s ++)) []
+
+class (Graph gr) => DynGraph gr where
+  -- | Merge the 'Context' into the 'DynGraph'.
+  --
+  --   Context adjacencies should only refer to either a Node already
+  --   in a graph or the node in the Context itself (for loops).
+  --
+  --   Behaviour is undefined if the specified 'Node' already exists
+  --   in the graph.
+  (&) :: Context a b -> gr a b -> gr a b
+
+
+-- | The number of nodes in the graph.  An alias for 'noNodes'.
+order :: (Graph gr) => gr a b -> Int
+order = noNodes
+
+-- | The number of edges in the graph.
+--
+--   Note that this counts every edge found, so if you are
+--   representing an unordered graph by having each edge mirrored this
+--   will be incorrect.
+--
+--   If you created an unordered graph by either mirroring every edge
+--   (including loops!) or using the @undir@ function in
+--   "Data.Graph.Inductive.Basic" then you can safely halve the value
+--   returned by this.
+size :: (Graph gr) => gr a b -> Int
+size = length . labEdges
+
+-- | Fold a function over the graph by recursively calling 'match'.
+ufold :: (Graph gr) => (Context a b -> c -> c) -> c -> gr a b -> c
+ufold f u g
+  | isEmpty g = u
+  | otherwise = f c (ufold f u g')
+  where
+    (c,g') = matchAny g
+
+-- | Map a function over the graph by recursively calling 'match'.
+gmap :: (DynGraph gr) => (Context a b -> Context c d) -> gr a b -> gr c d
+gmap f = ufold (\c->(f c&)) empty
+{-# NOINLINE [0] gmap #-}
+
+-- | Map a function over the 'Node' labels in a graph.
+nmap :: (DynGraph gr) => (a -> c) -> gr a b -> gr c b
+nmap f = gmap (\(p,v,l,s)->(p,v,f l,s))
+{-# NOINLINE [0] nmap #-}
+
+-- | Map a function over the 'Edge' labels in a graph.
+emap :: (DynGraph gr) => (b -> c) -> gr a b -> gr a c
+emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s))
+  where
+    map1 g = map (first g)
+{-# NOINLINE [0] emap #-}
+
+-- | Map functions over both the 'Node' and 'Edge' labels in a graph.
+nemap :: (DynGraph gr) => (a -> c) -> (b -> d) -> gr a b -> gr c d
+nemap fn fe = gmap (\(p,v,l,s) -> (fe' p,v,fn l,fe' s))
+  where
+    fe' = map (first fe)
+{-# NOINLINE [0] nemap #-}
+
+-- | List all 'Node's in the 'Graph'.
+nodes :: (Graph gr) => gr a b -> [Node]
+nodes = map fst . labNodes
+
+-- | List all 'Edge's in the 'Graph'.
+edges :: (Graph gr) => gr a b -> [Edge]
+edges = map toEdge . labEdges
+
+-- | Drop the label component of an edge.
+toEdge :: LEdge b -> Edge
+toEdge (v,w,_) = (v,w)
+
+-- | Add a label to an edge.
+toLEdge :: Edge -> b -> LEdge b
+toLEdge (v,w) l = (v,w,l)
+
+-- | The label in an edge.
+edgeLabel :: LEdge b -> b
+edgeLabel (_,_,l) = l
+
+-- | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'.
+newNodes :: (Graph gr) => Int -> gr a b -> [Node]
+newNodes i g
+  | isEmpty g = [0..i-1]
+  | otherwise = [n+1..n+i]
+  where
+    (_,n) = nodeRange g
+
+-- | 'True' if the 'Node' is present in the 'Graph'.
+gelem :: (Graph gr) => Node -> gr a b -> Bool
+gelem v = isJust . fst . match v
+
+-- | Insert a 'LNode' into the 'Graph'.
+insNode :: (DynGraph gr) => LNode a -> gr a b -> gr a b
+insNode (v,l) = (([],v,l,[])&)
+{-# NOINLINE [0] insNode #-}
+
+-- | Insert a 'LEdge' into the 'Graph'.
+insEdge :: (DynGraph gr) => LEdge b -> gr a b -> gr a b
+insEdge (v,w,l) g = (pr,v,la,(l,w):su) & g'
+  where
+    (mcxt,g') = match v g
+    (pr,_,la,su) = fromMaybe
+                     (panic ("insEdge: cannot add edge from non-existent vertex " ++ show v))
+                     mcxt
+{-# NOINLINE [0] insEdge #-}
+
+-- | Remove a 'Node' from the 'Graph'.
+delNode :: (Graph gr) => Node -> gr a b -> gr a b
+delNode v = delNodes [v]
+
+-- | Remove an 'Edge' from the 'Graph'.
+--
+--   NOTE: in the case of multiple edges, this will delete /all/ such
+--   edges from the graph as there is no way to distinguish between
+--   them.  If you need to delete only a single such edge, please use
+--   'delLEdge'.
+delEdge :: (DynGraph gr) => Edge -> gr a b -> gr a b
+delEdge (v,w) g = case match v g of
+                    (Nothing,_)          -> g
+                    (Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) & g'
+
+-- | Remove an 'LEdge' from the 'Graph'.
+--
+--   NOTE: in the case of multiple edges with the same label, this
+--   will only delete the /first/ such edge.  To delete all such
+--   edges, please use 'delAllLedge'.
+delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b
+delLEdge = delLEdgeBy delete
+
+-- | Remove all edges equal to the one specified.
+delAllLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b
+delAllLEdge = delLEdgeBy (filter . (/=))
+
+delLEdgeBy :: (DynGraph gr) => ((b,Node) -> Adj b -> Adj b)
+              -> LEdge b -> gr a b -> gr a b
+delLEdgeBy f (v,w,b) g = case match v g of
+                           (Nothing,_)          -> g
+                           (Just (p,v',l,s),g') -> (p,v',l,f (b,w) s) & g'
+
+-- | Insert multiple 'LNode's into the 'Graph'.
+insNodes   :: (DynGraph gr) => [LNode a] -> gr a b -> gr a b
+insNodes vs g = foldl' (flip insNode) g vs
+{-# INLINABLE insNodes #-}
+
+-- | Insert multiple 'LEdge's into the 'Graph'.
+insEdges :: (DynGraph gr) => [LEdge b] -> gr a b -> gr a b
+insEdges es g = foldl' (flip insEdge) g es
+{-# INLINABLE insEdges #-}
+
+-- | Remove multiple 'Node's from the 'Graph'.
+delNodes :: (Graph gr) => [Node] -> gr a b -> gr a b
+delNodes vs g = foldl' (snd .: flip match) g vs
+
+-- | Remove multiple 'Edge's from the 'Graph'.
+delEdges :: (DynGraph gr) => [Edge] -> gr a b -> gr a b
+delEdges es g = foldl' (flip delEdge) g es
+
+-- | Build a 'Graph' from a list of 'Context's.
+--
+--   The list should be in the order such that earlier 'Context's
+--   depend upon later ones (i.e. as produced by @'ufold' (:) []@).
+buildGr :: (DynGraph gr) => [Context a b] -> gr a b
+buildGr = foldr (&) empty
+
+-- | Build a quasi-unlabeled 'Graph'.
+mkUGraph :: (Graph gr) => [Node] -> [Edge] -> gr () ()
+mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es)
+   where
+     labUEdges = map (`toLEdge` ())
+     labUNodes = map (flip (,) ())
+
+-- | Build a graph out of the contexts for which the predicate is
+-- satisfied by recursively calling 'match'.
+gfiltermap :: DynGraph gr => (Context a b -> MContext c d) -> gr a b -> gr c d
+gfiltermap f = ufold (maybe id (&) . f) empty
+
+-- | Returns the subgraph only containing the labelled nodes which
+-- satisfy the given predicate.
+labnfilter :: Graph gr => (LNode a -> Bool) -> gr a b -> gr a b
+labnfilter p gr = delNodes (map fst . filter (not . p) $ labNodes gr) gr
+
+-- | Returns the subgraph only containing the nodes which satisfy the
+-- given predicate.
+nfilter :: DynGraph gr => (Node -> Bool) -> gr a b -> gr a b
+nfilter f = labnfilter (f . fst)
+
+-- | Returns the subgraph only containing the nodes whose labels
+-- satisfy the given predicate.
+labfilter :: DynGraph gr => (a -> Bool) -> gr a b -> gr a b
+labfilter f = labnfilter (f . snd)
+
+-- | Returns the subgraph induced by the supplied nodes.
+subgraph :: DynGraph gr => [Node] -> gr a b -> gr a b
+subgraph vs = let vs' = IntSet.fromList vs
+              in nfilter (`IntSet.member` vs')
+
+-- | Find the context for the given 'Node'.  Causes an error if the 'Node' is
+-- not present in the 'Graph'.
+context :: (Graph gr) => gr a b -> Node -> Context a b
+context g v = fromMaybe (panic ("Match Exception, Node: "++show v))
+                        (fst (match v g))
+
+-- | Find the label for a 'Node'.
+lab :: (Graph gr) => gr a b -> Node -> Maybe a
+lab g v = fmap lab' . fst $ match v g
+
+-- | Find the neighbors for a 'Node'.
+neighbors :: (Graph gr) => gr a b -> Node -> [Node]
+neighbors = map snd .: lneighbors
+
+-- | Find the labelled links coming into or going from a 'Context'.
+lneighbors :: (Graph gr) => gr a b -> Node -> Adj b
+lneighbors = maybe [] lneighbors' .: mcontext
+
+-- | Find all 'Node's that have a link from the given 'Node'.
+suc :: (Graph gr) => gr a b -> Node -> [Node]
+suc = map snd .: context4l
+
+-- | Find all 'Node's that link to to the given 'Node'.
+pre :: (Graph gr) => gr a b -> Node -> [Node]
+pre = map snd .: context1l
+
+-- | Find all 'Node's that are linked from the given 'Node' and the label of
+-- each link.
+lsuc :: (Graph gr) => gr a b -> Node -> [(Node,b)]
+lsuc = map flip2 .: context4l
+
+-- | Find all 'Node's that link to the given 'Node' and the label of each link.
+lpre :: (Graph gr) => gr a b -> Node -> [(Node,b)]
+lpre = map flip2 .: context1l
+
+-- | Find all outward-bound 'LEdge's for the given 'Node'.
+out :: (Graph gr) => gr a b -> Node -> [LEdge b]
+out g v = map (\(l,w)->(v,w,l)) (context4l g v)
+
+-- | Find all inward-bound 'LEdge's for the given 'Node'.
+inn :: (Graph gr) => gr a b -> Node -> [LEdge b]
+inn g v = map (\(l,w)->(w,v,l)) (context1l g v)
+
+-- | The outward-bound degree of the 'Node'.
+outdeg :: (Graph gr) => gr a b -> Node -> Int
+outdeg = length .: context4l
+
+-- | The inward-bound degree of the 'Node'.
+indeg :: (Graph gr) => gr a b -> Node -> Int
+indeg  = length .: context1l
+
+-- | The degree of the 'Node'.
+deg :: (Graph gr) => gr a b -> Node -> Int
+deg = deg' .: context
+
+-- | The 'Node' in a 'Context'.
+node' :: Context a b -> Node
+node' (_,v,_,_) = v
+
+-- | The label in a 'Context'.
+lab' :: Context a b -> a
+lab' (_,_,l,_) = l
+
+-- | The 'LNode' from a 'Context'.
+labNode' :: Context a b -> LNode a
+labNode' (_,v,l,_) = (v,l)
+
+-- | All 'Node's linked to or from in a 'Context'.
+neighbors' :: Context a b -> [Node]
+neighbors' (p,_,_,s) = map snd p++map snd s
+
+-- | All labelled links coming into or going from a 'Context'.
+lneighbors' :: Context a b -> Adj b
+lneighbors' (p,_,_,s) = p ++ s
+
+-- | All 'Node's linked to in a 'Context'.
+suc' :: Context a b -> [Node]
+suc' = map snd . context4l'
+
+-- | All 'Node's linked from in a 'Context'.
+pre' :: Context a b -> [Node]
+pre' = map snd . context1l'
+
+-- | All 'Node's linked from in a 'Context', and the label of the links.
+lsuc' :: Context a b -> [(Node,b)]
+lsuc' = map flip2 . context4l'
+
+-- | All 'Node's linked from in a 'Context', and the label of the links.
+lpre' :: Context a b -> [(Node,b)]
+lpre' = map flip2 . context1l'
+
+-- | All outward-directed 'LEdge's in a 'Context'.
+out' :: Context a b -> [LEdge b]
+out' c@(_,v,_,_) = map (\(l,w)->(v,w,l)) (context4l' c)
+
+-- | All inward-directed 'LEdge's in a 'Context'.
+inn' :: Context a b -> [LEdge b]
+inn' c@(_,v,_,_) = map (\(l,w)->(w,v,l)) (context1l' c)
+
+-- | The outward degree of a 'Context'.
+outdeg' :: Context a b -> Int
+outdeg' = length . context4l'
+
+-- | The inward degree of a 'Context'.
+indeg' :: Context a b -> Int
+indeg' = length . context1l'
+
+-- | The degree of a 'Context'.
+deg' :: Context a b -> Int
+deg' (p,_,_,s) = length p+length s
+
+-- | Checks if there is a directed edge between two nodes.
+hasEdge :: Graph gr => gr a b -> Edge -> Bool
+hasEdge gr (v,w) = w `elem` suc gr v
+
+-- | Checks if there is an undirected edge between two nodes.
+hasNeighbor :: Graph gr => gr a b -> Node -> Node -> Bool
+hasNeighbor gr v w = w `elem` neighbors gr v
+
+-- | Checks if there is a labelled edge between two nodes.
+hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool
+hasLEdge gr (v,w,l) = (w,l) `elem` lsuc gr v
+
+-- | Checks if there is an undirected labelled edge between two nodes.
+hasNeighborAdj :: (Graph gr, Eq b) => gr a b -> Node -> (b,Node) -> Bool
+hasNeighborAdj gr v a = a `elem` lneighbors gr v
+
+----------------------------------------------------------------------
+-- GRAPH EQUALITY
+----------------------------------------------------------------------
+
+slabNodes :: (Graph gr) => gr a b -> [LNode a]
+slabNodes = sortBy (compare `on` fst) . labNodes
+
+glabEdges :: (Graph gr) => gr a b -> [GroupEdges b]
+glabEdges = map (GEs . groupLabels)
+            . groupBy ((==) `on` toEdge)
+            . sortBy (compare `on` toEdge)
+            . labEdges
+  where
+    groupLabels les = toLEdge (toEdge (head les)) (map edgeLabel les)
+
+equal :: (Eq a,Eq b,Graph gr) => gr a b -> gr a b -> Bool
+equal g g' = slabNodes g == slabNodes g' && glabEdges g == glabEdges g'
+-- This assumes that nodes aren't repeated (which shouldn't happen for
+-- sane graph instances).  If node IDs are repeated, then the usage of
+-- slabNodes cannot guarantee stable ordering.
+
+-- Newtype wrapper just to test for equality of multiple edges.  This
+-- is needed because without an Ord constraint on `b' it is not
+-- possible to guarantee a stable ordering on edge labels.
+newtype GroupEdges b = GEs (LEdge [b])
+  deriving (Show, Read)
+
+instance (Eq b) => Eq (GroupEdges b) where
+  (GEs (v1,w1,bs1)) == (GEs (v2,w2,bs2)) = v1 == v2
+                                           && w1 == w2
+                                           && eqLists bs1 bs2
+
+eqLists :: (Eq a) => [a] -> [a] -> Bool
+eqLists xs ys = null (xs \\ ys) && null (ys \\ xs)
+-- OK to use \\ here as we want each value in xs to cancel a *single*
+-- value in ys.
+
+----------------------------------------------------------------------
+-- UTILITIES
+----------------------------------------------------------------------
+
+-- auxiliary functions used in the implementation of the
+-- derived class members
+--
+(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
+-- f .: g = \x y->f (g x y)
+-- f .: g = (f .) . g
+-- (.:) f = ((f .) .)
+-- (.:) = (.) (.) (.)
+(.:) = (.) . (.)
+
+flip2 :: (a,b) -> (b,a)
+flip2 (x,y) = (y,x)
+
+-- projecting on context elements
+--
+context1l :: (Graph gr) => gr a b -> Node -> Adj b
+context1l = maybe [] context1l' .: mcontext
+
+context4l :: (Graph gr) => gr a b -> Node -> Adj b
+context4l = maybe [] context4l' .: mcontext
+
+mcontext :: (Graph gr) => gr a b -> Node -> MContext a b
+mcontext = fst .: flip match
+
+context1l' :: Context a b -> Adj b
+context1l' (p,v,_,s) = p++filter ((==v).snd) s
+
+context4l' :: Context a b -> Adj b
+context4l' (p,v,_,s) = s++filter ((==v).snd) p
+
+----------------------------------------------------------------------
+-- PRETTY PRINTING
+----------------------------------------------------------------------
+
+-- | Pretty-print the graph.  Note that this loses a lot of
+--   information, such as edge inverses, etc.
+prettify :: (DynGraph gr, Show a, Show b) => gr a b -> String
+prettify g = foldr (showsContext . context g) id (nodes g) ""
+  where
+    showsContext (_,n,l,s) sg = shows n . (':':) . shows l
+                                . showString "->" . shows s
+                                . ('\n':) . sg
+
+-- | Pretty-print the graph to stdout.
+prettyPrint :: (DynGraph gr, Show a, Show b) => gr a b -> IO ()
+prettyPrint = putStr . prettify
+
+----------------------------------------------------------------------
+-- Ordered Graph
+----------------------------------------------------------------------
+
+-- | OrdGr comes equipped with an Ord instance, so that graphs can be
+--   used as e.g. Map keys.
+newtype OrdGr gr a b = OrdGr { unOrdGr :: gr a b }
+  deriving (Read,Show)
+
+instance (Graph gr, Ord a, Ord b) => Eq (OrdGr gr a b) where
+  g1 == g2 = compare g1 g2 == EQ
+
+instance (Graph gr, Ord a, Ord b) => Ord (OrdGr gr a b) where
+  compare (OrdGr g1) (OrdGr g2) =
+    (compare `on` sort . labNodes) g1 g2
+    `mappend` (compare `on` sort . labEdges) g1 g2
+
+
+{-----------------------------------------------------------------
+
+Copyright (c) 1999-2008, Martin Erwig
+              2010, Ivan Lazar Miljenovic
+              2022, Norman Ramsey
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice,
+   this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of its contributors may be
+   used to endorse or promote products derived from this software without
+   specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+----------------------------------------------------------------}
diff --git a/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs b/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs
new file mode 100644
index 0000000000..047ae0b2c7
--- /dev/null
+++ b/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs
@@ -0,0 +1,341 @@
+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+-- |An efficient implementation of 'Data.Graph.Inductive.Graph.Graph'
+-- using big-endian patricia tree (i.e. "Data.IntMap").
+--
+-- This module provides the following specialised functions to gain
+-- more performance, using GHC's RULES pragma:
+--
+-- * 'Data.Graph.Inductive.Graph.insNode'
+--
+-- * 'Data.Graph.Inductive.Graph.insEdge'
+--
+-- * 'Data.Graph.Inductive.Graph.gmap'
+--
+-- * 'Data.Graph.Inductive.Graph.nmap'
+--
+-- * 'Data.Graph.Inductive.Graph.emap'
+
+module GHC.Data.Graph.Inductive.PatriciaTree
+    ( Gr
+    , UGr
+    )
+    where
+
+import GHC.Prelude
+
+import GHC.Data.Graph.Inductive.Graph
+
+import           Control.Applicative (liftA2)
+import           Data.IntMap         (IntMap)
+import qualified Data.IntMap         as IM
+import           Data.List           (sort)
+import           Data.Maybe          (fromMaybe)
+import           Data.Tuple          (swap)
+
+import qualified Data.IntMap.Strict as IMS
+
+import GHC.Generics (Generic)
+
+import Data.Bifunctor
+
+----------------------------------------------------------------------
+-- GRAPH REPRESENTATION
+----------------------------------------------------------------------
+
+newtype Gr a b = Gr (GraphRep a b)
+  deriving (Generic)
+
+type GraphRep a b = IntMap (Context' a b)
+type Context' a b = (IntMap [b], a, IntMap [b])
+
+type UGr = Gr () ()
+
+----------------------------------------------------------------------
+-- CLASS INSTANCES
+----------------------------------------------------------------------
+
+instance (Eq a, Ord b) => Eq (Gr a b) where
+  (Gr g1) == (Gr g2) = fmap sortAdj g1 == fmap sortAdj g2
+    where
+      sortAdj (p,n,s) = (fmap sort p,n,fmap sort s)
+
+instance (Show a, Show b) => Show (Gr a b) where
+  showsPrec d g = showParen (d > 10) $
+                    showString "mkGraph "
+                    . shows (labNodes g)
+                    . showString " "
+                    . shows (labEdges g)
+
+instance (Read a, Read b) => Read (Gr a b) where
+  readsPrec p = readParen (p > 10) $ \ r -> do
+    ("mkGraph", s) <- lex r
+    (ns,t) <- reads s
+    (es,u) <- reads t
+    return (mkGraph ns es, u)
+
+instance Graph Gr where
+    empty           = Gr IM.empty
+
+    isEmpty (Gr g)  = IM.null g
+
+    match           = matchGr
+
+    mkGraph vs es   = insEdges es
+                      . Gr
+                      . IM.fromList
+                      . map (second (\l -> (IM.empty,l,IM.empty)))
+                      $ vs
+
+    labNodes (Gr g) = [ (node, label)
+                            | (node, (_, label, _)) <- IM.toList g ]
+
+    noNodes   (Gr g) = IM.size g
+
+    nodeRange (Gr g) = fromMaybe (error "nodeRange of empty graph")
+                       $ liftA2 (,) (ix (IM.minViewWithKey g))
+                                    (ix (IM.maxViewWithKey g))
+      where
+        ix = fmap (fst . fst)
+
+    labEdges (Gr g) = do (node, (_, _, s)) <- IM.toList g
+                         (next, labels)    <- IM.toList s
+                         label             <- labels
+                         return (node, next, label)
+
+instance DynGraph Gr where
+    (p, v, l, s) & (Gr g)
+        = let !g1 = IM.insert v (preds, l, succs) g
+              !(np, preds) = fromAdjCounting p
+              !(ns, succs) = fromAdjCounting s
+              !g2 = addSucc g1 v np preds
+              !g3 = addPred g2 v ns succs
+          in Gr g3
+
+
+instance Bifunctor Gr where
+  bimap = fastNEMap
+
+  first = fastNMap
+
+  second = fastEMap
+
+
+matchGr :: Node -> Gr a b -> Decomp Gr a b
+matchGr node (Gr g)
+    = case IM.lookup node g of
+        Nothing
+            -> (Nothing, Gr g)
+
+        Just (p, label, s)
+            -> let !g1 = IM.delete node g
+                   !p' = IM.delete node p
+                   !s' = IM.delete node s
+                   !g2 = clearPred g1 node s'
+                   !g3 = clearSucc g2 node p'
+               in (Just (toAdj p', node, label, toAdj s), Gr g3)
+
+----------------------------------------------------------------------
+-- OVERRIDING FUNCTIONS
+----------------------------------------------------------------------
+
+{-
+
+{- RULES
+      "insNode/Data.Graph.Inductive.PatriciaTree"  insNode = fastInsNode
+  -}
+fastInsNode :: LNode a -> Gr a b -> Gr a b
+fastInsNode (v, l) (Gr g) = g' `seq` Gr g'
+  where
+    g' = IM.insert v (IM.empty, l, IM.empty) g
+
+-}
+{-# RULES
+      "insEdge/GHC.Data.Graph.Inductive.PatriciaTree"  insEdge = fastInsEdge
+  #-}
+fastInsEdge :: LEdge b -> Gr a b -> Gr a b
+fastInsEdge (v, w, l) (Gr g) = g2 `seq` Gr g2
+  where
+    g1 = IM.adjust addS' v g
+    g2 = IM.adjust addP' w g1
+
+    addS' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss)
+    addP' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)
+
+{-
+
+{- RULES
+      "gmap/Data.Graph.Inductive.PatriciaTree"  gmap = fastGMap
+  -}
+fastGMap :: forall a b c d. (Context a b -> Context c d) -> Gr a b -> Gr c d
+fastGMap f (Gr g) = Gr (IM.mapWithKey f' g)
+  where
+    f' :: Node -> Context' a b -> Context' c d
+    f' = ((fromContext . f) .) . toContext
+
+{- RULES
+      "nmap/Data.Graph.Inductive.PatriciaTree"  nmap = fastNMap
+  -}
+-}
+fastNMap :: forall a b c. (a -> c) -> Gr a b -> Gr c b
+fastNMap f (Gr g) = Gr (IM.map f' g)
+  where
+    f' :: Context' a b -> Context' c b
+    f' (ps, a, ss) = (ps, f a, ss)
+{-
+
+{- RULES
+      "emap/GHC.Data.Graph.Inductive.PatriciaTree"  emap = fastEMap
+   -}
+-}
+fastEMap :: forall a b c. (b -> c) -> Gr a b -> Gr a c
+fastEMap f (Gr g) = Gr (IM.map f' g)
+  where
+    f' :: Context' a b -> Context' a c
+    f' (ps, a, ss) = (IM.map (map f) ps, a, IM.map (map f) ss)
+
+{-  RULES
+      "nemap/GHC.Data.Graph.Inductive.PatriciaTree"  nemap = fastNEMap
+   -}
+
+fastNEMap :: forall a b c d. (a -> c) -> (b -> d) -> Gr a b -> Gr c d
+fastNEMap fn fe (Gr g) = Gr (IM.map f g)
+  where
+    f :: Context' a b -> Context' c d
+    f (ps, a, ss) = (IM.map (map fe) ps, fn a, IM.map (map fe) ss)
+
+
+
+----------------------------------------------------------------------
+-- UTILITIES
+----------------------------------------------------------------------
+
+toAdj :: IntMap [b] -> Adj b
+toAdj = concatMap expand . IM.toList
+  where
+    expand (n,ls) = map (flip (,) n) ls
+
+--fromAdj :: Adj b -> IntMap [b]
+--fromAdj = IM.fromListWith addLists . map (second (:[]) . swap)
+
+data FromListCounting a = FromListCounting !Int !(IntMap a)
+  deriving (Eq, Show, Read)
+
+getFromListCounting :: FromListCounting a -> (Int, IntMap a)
+getFromListCounting (FromListCounting i m) = (i, m)
+{-# INLINE getFromListCounting #-}
+
+fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
+fromListWithKeyCounting f = getFromListCounting . foldl' ins (FromListCounting 0 IM.empty)
+  where
+    ins (FromListCounting i t) (k,x) = FromListCounting (i + 1) (IM.insertWithKey f k x t)
+{-# INLINE fromListWithKeyCounting #-}
+
+fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
+fromListWithCounting f = fromListWithKeyCounting (\_ x y -> f x y)
+{-# INLINE fromListWithCounting #-}
+
+fromAdjCounting :: Adj b -> (Int, IntMap [b])
+fromAdjCounting = fromListWithCounting addLists . map (second (:[]) . swap)
+
+-- We use differenceWith to modify a graph more than bulkThreshold times,
+-- and repeated insertWith otherwise.
+bulkThreshold :: Int
+bulkThreshold = 5
+
+--toContext :: Node -> Context' a b -> Context a b
+--toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss)
+
+--fromContext :: Context a b -> Context' a b
+--fromContext (ps, _, a, ss) = (fromAdj ps, a, fromAdj ss)
+
+-- A version of @++@ where order isn't important, so @xs ++ [x]@
+-- becomes @x:xs@.  Used when we have to have a function of type @[a]
+-- -> [a] -> [a]@ but one of the lists is just going to be a single
+-- element (and it isn't possible to tell which).
+addLists :: [a] -> [a] -> [a]
+addLists [a] as  = a : as
+addLists as  [a] = a : as
+addLists xs  ys  = xs ++ ys
+
+addSucc :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b
+addSucc g0 v numAdd xs
+  | numAdd < bulkThreshold = foldlWithKey' go g0 xs
+  where
+    go :: GraphRep a b -> Node -> [b] -> GraphRep a b
+    go g p l = IMS.adjust f p g
+      where f (ps, l', ss) = let !ss' = IM.insertWith addLists v l ss
+                             in (ps, l', ss')
+addSucc g v _ xs = IMS.differenceWith go g xs
+  where
+    go :: Context' a b -> [b] -> Maybe (Context' a b)
+    go (ps, l', ss) l = let !ss' = IM.insertWith addLists v l ss
+                        in Just (ps, l', ss')
+
+foldlWithKey' :: (a -> IM.Key -> b -> a) -> a -> IntMap b -> a
+foldlWithKey' =
+  IM.foldlWithKey'
+
+addPred :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b
+addPred g0 v numAdd xs
+  | numAdd < bulkThreshold = foldlWithKey' go g0 xs
+  where
+    go :: GraphRep a b -> Node -> [b] -> GraphRep a b
+    go g p l = IMS.adjust f p g
+      where f (ps, l', ss) = let !ps' = IM.insertWith addLists v l ps
+                             in (ps', l', ss)
+addPred g v _ xs = IMS.differenceWith go g xs
+  where
+    go :: Context' a b -> [b] -> Maybe (Context' a b)
+    go (ps, l', ss) l = let !ps' = IM.insertWith addLists v l ps
+                        in Just (ps', l', ss)
+
+clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b
+clearSucc g v = IMS.differenceWith go g
+  where
+    go :: Context' a b -> x -> Maybe (Context' a b)
+    go (ps, l, ss) _ = let !ss' = IM.delete v ss
+                       in Just (ps, l, ss')
+
+clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b
+clearPred g v = IMS.differenceWith go g
+  where
+    go :: Context' a b -> x -> Maybe (Context' a b)
+    go (ps, l, ss) _ = let !ps' = IM.delete v ps
+                       in Just (ps', l, ss)
+
+{-----------------------------------------------------------------
+
+Copyright (c) 1999-2008, Martin Erwig
+              2010, Ivan Lazar Miljenovic
+              2022, Norman Ramsey
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice,
+   this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of its contributors may be
+   used to endorse or promote products derived from this software without
+   specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+----------------------------------------------------------------}
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 008f3d8d02..768cb49be1 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -364,6 +364,8 @@ Library
         GHC.Data.Graph.Base
         GHC.Data.Graph.Color
         GHC.Data.Graph.Directed
+        GHC.Data.Graph.Inductive.Graph
+        GHC.Data.Graph.Inductive.PatriciaTree
         GHC.Data.Graph.Ops
         GHC.Data.Graph.Ppr
         GHC.Data.Graph.UnVar