[Git][ghc/ghc][wip/romes/graph-compact-easy] fixup! A start on module graphs
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Mon Nov 18 14:58:11 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/graph-compact-easy at Glasgow Haskell Compiler / GHC
Commits:
dc510042 by Rodrigo Mesquita at 2024-11-18T14:57:50+00:00
fixup! A start on module graphs
- - - - -
4 changed files:
- compiler/GHC/CmmToAsm/Reg/Linear.hs
- compiler/GHC/Data/Graph/Directed.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Unit/Module/Graph.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/Reg/Linear.hs
=====================================
@@ -843,7 +843,7 @@ allocateRegsAndSpill reading keep spills alloc (r@(VirtualRegWithFormat vr _fmt)
Just (InMem slot) | reading -> doSpill (ReadMem slot)
| otherwise -> doSpill WriteMem
Nothing | reading ->
- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr vr)
+ pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr vr <+> ppr assig)
-- NOTE: if the input to the NCG contains some
-- unreachable blocks with junk code, this panic
-- might be triggered. Make sure you only feed
=====================================
compiler/GHC/Data/Graph/Directed.hs
=====================================
@@ -14,7 +14,8 @@ module GHC.Data.Graph.Directed (
stronglyConnCompG,
topologicalSortG,
verticesG, edgesG, hasVertexG,
- reachableG, reachablesG, transposeG, outgoingG,
+ reachableG, reachableG',
+ reachablesG, transposeG, outgoingG,
emptyG,
findCycle,
@@ -28,7 +29,7 @@ module GHC.Data.Graph.Directed (
-- Simple way to classify edges
EdgeType(..), classifyEdges,
- ReachabilityIndex, reachabilityIndex, emptyGraph, nodeLookupByIx
+ ReachabilityIndex, reachabilityIndex, emptyGraph, nodeLookupByIx, reachable
) where
------------------------------------------------------------------------------
@@ -358,11 +359,20 @@ topologicalSortG :: Graph node -> [node]
topologicalSortG graph = map (gr_vertex_to_node graph) result
where result = {-# SCC "Digraph.topSort" #-} G.topSort (gr_int_graph graph)
+-- ROMES:TODO: ADD UNIT TESTS(To the properly defined graph interface)
+-- ROMES:TODO: ADD UNIT TESTS(To the mOduleGraph properly defined graph interface)
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)
hits = {-# SCC "Digraph.reachable" #-} IM.lookup from_vertex (gr_reachability graph)
- result = maybe [] IS.toList hits
+ result = IS.toList $! IS.insert from_vertex $ expectJust "reachableG2" hits
+
+-- | DoENS't INCLUDE THE ROOT VERTEX
+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)
+ hits = {-# SCC "Digraph.reachable" #-} IM.lookup from_vertex (gr_reachability graph)
+ result = IS.toList $! expectJust "reachableG2" hits
outgoingG :: Graph node -> node -> [node]
outgoingG graph from = map (gr_vertex_to_node graph) result
@@ -371,9 +381,10 @@ outgoingG graph from = map (gr_vertex_to_node graph) result
-- | Given a list of roots return all reachable nodes.
reachablesG :: Graph node -> [node] -> [node]
-reachablesG graph froms = map (gr_vertex_to_node graph) result
+reachablesG graph froms = map (gr_vertex_to_node graph) (IS.toList result)
where result = {-# SCC "Digraph.reachable" #-}
- concatMap (maybe [] IS.toList . flip IM.lookup (gr_reachability graph)) vs
+ IS.union (IS.fromList vs) $
+ IS.unions $ map (expectJust "reachablesG" . flip IM.lookup (gr_reachability graph)) vs
vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
hasVertexG :: Graph node -> node -> Bool
@@ -428,31 +439,13 @@ graphEmpty g = lo > hi
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]
+-- NB: We also used to have `reachableGraphCyclic`, but it was unused in the source so it was removed.
+-- If you need something like that, search the git history for `reachableGraphCyclic`.
scc :: IntGraph -> [SCC Vertex]
scc graph = map decode forest
@@ -465,47 +458,6 @@ scc graph = map decode forest
where dec (Node v ts) vs = v : foldr dec vs ts
mentions_itself v = v `elem` (graph ! v)
-{- unused?
-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)
--}
-
{-
************************************************************************
* *
@@ -625,3 +577,13 @@ reachabilityIndex = gr_reachability
nodeLookupByIx :: Graph node -> Vertex -> node
nodeLookupByIx (Graph _ from _ _) v = from v
+-- | Reachability query. On graph @g@ and nodes @a@ and @b@, @reachable(g, a,
+-- b)@ asks whether @b@ can be reached starting from @a at .
+reachable :: Graph node -- ^ @g@
+ -> node -- ^ @a@
+ -> node -- ^ @b@
+ -> Bool -- ^ @b@ is reachable from @a@
+reachable (Graph _ _ to index) 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
+
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -624,7 +624,7 @@ createBuildPlan mod_graph maybe_top_mod =
-- on the boot file.
Set.filter (\(mkNodeKey -> nk) ->
nodeKeyUnitId nk == uid -- Cheap test
- && (NodeKey_Module (key IsBoot)) `notElem` (mkNodeKey <$> mgReachable mod_graph nk)) $
+ && mgQuery mod_graph nk (NodeKey_Module (key IsBoot))) $
Set.fromList $
mgReachable mod_graph (NodeKey_Module (key NotBoot))
where
@@ -1840,7 +1840,8 @@ checkHomeUnitsClosed ue
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 $ reachablesG 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/Unit/Module/Graph.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.Unit.Module.Graph
, moduleGraphNodeModSum
, moduleGraphModulesBelow
, mgReachable
+ , mgQuery
, moduleGraphNodes
, SummaryNode
@@ -407,5 +408,16 @@ moduleGraphModulesBelow mg uid mn = filtered_mods [ mn | NodeKey_Module mn <- mo
mgReachable :: ModuleGraph -> NodeKey -> [ModuleGraphNode]
mgReachable mg nk = map summaryNodeSummary modules_below where
(td_map, lookup_node) = mg_graph mg
- modules_below = fromMaybe [] $
- reachableG td_map <$> lookup_node nk
+ modules_below = expectJust "mgReachable" $
+ reachableG' td_map <$> lookup_node nk
+
+-- | Reachability Query. @mgQuery(g, a, b)@ asks: Can we reach @b@ from @a@ in graph @g@?
+mgQuery :: ModuleGraph -- ^ @g@
+ -> NodeKey -- ^ @a@
+ -> NodeKey -- ^ @b@
+ -> Bool -- ^ @b@ is reachable from @a@
+mgQuery mg nka nkb = reachable 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
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc510042fbb87cbed53891ffdad6a8f16a16702b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc510042fbb87cbed53891ffdad6a8f16a16702b
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/20241118/53264f66/attachment-0001.html>
More information about the ghc-commits
mailing list