[Git][ghc/ghc][wip/romes/graph-compact-easy] MP fixes

[Rodrigo Mesquita (@alt-romes)]

Rodrigo Mesquita pushed to branch wip/romes/graph-compact-easy at Glasgow Haskell Compiler / GHC


Commits:
6aed1559 by Matthew Pickering at 2024-11-19T12:08:25+00:00
MP fixes

- - - - -


3 changed files:

- compiler/GHC/Driver/Make.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Unit/Module/Graph.hs


Changes:

=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -626,7 +626,7 @@ createBuildPlan mod_graph maybe_top_mod =
             nodeKeyUnitId nk == uid  -- Cheap test
               && mgQuery mod_graph nk (NodeKey_Module (key IsBoot))) $
           Set.fromList $
-          mgReachable mod_graph (NodeKey_Module (key NotBoot))
+          expectJust "not_boot_dep"  (mgReachable mod_graph (NodeKey_Module (key NotBoot)))
           where
             key ib = ModNodeKeyWithUid (GWIB mn ib) uid
 


=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -164,18 +164,17 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
     make_deps_loop found [] = found
     make_deps_loop found@(found_units, found_mods) (nk:nexts)
       | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts
-
-      | mgMember mod_graph (NodeKey_Module nk)
-      , let (ModNodeKeyWithUid _ uid) = nk
-      = make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts
-
-      | otherwise
-      , let trans_deps = mkNodeKey <$> mgReachable mod_graph (NodeKey_Module nk)
-            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]
-      = make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
+      | otherwise =
+        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/Unit/Module/Graph.hs
=====================================
@@ -24,7 +24,6 @@ module GHC.Unit.Module.Graph
    , moduleGraphModulesBelow
    , mgReachable
    , mgQuery
-   , mgMember
 
    , moduleGraphNodes
    , SummaryNode
@@ -74,6 +73,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
@@ -389,7 +389,7 @@ type ModNodeKey = ModuleNameWithIsBoot
 moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
 moduleGraphModulesBelow mg uid mn = filtered_mods [ mn | NodeKey_Module mn <- modules_below ]
   where
-    modules_below = mkNodeKey <$> mgReachable mg (NodeKey_Module (ModNodeKeyWithUid mn uid))
+    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
@@ -406,10 +406,10 @@ moduleGraphModulesBelow mg uid mn = filtered_mods [ mn | NodeKey_Module mn <- mo
         | otherwise -> r1 : filter_mods (r2:rs)
       rs -> rs
 
-mgReachable :: ModuleGraph -> NodeKey -> [ModuleGraphNode]
-mgReachable mg nk = map summaryNodeSummary modules_below where
+mgReachable :: HasCallStack => ModuleGraph -> NodeKey -> Maybe [ModuleGraphNode]
+mgReachable mg nk = map summaryNodeSummary <$> modules_below where
   (td_map, lookup_node) = mg_graph mg
-  modules_below = expectJust "mgReachable" $
+  modules_below =
     reachableFromG td_map <$> lookup_node nk
 
 -- | Reachability Query. @mgQuery(g, a, b)@ asks: Can we reach @b@ from @a@ in
@@ -424,10 +424,3 @@ mgQuery mg nka nkb = reachableQuery td_map na nb where
   na = expectJust "mgQuery:a" $ lookup_node nka
   nb = expectJust "mgQuery:b" $ lookup_node nkb
 
--- | Is @k@ in @g@?
-mgMember :: ModuleGraph -- ^ @g@
-         -> NodeKey -- ^ @k@
-         -> Bool
-mgMember mg nk = isJust $ ixLookupByNode td_map =<< k where
-    (td_map, lookup_node) = mg_graph mg
-    k = lookup_node nk



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6aed1559246007bb8c2049b790b2a8613e08e8c6

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6aed1559246007bb8c2049b790b2a8613e08e8c6
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/20241119/d5abd9f0/attachment-0001.html>