[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Fix CRLF in multiline strings (#25375)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Nov 21 15:18:28 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9049e46c by Brandon Chinn at 2024-11-21T10:18:07-05:00
Fix CRLF in multiline strings (#25375)
- - - - -
3369685d by Rodrigo Mesquita at 2024-11-21T10:18:08-05:00
Improve reachability queries on ModuleGraph
Introduces `ReachabilityIndex`, an index constructed from a
`GHC.Data.Graph.Directed` `Graph` that supports fast reachability
queries (in $O(1)$). This abstract data structure is exposed from
`GHC.Data.Graph.Directed.Reachability`.
This index is constructed from the module graph nodes and cached in
`ModuleGraph`, enabling efficient reachability queries on the module
graph. Previously, we'd construct a Map of Set of ModuleGraph nodes
which used a lot of memory (`O(n^2)` in the number of nodes) and cache
that in the `ModuleGraph`. By using the reachability index we get rid of
this space leak in the module graph -- even though the index is still
quadratic in the number of modules, it is much, much more space
efficient due to its representation using an IntMap of IntSet as opposed
to the transitive closure we previously cached.
In a memory profile of MultiLayerModules with 100x100 modules, memory
usage improved from 6GB residency to 2.8GB, out of which roughly 1.8GB
are caused by a second space leak related to ModuleGraph. On the same
program, it brings compile time from 7.5s to 5.5s.
Note how we simplify `checkHomeUnitsClosed` in terms of
`isReachableMany` and by avoiding constructing a second graph with the
full transitive closure -- it suffices to answer the reachability query
on the full graph without collapsing the transitive closure completely
into nodes.
Unfortunately, solving this leak means we have to do a little bit more
work since we can no longer cache the result of turning vertex indices
into nodes. This results in a slight regression in MultiLayerModulesTH_Make,
but results in large performance and memory wins when compiling large
amounts of modules.
-------------------------
Metric Decrease:
mhu-perf
Metric Increase:
MultiLayerModulesTH_Make
-------------------------
- - - - -
e25afd6e by Cheng Shao at 2024-11-21T10:18:08-05:00
driver: fix hpc undefined symbol issue in TH with -fprefer-byte-code
This commit fixes an undefined symbol error in RTS linker when
attempting to compile home modules with -fhpc and
-fbyte-code-and-object-code/-fprefer-byte-code, see #25510 for
detailed description and analysis of the bug.
Also adds T25510/T25510c regression tests to test make mode/oneshot
mode of the bug.
- - - - -
29 changed files:
- .gitattributes
- compiler/GHC/Data/Graph/Directed.hs
- + compiler/GHC/Data/Graph/Directed/Internal.hs
- + compiler/GHC/Data/Graph/Directed/Reachability.hs
- compiler/GHC/Driver/Config/StgToCmm.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/HsToCore/Coverage.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Parser/String.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Config.hs
- compiler/GHC/StgToCmm/Hpc.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/ModGuts.hs
- compiler/ghc.cabal.in
- docs/users_guide/exts/multiline_strings.rst
- + testsuite/tests/bytecode/T25510/Makefile
- + testsuite/tests/bytecode/T25510/T25510A.hs
- + testsuite/tests/bytecode/T25510/T25510B.hs
- + testsuite/tests/bytecode/T25510/all.T
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/parser/should_run/T25375.hs
- + testsuite/tests/parser/should_run/T25375.stdout
- testsuite/tests/parser/should_run/all.T
- testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
Changes:
=====================================
.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
=====================================
@@ -0,0 +1,79 @@
+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
=====================================
@@ -0,0 +1,168 @@
+-- | 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 at .
+--
+-- 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 at .
+--
+-- 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 at .
+--
+-- 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 at .
+--
+-- 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 at .
+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
~~~~~~~~
=====================================
testsuite/tests/bytecode/T25510/Makefile
=====================================
@@ -0,0 +1,7 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T25510c:
+ '$(TEST_HC)' $(ghcThWayFlags) -fhpc -fbyte-code-and-object-code -c T25510A.hs
+ '$(TEST_HC)' $(ghcThWayFlags) -fhpc -fprefer-byte-code -c T25510B.hs
=====================================
testsuite/tests/bytecode/T25510/T25510A.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module T25510A where
+
+import Language.Haskell.TH
+
+a :: Q Exp
+a = [| 114514 |]
=====================================
testsuite/tests/bytecode/T25510/T25510B.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T25510B where
+
+import T25510A
+
+b = $(a)
=====================================
testsuite/tests/bytecode/T25510/all.T
=====================================
@@ -0,0 +1,10 @@
+test('T25510', [
+ req_th,
+ js_skip
+], multimod_compile, ['T25510B', '-fhpc -fbyte-code-and-object-code -fprefer-byte-code -v0'])
+
+test('T25510c', [
+ extra_files(['T25510A.hs', 'T25510B.hs']),
+ req_th,
+ js_skip
+], makefile_test, ['T25510c ghcThWayFlags=' + config.ghc_th_way_flags])
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -66,6 +66,7 @@ GHC.Data.FastString.Env
GHC.Data.FiniteMap
GHC.Data.FlatBag
GHC.Data.Graph.Directed
+GHC.Data.Graph.Directed.Internal
GHC.Data.Graph.UnVar
GHC.Data.List.Infinite
GHC.Data.List.SetOps
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -67,6 +67,8 @@ GHC.Data.FastString.Env
GHC.Data.FiniteMap
GHC.Data.FlatBag
GHC.Data.Graph.Directed
+GHC.Data.Graph.Directed.Internal
+GHC.Data.Graph.Directed.Reachability
GHC.Data.Graph.UnVar
GHC.Data.List.Infinite
GHC.Data.List.SetOps
=====================================
testsuite/tests/parser/should_run/T25375.hs
=====================================
@@ -0,0 +1,38 @@
+{-# LANGUAGE MultilineStrings #-}
+
+str1 = unlines
+ [ "aaa"
+ , "bbb"
+ , "ccc"
+ ]
+
+str2 = "aaa\n\
+ \bbb\n\
+ \ccc\n"
+
+str3 = """
+ aaa
+ bbb
+ ccc
+ """
+
+str4 = """
+
+ aaa
+ bbb
+ ccc
+
+ """
+
+str5 = """
+ aaa
+ bbb
+ ccc\n
+ """
+
+main = do
+ print str1
+ print str2
+ print str3
+ print str4
+ print str5
=====================================
testsuite/tests/parser/should_run/T25375.stdout
=====================================
@@ -0,0 +1,5 @@
+"aaa\nbbb\nccc\n"
+"aaa\nbbb\nccc\n"
+"aaa\nbbb\nccc"
+"\naaa\nbbb\nccc\n"
+"aaa\nbbb\nccc\n"
=====================================
testsuite/tests/parser/should_run/all.T
=====================================
@@ -23,3 +23,4 @@ test('RecordDotSyntax5', normal, compile_and_run, [''])
test('ListTuplePunsConstraints', extra_files(['ListTuplePunsConstraints.hs']), ghci_script, ['ListTuplePunsConstraints.script'])
test('MultilineStrings', normal, compile_and_run, [''])
test('MultilineStringsOverloaded', normal, compile_and_run, [''])
+test('T25375', normal, compile_and_run, [''])
=====================================
testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
=====================================
@@ -34,7 +34,6 @@ import GHC.Stg.FVs
import GHC.Stg.Syntax
import GHC.StgToCmm (codeGen)
import GHC.Types.CostCentre (emptyCollectedCCs)
-import GHC.Types.HpcInfo (emptyHpcInfo)
import GHC.Types.IPE (emptyInfoTableProvMap)
import GHC.Types.Unique.DSM
import GHC.Unit.Home
@@ -70,14 +69,12 @@ cmmOfSummary summ = do
tycons = []
ccs = emptyCollectedCCs
stg' = fmap fst (depSortWithAnnotStgPgm (ms_mod summ) stg)
- hpcinfo = emptyHpcInfo False
tmpfs = hsc_tmpfs env
- stg_to_cmm dflags mod = codeGen logger tmpfs (initStgToCmmConfig dflags mod)
(groups, _infos) <-
liftIO $ fmap fst $
runUDSMT (initDUniqSupply 't' 0) $
collectAll $
- stg_to_cmm dflags (ms_mod summ) infotable tycons ccs stg' hpcinfo
+ codeGen logger tmpfs (initStgToCmmConfig dflags (ms_mod summ)) infotable tycons ccs stg'
return groups
frontend :: DynFlags -> HscEnv -> ModSummary -> IO ModGuts
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cffc92d345cab38274c7a6a45baa72eab62bd94...e25afd6e05a0fd4ade7f6223cf790b53878dbfb2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5cffc92d345cab38274c7a6a45baa72eab62bd94...e25afd6e05a0fd4ade7f6223cf790b53878dbfb2
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241121/6d399b0a/attachment-0001.html>
More information about the ghc-commits
mailing list