.gitattributes

@@ -2,3 +2,4 @@
 # don't convert anything on checkout
 * text=auto eol=lf
 mk/win32-tarballs.md5sum text=auto eol=LF
+testsuite/tests/parser/should_run/T25375.hs text=auto eol=crlf

compiler/GHC/Data/Graph/Directed.hs

@@ -8,13 +8,14 @@
 
 module GHC.Data.Graph.Directed (
         Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
-        graphFromVerticesAndAdjacency,
+        graphFromVerticesAndAdjacency, emptyGraph,
 
         SCC(..), Node(..), G.flattenSCC, G.flattenSCCs,
         stronglyConnCompG,
         topologicalSortG,
         verticesG, edgesG, hasVertexG,
-        reachableG, reachablesG, transposeG, allReachable, allReachableCyclic, outgoingG,
+        reachablesG,
+        transposeG, outgoingG,
         emptyG,
 
         findCycle,
@@ -43,7 +44,6 @@ module GHC.Data.Graph.Directed (
 -- removed them since they were not used anywhere in GHC.
 ------------------------------------------------------------------------------
 
-
 import GHC.Prelude
 
 import GHC.Utils.Misc ( sortWith, count )
@@ -60,13 +60,13 @@ import qualified Data.Set as Set
 
 import qualified Data.Graph as G
 import Data.Graph ( Vertex, Bounds, SCC(..) ) -- Used in the underlying representation
-import Data.Tree
 import GHC.Types.Unique
 import GHC.Types.Unique.FM
-import qualified Data.IntMap as IM
-import qualified Data.IntSet as IS
-import qualified Data.Map as M
-import qualified Data.Set as S
+
+-- The graph internals are defined in the .Internal module so they can be
+-- imported by GHC.Data.Graph.Directed.Reachability while still allowing this
+-- module to export it abstractly.
+import GHC.Data.Graph.Directed.Internal
 
 {-
 ************************************************************************
@@ -86,14 +86,6 @@ Note [Nodes, keys, vertices]
         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
@@ -357,51 +349,22 @@ topologicalSortG :: Graph node -> [node]
 topologicalSortG graph = map (gr_vertex_to_node graph) result
   where result = {-# SCC "Digraph.topSort" #-} G.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]
-
 outgoingG :: Graph node -> node -> [node]
 outgoingG graph from = map (gr_vertex_to_node graph) result
-  where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
+  where from_vertex = expectJust "outgoingG" (gr_node_to_vertex graph from)
         result = gr_int_graph graph ! from_vertex
 
--- | Given a list of roots return all reachable nodes.
+-- | Given a list of roots, return all reachable nodes in topological order.
+-- Implemented using a depth-first traversal.
 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 ]
 
--- | Efficiently construct a map which maps each key to it's set of transitive
--- dependencies. Only works on acyclic input.
-allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key)
-allReachable = all_reachable reachableGraph
-
--- | Efficiently construct a map which maps each key to it's set of transitive
--- dependencies. Less efficient than @allReachable@, but works on cyclic input as well.
-allReachableCyclic :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key)
-allReachableCyclic = all_reachable reachableGraphCyclic
-
-all_reachable :: Ord key => (IntGraph -> IM.IntMap IS.IntSet) -> Graph node -> (node -> key) -> M.Map key (S.Set key)
-all_reachable int_reachables (Graph g from _) keyOf =
-  M.fromList [(k, IS.foldr (\v' vs -> keyOf (from v') `S.insert` vs) S.empty vs)
-             | (v, vs) <- IM.toList int_graph
-             , let k = keyOf (from v)]
-  where
-    int_graph = int_reachables g
-
 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) $ G.vertices (gr_int_graph graph)
-
-edgesG :: Graph node -> [Edge node]
-edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ G.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)
@@ -410,112 +373,10 @@ transposeG graph = Graph (G.transposeG (gr_int_graph 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 (G.dfs g vs)
-
-reachableGraph :: IntGraph -> IM.IntMap IS.IntSet
-reachableGraph g = res
-  where
-    do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup res) (g ! v))
-    res = IM.fromList [(v, do_one v) | v <- G.vertices g]
-
-scc :: IntGraph -> [SCC Vertex]
-scc graph = map decode forest
-  where
-    forest = {-# SCC "Digraph.scc" #-} G.scc graph
-
-    decode (Node v []) | mentions_itself v = CyclicSCC [v]
-                       | otherwise         = AcyclicSCC v
-    decode other = CyclicSCC (dec other [])
-      where dec (Node v ts) vs = v : foldr dec vs ts
-    mentions_itself v = v `elem` (graph ! v)
-
-reachableGraphCyclic :: IntGraph -> IM.IntMap IS.IntSet
-reachableGraphCyclic g = foldl' add_one_comp mempty comps
-  where
-    neighboursOf v = g!v
-
-    comps = scc g
-
-    -- To avoid divergence on cyclic input, we build the result
-    -- strongly connected component by component, in topological
-    -- order. For each SCC, we know that:
-    --
-    --   * All vertices in the component can reach all other vertices
-    --     in the component ("local" reachables)
-    --
-    --   * Other reachable vertices ("remote" reachables) must come
-    --     from earlier components, either via direct neighbourhood, or
-    --     transitively from earlier reachability map
-    --
-    -- This allows us to build the extension of the reachability map
-    -- directly, without any self-reference, thereby avoiding a loop.
-    add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet
-    add_one_comp earlier (AcyclicSCC v) = IM.insert v all_remotes earlier
-      where
-        earlier_neighbours = neighboursOf v
-        earlier_further = mapMaybe (flip IM.lookup earlier) earlier_neighbours
-        all_remotes = IS.unions (IS.fromList earlier_neighbours : earlier_further)
-    add_one_comp earlier (CyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- vs]) earlier
-      where
-        all_locals = IS.fromList vs
-        local v = IS.delete v all_locals
-            -- Arguably, for a cyclic SCC we should include each
-            -- vertex in its own reachable set. However, this could
-            -- lead to a lot of extra pain in client code to avoid
-            -- looping when traversing the reachability map.
-        all_neighbours = IS.fromList (concatMap neighboursOf vs)
-        earlier_neighbours = all_neighbours IS.\\ all_locals
-        earlier_further = mapMaybe (flip IM.lookup earlier) (IS.toList earlier_neighbours)
-        all_remotes = IS.unions (earlier_neighbours : earlier_further)
 
 {-
 ************************************************************************
@@ -623,3 +484,4 @@ graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vert
                                   expectJust "graphFromVerticesAndAdjacency" $ key_vertex b)
         reduced_edges = map key_vertex_pair edges
         graph = G.buildG bounds reduced_edges
+

compiler/GHC/Data/Graph/Directed/Internal.hs

+module GHC.Data.Graph.Directed.Internal where
+
+import GHC.Prelude
+import GHC.Utils.Outputable
+
+import Data.Array
+import qualified Data.Graph as G
+import Data.Graph ( Vertex, SCC(..) ) -- Used in the underlying representation
+import Data.Tree
+
+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
+
+------------------------------------------------------------
+-- Nodes and Edges
+------------------------------------------------------------
+
+verticesG :: Graph node -> [node]
+verticesG graph = map (gr_vertex_to_node graph) $ G.vertices (gr_int_graph graph)
+
+edgesG :: Graph node -> [Edge node]
+edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ G.edges (gr_int_graph graph)
+  where v2n = gr_vertex_to_node graph
+
+------------------------------------------------------------
+-- 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
+
+{-
+************************************************************************
+*                                                                      *
+*      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 (G.dfs g vs)
+
+scc :: IntGraph -> [SCC Vertex]
+scc graph = map decode forest
+  where
+    forest = {-# SCC "Digraph.scc" #-} G.scc graph
+
+    decode (Node v []) | mentions_itself v = CyclicSCC [v]
+                       | otherwise         = AcyclicSCC v
+    decode other = CyclicSCC (dec other [])
+      where dec (Node v ts) vs = v : foldr dec vs ts
+    mentions_itself v = v `elem` (graph ! v)
+

compiler/GHC/Data/Graph/Directed/Reachability.hs

+-- | An abstract interface for a fast reachability data structure constructed
+-- from a 'GHC.Data.Graph.Directed' graph.
+module GHC.Data.Graph.Directed.Reachability
+  ( ReachabilityIndex
+
+  -- * Constructing a reachability index
+  , graphReachability, cyclicGraphReachability
+
+  -- * Reachability queries
+  , allReachable, allReachableMany
+  , isReachable, isReachableMany
+  )
+  where
+
+import GHC.Prelude
+import GHC.Data.Maybe
+
+import qualified Data.Graph as G
+import Data.Graph ( Vertex, SCC(..) )
+
+import Data.Array ((!))
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+
+import GHC.Data.Graph.Directed.Internal
+
+--------------------------------------------------------------------------------
+-- * Reachability index
+--------------------------------------------------------------------------------
+
+-- | The abstract data structure for fast reachability queries
+data ReachabilityIndex node = ReachabilityIndex {
+    index :: IM.IntMap IS.IntSet,
+    from_vertex :: Vertex -> node,
+    to_vertex :: node -> Maybe Vertex
+}
+
+--------------------------------------------------------------------------------
+-- * Construction
+--------------------------------------------------------------------------------
+
+-- | Construct a 'ReachabilityIndex' from an acyclic 'Graph'.
+-- If the graph can have cycles, use 'cyclicGraphReachability'
+graphReachability :: Graph node -> ReachabilityIndex node
+graphReachability (Graph g from to) =
+  ReachabilityIndex{index = reachableGraph, from_vertex = from, to_vertex = to}
+    where
+      reachableGraph :: IM.IntMap IS.IntSet
+      reachableGraph = IM.fromList [(v, do_one v) | v <- G.vertices g]
+
+      do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup reachableGraph) (g ! v))
+
+-- | Construct a 'ReachabilityIndex' from a 'Graph' which may have cycles.
+cyclicGraphReachability :: Graph node -> ReachabilityIndex node
+cyclicGraphReachability (Graph g from to) =
+  ReachabilityIndex{index = reachableGraphCyclic, from_vertex = from, to_vertex = to}
+    where
+      reachableGraphCyclic :: IM.IntMap IS.IntSet
+      reachableGraphCyclic = foldl' add_one_comp mempty comps
+
+      neighboursOf v = g!v
+
+      comps = scc g
+
+      -- To avoid divergence on cyclic input, we build the result
+      -- strongly connected component by component, in topological
+      -- order. For each SCC, we know that:
+      --
+      --   * All vertices in the component can reach all other vertices
+      --     in the component ("local" reachables)
+      --
+      --   * Other reachable vertices ("remote" reachables) must come
+      --     from earlier components, either via direct neighbourhood, or
+      --     transitively from earlier reachability map
+      --
+      -- This allows us to build the extension of the reachability map
+      -- directly, without any self-reference, thereby avoiding a loop.
+      add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet
+      add_one_comp earlier (AcyclicSCC v) = IM.insert v all_remotes earlier
+        where
+          earlier_neighbours = neighboursOf v
+          earlier_further = mapMaybe (flip IM.lookup earlier) earlier_neighbours
+          all_remotes = IS.unions (IS.fromList earlier_neighbours : earlier_further)
+      add_one_comp earlier (CyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- vs]) earlier
+        where
+          all_locals = IS.fromList vs
+          local v = IS.delete v all_locals
+              -- Arguably, for a cyclic SCC we should include each
+              -- vertex in its own reachable set. However, this could
+              -- lead to a lot of extra pain in client code to avoid
+              -- looping when traversing the reachability map.
+          all_neighbours = IS.fromList (concatMap neighboursOf vs)
+          earlier_neighbours = all_neighbours IS.\\ all_locals
+          earlier_further = mapMaybe (flip IM.lookup earlier) (IS.toList earlier_neighbours)
+          all_remotes = IS.unions (earlier_neighbours : earlier_further)
+
+--------------------------------------------------------------------------------
+-- * Reachability queries
+--------------------------------------------------------------------------------
+
+-- | 'allReachable' returns the nodes reachable from the given @root@ node.
+--
+-- Properties:
+--  * The list of nodes /does not/ include the @root@ node!
+--  * The list of nodes is deterministically ordered, but according to an
+--     internal order determined by the indices attributed to graph nodes.
+--  * This function has $O(1)$ complexity.
+--
+-- If you need a topologically sorted list, consider using the functions exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead.
+allReachable :: ReachabilityIndex node -> node {-^ The @root@ node -} -> [node] {-^ All nodes reachable from @root@ -}
+allReachable (ReachabilityIndex index from to) root = map from result
+  where root_i = expectJust "reachableFrom" (to root)
+        hits = {-# SCC "allReachable" #-} IM.lookup root_i index
+        result = IS.toList $! expectJust "reachableFrom" hits
+
+-- | 'allReachableMany' returns all nodes reachable from the many given @roots@.
+--
+-- Properties:
+--  * The list of nodes /does not/ include the @roots@ node!
+--  * The list of nodes is deterministically ordered, but according to an
+--     internal order determined by the indices attributed to graph nodes.
+--  * This function has $O(n)$ complexity where $n$ is the number of @roots@.
+--
+-- If you need a topologically sorted list, consider using the functions
+-- exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead ('reachableG').
+allReachableMany :: ReachabilityIndex node -> [node] {-^ The @roots@ -} -> [node] {-^ All nodes reachable from all @roots@ -}
+allReachableMany (ReachabilityIndex index from to) roots = map from (IS.toList hits)
+  where roots_i = [ v | Just v <- map to roots ]
+        hits = {-# SCC "allReachableMany" #-}
+               IS.unions $ map (expectJust "reachablesG" . flip IM.lookup index) roots_i
+
+-- | Fast reachability query.
+--
+-- On graph @g@ with nodes @a@ and @b@, @isReachable g a b@
+-- asks whether @b@ can be reached through @g@ starting from @a@.
+--
+-- Properties:
+--  * No self loops, i.e. @isReachable _ a a == False@
+--  * This function has $O(1)$ complexity.
+isReachable :: ReachabilityIndex node {-^ @g@ -}
+            -> node -- ^ @a@
+            -> node -- ^ @b@
+            -> Bool -- ^ @b@ is reachable from @a@
+isReachable (ReachabilityIndex index _ to) a b =
+    IS.member b_i $
+    expectJust "reachable" $ IM.lookup a_i index
+  where a_i = expectJust "reachable:node not in graph" $ to a
+        b_i = expectJust "reachable:node not in graph" $ to b
+
+-- | Fast reachability query with many roots.
+--
+-- On graph @g@ with many nodes @roots@ and node @b@, @isReachableMany g as b@
+-- asks whether @b@ can be reached through @g@ from any of the @roots@.
+--
+-- Properties:
+--  * No self loops, i.e. @isReachableMany _ [a] a == False@
+--  * This function is $O(n)$ in the number of roots
+isReachableMany :: ReachabilityIndex node -- ^ @g@
+                -> [node] -- ^ @roots@
+                -> node -- ^ @b@
+                -> Bool -- ^ @b@ is reachable from any of the @roots@
+isReachableMany (ReachabilityIndex index _ to) roots b =
+    IS.member b_i $
+    IS.unions $
+    map (expectJust "reachablesQuery" . flip IM.lookup index) roots_i
+  where roots_i = [ v | Just v <- map to roots ]
+        b_i = expectJust "reachablesQuery:node not in graph" $ to b
+

compiler/GHC/Driver/Config/StgToCmm.hs

@@ -38,7 +38,6 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
   -- flags
   , stgToCmmLoopification = gopt Opt_Loopification         dflags
   , stgToCmmAlignCheck    = gopt Opt_AlignmentSanitisation dflags
-  , stgToCmmOptHpc        = gopt Opt_Hpc                   dflags
   , stgToCmmFastPAPCalls  = gopt Opt_FastPAPCalls          dflags
   , stgToCmmSCCProfiling  = sccProfilingEnabled            dflags
   , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling     dflags

compiler/GHC/Driver/Hooks.hs

@@ -48,7 +48,6 @@ import GHC.Types.Basic
 import GHC.Types.CostCentre
 import GHC.Types.IPE
 import GHC.Types.Meta
-import GHC.Types.HpcInfo
 
 import GHC.Unit.Module
 import GHC.Unit.Module.ModSummary
@@ -149,7 +148,7 @@ data Hooks = Hooks
                                          -> IO (Either Type (HValue, [Linkable], PkgsLoaded))))
   , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))
   , stgToCmmHook           :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs
-                                 -> [CgStgTopBinding] -> HpcInfo -> CgStream CmmGroup ModuleLFInfos))
+                                 -> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos))
   , cmmToRawCmmHook        :: !(forall a . Maybe (DynFlags -> Maybe Module -> CgStream CmmGroupSRTs a
                                  -> IO (CgStream RawCmmGroup a)))
   }

compiler/GHC/Driver/Main.hs

@@ -248,7 +248,6 @@ import GHC.Types.Name.Cache ( initNameCache )
 import GHC.Types.Name.Reader
 import GHC.Types.Name.Ppr
 import GHC.Types.TyThing
-import GHC.Types.HpcInfo
 import GHC.Types.Unique.Supply (uniqFromTag)
 import GHC.Types.Unique.Set
 
@@ -1980,7 +1979,6 @@ hscGenHardCode hsc_env cgguts location output_filename = do
               cg_foreign       = foreign_stubs0,
               cg_foreign_files = foreign_files,
               cg_dep_pkgs      = dependencies,
-              cg_hpc_info      = hpc_info,
               cg_spt_entries   = spt_entries,
               cg_binds         = late_binds,
               cg_ccs           = late_local_ccs
@@ -2084,7 +2082,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
               cmms <- {-# SCC "StgToCmm" #-}
                 doCodeGen hsc_env this_mod denv data_tycons
                 cost_centre_info
-                stg_binds hpc_info
+                stg_binds
 
               ------------------  Code output -----------------------
               rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
@@ -2291,13 +2289,12 @@ This reduces residency towards the end of the CodeGen phase significantly
 doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
           -> CollectedCCs
           -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
-          -> HpcInfo
           -> IO (CgStream CmmGroupSRTs CmmCgInfos)
          -- Note we produce a 'Stream' of CmmGroups, so that the
          -- backend can be run incrementally.  Otherwise it generates all
          -- the C-- up front, which has a significant space cost.
 doCodeGen hsc_env this_mod denv data_tycons
-              cost_centre_info stg_binds_w_fvs hpc_info = do
+              cost_centre_info stg_binds_w_fvs = do
     let dflags     = hsc_dflags hsc_env
         logger     = hsc_logger hsc_env
         hooks      = hsc_hooks  hsc_env
@@ -2308,14 +2305,14 @@ doCodeGen hsc_env this_mod denv data_tycons
     putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG
         (pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs)
 
-    let stg_to_cmm dflags mod a b c d e = case stgToCmmHook hooks of
-          Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) a b c d e
-          Just h  -> (,emptyDetUFM) <$> h          (initStgToCmmConfig dflags mod) a b c d e
+    let stg_to_cmm dflags mod a b c d = case stgToCmmHook hooks of
+          Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) a b c d
+          Just h  -> (,emptyDetUFM) <$> h          (initStgToCmmConfig dflags mod) a b c d
 
     let cmm_stream :: CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
         -- See Note [Forcing of stg_binds]
         cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
-            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info
+            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs
 
         -- codegen consumes a stream of CmmGroup, and produces a new
         -- stream of CmmGroup (not necessarily synchronised: one

compiler/GHC/Driver/Make.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- -----------------------------------------------------------------------------
 --
@@ -149,6 +150,7 @@ import GHC.Types.Unique
 import GHC.Iface.Errors.Types
 
 import qualified GHC.Data.Word64Set as W
+import GHC.Data.Graph.Directed.Reachability
 
 -- -----------------------------------------------------------------------------
 -- Loading the program
@@ -610,20 +612,20 @@ createBuildPlan mod_graph maybe_top_mod =
               mresolved_cycle = collapseSCC (topSortWithBoot nodes)
           in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []
 
-        (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)
-        trans_deps_map = allReachable mg (mkNodeKey . node_payload)
         -- Compute the intermediate modules between a file and its hs-boot file.
         -- See Step 2a in Note [Upsweep]
         boot_path mn uid =
-          map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $
+          Set.toList $
           -- Don't include the boot module itself
-          Set.delete (NodeKey_Module (key IsBoot))  $
+          Set.filter ((/= NodeKey_Module (key IsBoot)) . mkNodeKey)  $
           -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are
           -- the transitive dependencies of the non-boot file which transitively depend
           -- on the boot file.
-          Set.filter (\nk -> nodeKeyUnitId nk == uid  -- Cheap test
-                              && (NodeKey_Module (key IsBoot)) `Set.member` expectJust "dep_on_boot" (M.lookup nk trans_deps_map)) $
-          expectJust "not_boot_dep" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map)
+          Set.filter (\(mkNodeKey -> nk) ->
+            nodeKeyUnitId nk == uid  -- Cheap test
+              && mgQuery mod_graph nk (NodeKey_Module (key IsBoot))) $
+          Set.fromList $
+          expectJust "not_boot_dep"  (mgReachable mod_graph (NodeKey_Module (key NotBoot)))
           where
             key ib = ModNodeKeyWithUid (GWIB mn ib) uid
 
@@ -1497,7 +1499,7 @@ topSortModules drop_hs_boot_nodes summaries mb_root_mod
                      = node
                      | otherwise
                      = throwGhcException (ProgramError "module does not exist")
-            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
+            in graphFromEdgedVerticesUniq (seq root (root:allReachable (graphReachability graph) root))
 
 newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }
   deriving (Functor, Traversable, Foldable)
@@ -1821,20 +1823,15 @@ checkHomeUnitsClosed ue
     | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
   where
     home_id_set = unitEnv_keys $ ue_home_unit_graph ue
-    bad_unit_ids = upwards_closure Set.\\ home_id_set
+    bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -}
     rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
 
-    graph :: Graph (Node UnitId UnitId)
-    graph = graphFromEdgedVerticesUniq graphNodes
+    downwards_closure :: Graph (Node UnitId UnitId)
+    downwards_closure = graphFromEdgedVerticesUniq graphNodes
 
-    -- downwards closure of graph
-    downwards_closure
-      = graphFromEdgedVerticesUniq [ DigraphNode uid uid (Set.toList deps)
-                                   | (uid, deps) <- M.toList (allReachable graph node_key)]
+    inverse_closure = graphReachability $ transposeG downwards_closure
 
-    inverse_closure = transposeG downwards_closure
-
-    upwards_closure = Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
+    upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
 
     all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
     all_unit_direct_deps

compiler/GHC/HsToCore/Coverage.hs

@@ -117,7 +117,7 @@ hpcInitCode platform this_mod (HpcInfo tickCount hashNo)
  = initializerCStub platform fn_name decls body
   where
     fn_name = mkInitializerStubLabel this_mod (fsLit "hpc")
-    decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi
+    decls = text "StgWord64 " <> tickboxes <> brackets (int tickCount) <> semi
     body = text "hs_hpc_module" <>
               parens (hcat (punctuate comma [
                   doubleQuotes full_name_str,

compiler/GHC/Iface/Tidy.hs

@@ -407,7 +407,6 @@ tidyProgram opts (ModGuts { mg_module           = mod
                           , mg_deps             = deps
                           , mg_foreign          = foreign_stubs
                           , mg_foreign_files    = foreign_files
-                          , mg_hpc_info         = hpc_info
                           , mg_modBreaks        = modBreaks
                           , mg_boot_exports     = boot_exports
                           }) = do
@@ -480,7 +479,6 @@ tidyProgram opts (ModGuts { mg_module           = mod
                  , cg_foreign       = all_foreign_stubs
                  , cg_foreign_files = foreign_files
                  , cg_dep_pkgs      = dep_direct_pkgs deps
-                 , cg_hpc_info      = hpc_info
                  , cg_modBreaks     = modBreaks
                  , cg_spt_entries   = spt_entries
                  }
@@ -1567,4 +1565,3 @@ mustExposeTyCon no_trim_types exports tc
     exported_con con = any (`elemNameSet` exports)
                            (dataConName con : dataConFieldLabels con)
 -}
-

compiler/GHC/Linker/Deps.hs

@@ -51,7 +51,6 @@ import Control.Monad
 import Control.Applicative
 
 import qualified Data.Set as Set
-import qualified Data.Map as M
 import Data.List (isSuffixOf)
 
 import System.FilePath
@@ -166,16 +165,16 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
     make_deps_loop found@(found_units, found_mods) (nk:nexts)
       | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts
       | otherwise =
-        case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of
-            Just trans_deps ->
-              let deps = Set.insert (NodeKey_Module nk) trans_deps
-                  -- See #936 and the ghci.prog007 test for why we have to continue traversing through
-                  -- boot modules.
-                  todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps]
-              in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
-            Nothing ->
+        case fmap mkNodeKey <$> mgReachable mod_graph (NodeKey_Module nk) of
+          Nothing ->
               let (ModNodeKeyWithUid _ uid) = nk
               in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts
+          Just trans_deps ->
+            let deps = Set.insert (NodeKey_Module nk) (Set.fromList trans_deps)
+                -- See #936 and the ghci.prog007 test for why we have to continue traversing through
+                -- boot modules.
+                todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- trans_deps]
+            in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
 
     mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)
     (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods)

compiler/GHC/Parser/String.hs

@@ -261,6 +261,7 @@ lexMultilineString = lexStringWith processChars processChars
     processChars :: HasChar c => [c] -> Either (c, LexErr) [c]
     processChars =
           collapseGaps             -- Step 1
+      >>> normalizeEOL
       >>> expandLeadingTabs        -- Step 3
       >>> rmCommonWhitespacePrefix -- Step 4
       >>> collapseOnlyWsLines      -- Step 5
@@ -268,6 +269,19 @@ lexMultilineString = lexStringWith processChars processChars
       >>> rmLastNewline            -- Step 7b
       >>> resolveEscapes           -- Step 8
 
+    -- Normalize line endings to LF. The spec dictates that lines should be
+    -- split on newline characters and rejoined with ``\n``. But because we
+    -- aren't actually splitting/rejoining, we'll manually normalize here
+    normalizeEOL :: HasChar c => [c] -> [c]
+    normalizeEOL =
+      let go = \case
+            Char '\r' : c@(Char '\n') : cs -> c : go cs
+            c@(Char '\r') : cs -> setChar '\n' c : go cs
+            c@(Char '\f') : cs -> setChar '\n' c : go cs
+            c : cs -> c : go cs
+            [] -> []
+       in go
+
     -- expands all tabs, since the lexer will verify that tabs can only appear
     -- as leading indentation
     expandLeadingTabs :: HasChar c => [c] -> [c]

compiler/GHC/StgToCmm.hs

@@ -24,7 +24,6 @@ import GHC.StgToCmm.Layout
 import GHC.StgToCmm.Utils
 import GHC.StgToCmm.Closure
 import GHC.StgToCmm.Config
-import GHC.StgToCmm.Hpc
 import GHC.StgToCmm.Ticky
 import GHC.StgToCmm.Types (ModuleLFInfos)
 import GHC.StgToCmm.CgUtils (CgStream)
@@ -38,7 +37,6 @@ import GHC.Stg.Syntax
 
 import GHC.Types.CostCentre
 import GHC.Types.IPE
-import GHC.Types.HpcInfo
 import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Types.RepType
@@ -52,7 +50,6 @@ import GHC.Core.DataCon
 import GHC.Core.TyCon
 import GHC.Core.Multiplicity
 
-import GHC.Unit.Module
 
 import GHC.Utils.Error
 import GHC.Utils.Outputable
@@ -77,13 +74,12 @@ codeGen :: Logger
         -> [TyCon]
         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
         -> [CgStgTopBinding]           -- Bindings to convert
-        -> HpcInfo
         -> CgStream CmmGroup (ModuleLFInfos, DetUniqFM) -- See Note [Deterministic Uniques in the CG] on CgStream
                                        -- Output as a stream, so codegen can
                                        -- be interleaved with output
 
 codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) data_tycons
-        cost_centre_info stg_binds hpc_info
+        cost_centre_info stg_binds
   = do  {     -- cg: run the code generator, and yield the resulting CmmGroup
               -- Using an IORef to store the state is a bit crude, but otherwise
               -- we would need to add a state monad layer which regresses
@@ -118,7 +114,7 @@ codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) data_tycons
                 yield cmm
                 return a
 
-        ; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info)
+        ; cg (mkModuleInit cost_centre_info)
 
         ; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds
                 -- Put datatype_stuff after code_stuff, because the
@@ -281,13 +277,10 @@ cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body _typ)
 
 mkModuleInit
         :: CollectedCCs         -- cost centre info
-        -> Module
-        -> HpcInfo
         -> FCode ()
 
-mkModuleInit cost_centre_info this_mod hpc_info
-  = do  { initHpc this_mod hpc_info
-        ; initCostCentres cost_centre_info
+mkModuleInit cost_centre_info
+  = do  { initCostCentres cost_centre_info
         }
 
 

compiler/GHC/StgToCmm/Config.hs

@@ -46,7 +46,6 @@ data StgToCmmConfig = StgToCmmConfig
   ---------------------------------- Flags --------------------------------------
   , stgToCmmLoopification  :: !Bool              -- ^ Loopification enabled (cf @-floopification@)
   , stgToCmmAlignCheck     :: !Bool              -- ^ Insert alignment check (cf @-falignment-sanitisation@)
-  , stgToCmmOptHpc         :: !Bool              -- ^ perform code generation for code coverage
   , stgToCmmFastPAPCalls   :: !Bool              -- ^
   , stgToCmmSCCProfiling   :: !Bool              -- ^ Check if cost-centre profiling is enabled
   , stgToCmmEagerBlackHole :: !Bool              -- ^

compiler/GHC/StgToCmm/Hpc.hs

@@ -6,13 +6,11 @@
 --
 -----------------------------------------------------------------------------
 
-module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where
+module GHC.StgToCmm.Hpc ( mkTickBox ) where
 
 import GHC.Prelude
 import GHC.Platform
 
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Utils
 
 import GHC.Cmm.Graph
 import GHC.Cmm.Expr
@@ -20,9 +18,7 @@ import GHC.Cmm.CLabel
 import GHC.Cmm.Utils
 
 import GHC.Unit.Module
-import GHC.Types.HpcInfo
 
-import Control.Monad
 
 mkTickBox :: Platform -> Module -> Int -> CmmAGraph
 mkTickBox platform mod n
@@ -34,16 +30,3 @@ mkTickBox platform mod n
     tick_box = cmmIndex platform W64
                         (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
                         n
-
--- | Emit top-level tables for HPC and return code to initialise
-initHpc :: Module -> HpcInfo -> FCode ()
-initHpc _ NoHpcInfo{}
-  = return ()
-initHpc this_mod (HpcInfo tickCount _hashNo)
-  = do do_hpc <- stgToCmmOptHpc <$> getStgToCmmConfig
-       when do_hpc $
-           emitDataLits (mkHpcTicksLabel this_mod)
-                        [ CmmInt 0 W64
-                        | _ <- take tickCount [0 :: Int ..]
-                        ]
-

compiler/GHC/Unit/Module/Graph.hs

@@ -18,11 +18,12 @@ module GHC.Unit.Module.Graph
    , mgModSummaries
    , mgModSummaries'
    , mgLookupModule
-   , mgTransDeps
    , showModMsg
    , moduleGraphNodeModule
    , moduleGraphNodeModSum
    , moduleGraphModulesBelow
+   , mgReachable
+   , mgQuery
 
    , moduleGraphNodes
    , SummaryNode
@@ -49,6 +50,7 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import GHC.Data.Maybe
 import GHC.Data.Graph.Directed
+import GHC.Data.Graph.Directed.Reachability
 
 import GHC.Driver.Backend
 import GHC.Driver.DynFlags
@@ -72,6 +74,7 @@ import Data.Bifunctor
 import Data.Function
 import Data.List (sort)
 import GHC.Data.List.SetOps
+import GHC.Stack
 
 -- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.
 -- Edges between nodes mark dependencies arising from module imports
@@ -153,7 +156,7 @@ instance Outputable ModNodeKeyWithUid where
 -- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.
 data ModuleGraph = ModuleGraph
   { mg_mss :: [ModuleGraphNode]
-  , mg_trans_deps :: Map.Map NodeKey (Set.Set NodeKey)
+  , mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
     -- A cached transitive dependency calculation so that a lot of work is not
     -- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances)
   }
@@ -173,12 +176,11 @@ unionMG a b =
   let new_mss = nubOrdBy compare $ mg_mss a `mappend` mg_mss b
   in ModuleGraph {
         mg_mss = new_mss
-      , mg_trans_deps = mkTransDeps new_mss
+      , mg_graph = mkTransDeps new_mss
       }
 
-
-mgTransDeps :: ModuleGraph -> Map.Map NodeKey (Set.Set NodeKey)
-mgTransDeps = mg_trans_deps
+mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
+mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False
 
 mgModSummaries :: ModuleGraph -> [ModSummary]
 mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]
@@ -199,7 +201,7 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
     go _ = Nothing
 
 emptyMG :: ModuleGraph
-emptyMG = ModuleGraph [] Map.empty
+emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing)
 
 isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
 isTemplateHaskellOrQQNonBoot ms =
@@ -212,14 +214,9 @@ isTemplateHaskellOrQQNonBoot ms =
 extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph
 extendMG ModuleGraph{..} deps ms = ModuleGraph
   { mg_mss = ModuleNode deps ms : mg_mss
-  , mg_trans_deps = mkTransDeps (ModuleNode deps ms : mg_mss)
+  , mg_graph = mkTransDeps (ModuleNode deps ms : mg_mss)
   }
 
-mkTransDeps :: [ModuleGraphNode] -> Map.Map NodeKey (Set.Set NodeKey)
-mkTransDeps mss =
-  let (gg, _lookup_node) = moduleGraphNodes False mss
-  in allReachable gg (mkNodeKey . node_payload)
-
 extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph
 extendMGInst mg uid depUnitId = mg
   { mg_mss = InstantiationNode uid depUnitId : mg_mss mg
@@ -394,12 +391,9 @@ type ModNodeKey = ModuleNameWithIsBoot
 -- boot module and the non-boot module can be reached, it only returns the
 -- non-boot one.
 moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
-moduleGraphModulesBelow mg uid mn = filtered_mods $ [ mn |  NodeKey_Module mn <- modules_below]
+moduleGraphModulesBelow mg uid mn = filtered_mods [ mn | NodeKey_Module mn <- modules_below ]
   where
-    td_map = mgTransDeps mg
-
-    modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map
-
+    modules_below = maybe [] (map mkNodeKey) (mgReachable mg (NodeKey_Module (ModNodeKeyWithUid mn uid)))
     filtered_mods = Set.fromDistinctAscList . filter_mods . sort
 
     -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list
@@ -415,3 +409,22 @@ moduleGraphModulesBelow mg uid mn = filtered_mods $ [ mn |  NodeKey_Module mn <-
                        in r' : filter_mods rs
         | otherwise -> r1 : filter_mods (r2:rs)
       rs -> rs
+
+mgReachable :: HasCallStack => ModuleGraph -> NodeKey -> Maybe [ModuleGraphNode]
+mgReachable mg nk = map summaryNodeSummary <$> modules_below where
+  (td_map, lookup_node) = mg_graph mg
+  modules_below =
+    allReachable td_map <$> lookup_node nk
+
+-- | Reachability Query. @mgQuery(g, a, b)@ asks: Can we reach @b@ from @a@ in
+-- graph @g@?
+-- INVARIANT: Both @a@ and @b@ must be in @g@.
+mgQuery :: ModuleGraph -- ^ @g@
+        -> NodeKey -- ^ @a@
+        -> NodeKey -- ^ @b@
+        -> Bool -- ^ @b@ is reachable from @a@
+mgQuery mg nka nkb = isReachable td_map na nb where
+  (td_map, lookup_node) = mg_graph mg
+  na = expectJust "mgQuery:a" $ lookup_node nka
+  nb = expectJust "mgQuery:b" $ lookup_node nkb
+

compiler/GHC/Unit/Module/ModGuts.hs

@@ -141,7 +141,6 @@ data CgGuts
         cg_foreign_files :: ![(ForeignSrcLang, FilePath)],
         cg_dep_pkgs  :: !(Set UnitId),      -- ^ Dependent packages, used to
                                             -- generate #includes for C code gen
-        cg_hpc_info  :: !HpcInfo,           -- ^ Program coverage tick box information
         cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints
         cg_spt_entries :: [SptEntry]
                 -- ^ Static pointer table entries for static forms defined in

compiler/ghc.cabal.in

@@ -444,6 +444,8 @@ Library
         GHC.Data.Graph.Color
         GHC.Data.Graph.Collapse
         GHC.Data.Graph.Directed
+        GHC.Data.Graph.Directed.Internal
+        GHC.Data.Graph.Directed.Reachability
         GHC.Data.Graph.Inductive.Graph
         GHC.Data.Graph.Inductive.PatriciaTree
         GHC.Data.Graph.Ops

docs/users_guide/exts/multiline_strings.rst

@@ -14,7 +14,9 @@ With this extension, GHC now recognizes multiline string literals with ``"""`` d
 
 Normal string literals are lexed, then string gaps are collapsed, then escape characters are resolved. Multiline string literals add the following post-processing steps between collapsing string gaps and resolving escape characters:
 
-#. Split the string by newlines
+#. Split the string by newline characters
+
+      * Includes ``\r\n``, ``\r``, ``\n``, ``\f``
 
 #. Replace leading tabs with spaces up to the next tab stop
 
@@ -24,7 +26,9 @@ Normal string literals are lexed, then string gaps are collapsed, then escape ch
 
 #. Join the string back with ``\n`` delimiters
 
-#. If the first character of the string is a newline, remove it
+#. If the first character of the string is ``\n``, remove it
+
+#. If the last character of the string is ``\n``, remove it
 
 Examples
 ~~~~~~~~

libraries/ghc-internal/src/GHC/Internal/Exception.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_HADDOCK not-home #-}
 
 -----------------------------------------------------------------------------
@@ -52,7 +53,7 @@ module GHC.Internal.Exception
     , ratioZeroDenomException
     , underflowException
       -- ** 'ErrorCall'
-    , ErrorCall(..)
+    , ErrorCall(.., ErrorCallWithLocation)
     , errorCallException
     , errorCallWithCallStackException
     , toExceptionWithBacktrace
@@ -178,7 +179,11 @@ data ErrorCall = ErrorCall String
              , Ord -- ^ @since base-4.7.0.0
              )
 
-{-# COMPLETE ErrorCall #-}
+{-# DEPRECATED ErrorCallWithLocation "ErrorCallWithLocation has been deprecated in favour of ErrorCall (which does not have a location). Backtraces are now handled by the backtrace exception mechanisms exclusively." #-}
+pattern ErrorCallWithLocation :: String -> String -> ErrorCall
+pattern ErrorCallWithLocation err loc <- ErrorCall ((\err -> (err, error "ErrorCallWithLocation has been deprecated in favour of ErrorCall (which does not have a location). Backtraces are now handled by the backtrace exception mechanisms exclusively.")) -> (err, loc))
+  where ErrorCallWithLocation err _ = ErrorCall err
+{-# COMPLETE ErrorCallWithLocation #-}
 
 -- | @since base-4.0.0.0
 instance Exception ErrorCall