[Git][ghc/ghc][wip/mpickering/get-link-deps] WIP external grpah
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Wed Dec 18 15:37:39 UTC 2024
Rodrigo Mesquita pushed to branch wip/mpickering/get-link-deps at Glasgow Haskell Compiler / GHC
Commits:
a4db8f72 by Matthew Pickering at 2024-12-18T15:37:24+00:00
WIP external grpah
getLinkDeps and ExternalNode
missing file
fix plugin loading
(now rebased)
- - - - -
13 changed files:
- compiler/GHC/Data/Graph/Directed/Reachability.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Unit/External.hs
- + compiler/GHC/Unit/Module/External/Graph.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Data/Graph/Directed/Reachability.hs
=====================================
@@ -7,7 +7,7 @@ module GHC.Data.Graph.Directed.Reachability
, graphReachability, cyclicGraphReachability
-- * Reachability queries
- , allReachable, allReachableMany
+ , allReachable, allReachableMany, allReachableManyWithRoots
, isReachable, isReachableMany
)
where
@@ -132,6 +132,23 @@ allReachableMany (ReachabilityIndex index from to) roots = map from (IS.toList h
hits = {-# SCC "allReachableMany" #-}
IS.unions $ map (expectJust "reachablesG" . flip IM.lookup index) roots_i
+-- | 'allReachableManyWithRoots' returns all nodes reachable from the many given @roots at .
+--
+-- Properties:
+-- * The list of nodes includes 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').
+allReachableManyWithRoots :: ReachabilityIndex node -> [node] {-^ The @roots@ -} -> [node] {-^ All nodes reachable from all @roots@ -}
+allReachableManyWithRoots (ReachabilityIndex index from to) roots = map from (IS.toList hits)
+ where roots_i = [ v | Just v <- map to roots ]
+ hits = IS.union (IS.fromList roots_i)
+ (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@
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -589,6 +589,7 @@ mkBackpackMsg = do
MustCompile -> empty
RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"
LinkNode _ _ -> showMsg (text "Linking ") empty
+ PackageNode {} -> showMsg (text "Package ") empty
-- | 'PprStyle' for Backpack messages; here we usually want the module to
-- be qualified (so we can tell how it was instantiated.) But we try not
=====================================
compiler/GHC/Driver/Errors/Ppr.hs
=====================================
@@ -261,6 +261,7 @@ instance Diagnostic DriverMessage where
ppr_node (ModuleNode _deps m) = text "module" <+> ppr_ms m
ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u
ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid)
+ ppr_node (PackageNode uid _) = pprPanic "PackageNode should not be in a cycle" (ppr uid)
ppr_ms :: ModSummary -> SDoc
ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1469,6 +1469,7 @@ batchMsgWith extra hsc_env_start mod_index recomp node =
LinkNode {} -> "Linking"
InstantiationNode {} -> "Instantiating"
ModuleNode {} -> "Compiling"
+ PackageNode {} -> "Loading"
hsc_env = hscSetActiveUnitId (mgNodeUnitId node) hsc_env_start
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1110,7 +1110,16 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do
where
collect_result res_var = runMaybeT (waitResult res_var)
- n_mods = sum (map countMods plan)
+ -- Just used for an assertion
+ count_mods :: BuildPlan -> Int
+ count_mods (SingleModule m) = count_m m
+ count_mods (ResolvedCycle ns) = length ns
+ count_mods (UnresolvedCycle ns) = length ns
+
+ count_m (PackageNode {}) = 0
+ count_m _ = 1
+
+ n_mods = sum (map count_mods plan)
buildLoop :: [BuildPlan]
-> BuildM (Maybe [ModuleGraphNode], [MakeAction])
@@ -1141,7 +1150,6 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do
-> ModuleGraphNode -- The node we are compiling
-> BuildM MakeAction
buildSingleModule rehydrate_nodes origin mod = do
- mod_idx <- nodeId
!build_map <- getBuildMap
hug_var <- gets hug_var
-- 1. Get the direct dependencies of this module
@@ -1150,17 +1158,19 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do
-- which would retain all the result variables, preventing us from collecting them
-- after they are no longer used.
!build_deps = getDependencies direct_deps build_map
- let !build_action =
+ !build_action <-
case mod of
InstantiationNode uid iu -> do
- withCurrentUnit (mgNodeUnitId mod) $ do
+ mod_idx <- nodeId
+ return $ withCurrentUnit (mgNodeUnitId mod) $ do
(hug, deps) <- wait_deps_hug hug_var build_deps
executeInstantiationNode mod_idx n_mods hug uid iu
return (Nothing, deps)
- ModuleNode _build_deps ms ->
+ ModuleNode _build_deps ms -> do
let !old_hmi = M.lookup (msKey ms) old_hpt
rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes
- in withCurrentUnit (mgNodeUnitId mod) $ do
+ mod_idx <- nodeId
+ return $ withCurrentUnit (mgNodeUnitId mod) $ do
(hug, deps) <- wait_deps_hug hug_var build_deps
hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms
-- Write the HMI to an external cache (if one exists)
@@ -1171,10 +1181,12 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do
liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi)
return (Just hmi, addToModuleNameSet (mgNodeUnitId mod) (ms_mod_name ms) deps )
LinkNode _nks uid -> do
- withCurrentUnit (mgNodeUnitId mod) $ do
+ mod_idx <- nodeId
+ return $ withCurrentUnit (mgNodeUnitId mod) $ do
(hug, deps) <- wait_deps_hug hug_var build_deps
executeLinkNode hug (mod_idx, n_mods) uid direct_deps
return (Nothing, deps)
+ PackageNode {} -> return $ return (Nothing, mempty)
res_var <- liftIO newEmptyMVar
@@ -1288,8 +1300,6 @@ upsweep n_jobs hsc_env hmi_cache diag_wrapper mHscMessage old_hpt build_plan = d
toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo
toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])
-miKey :: ModIface -> ModNodeKeyWithUid
-miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi)))
upsweep_inst :: HscEnv
-> Maybe Messager
@@ -1712,9 +1722,10 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
Nothing excl_mods
case mb_s of
NotThere -> loopImports ss done summarised
- External _ -> do
- (other_deps, done', summarised') <- loopImports ss done summarised
- return (other_deps, done', summarised')
+ External uid -> do
+ let done' = loopUnit done [uid]
+ (other_deps, done'', summarised') <- loopImports ss done' summarised
+ return (NodeKey_ExternalUnit uid : other_deps, done'', summarised')
FoundInstantiation iud -> do
(other_deps, done', summarised') <- loopImports ss done summarised
return (NodeKey_Unit iud : other_deps, done', summarised')
@@ -1732,6 +1743,16 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro
GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
wanted_mod = L loc mod
+ loopUnit :: Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
+ loopUnit cache [] = cache
+ loopUnit cache (u:uxs) = do
+ let nk = (NodeKey_ExternalUnit u)
+ case Map.lookup nk cache of
+ Just {} -> loopUnit cache uxs
+ Nothing -> case unitDepends <$> lookupUnitId (hsc_units hsc_env) u of
+ Just us -> loopUnit (loopUnit (Map.insert nk (PackageNode us u) cache) us) uxs
+ Nothing -> panic "bad"
+
getRootSummary ::
[ModuleName] ->
M.Map (UnitId, FilePath) ModSummary ->
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -221,6 +221,7 @@ processDeps _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))
GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node
processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()
+processDeps _dflags _ _ _ _ (AcyclicSCC (PackageNode {})) = return ()
processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node))
= do { let extra_suffixes = depSuffixes dflags
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -108,6 +108,7 @@ import GHC.Unit.Home
import GHC.Unit.Home.ModInfo
import GHC.Unit.Finder
import GHC.Unit.Env
+import GHC.Unit.Module.External.Graph
import GHC.Data.Maybe
@@ -119,6 +120,8 @@ import GHC.Driver.Env.KnotVars
import {-# source #-} GHC.Driver.Main (loadIfaceByteCode)
import GHC.Iface.Errors.Types
import Data.Function ((&))
+import qualified Data.Set as Set
+import GHC.Unit.Module.Graph
{-
************************************************************************
@@ -407,6 +410,21 @@ loadInterfaceWithException doc mod_name where_from
let ctx = initSDocContext dflags defaultUserStyle
withIfaceErr ctx (loadInterface doc mod_name where_from)
+-- | Load all interfaces from the home package, presumes that this operation
+-- can be completed by traversing from the already loaded home packages.
+
+-- This operation is used just before TH splices are run.
+
+-- The first time this is run
+-- A field in the EPS tracks which home modules are fully loaded
+_loadHomePackageInterfacesBelow :: ModNodeKeyWithUid -> IfM lcl ()
+_loadHomePackageInterfacesBelow mn = do
+ graph <- eps_module_graph <$> getEps
+ let key = ExternalModuleKey mn
+ if isFullyLoadedModule key graph
+ then return ()
+ else return ()
+
------------------
loadInterface :: SDoc -> Module -> WhereFrom
-> IfM lcl (MaybeErr MissingInterfaceError ModIface)
@@ -515,6 +533,12 @@ loadInterface doc_str mod from
; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
; purged_hsc_env <- getTopEnv
+ ; let direct_deps = map (uncurry (flip ModNodeKeyWithUid)) $ (Set.toList (dep_direct_mods $ mi_deps iface))
+ ; let !module_graph_key =
+ if moduleUnitId mod `elem` hsc_all_home_unit_ids hsc_env
+ then Just $ NodeHomePackage (miKey iface) (map ExternalModuleKey direct_deps)
+ else Nothing
+
; let final_iface = iface
& set_mi_decls (panic "No mi_decls in PIT")
& set_mi_insts (panic "No mi_insts in PIT")
@@ -555,6 +579,9 @@ loadInterface doc_str mod from
eps_iface_bytecode = add_bytecode (eps_iface_bytecode eps),
eps_rule_base = extendRuleBaseList (eps_rule_base eps)
new_eps_rules,
+ eps_module_graph = case module_graph_key of
+ Just k -> extendExternalModuleGraph k (eps_module_graph eps)
+ Nothing -> eps_module_graph eps,
eps_complete_matches
= eps_complete_matches eps ++ new_eps_complete_matches,
eps_inst_env = extendInstEnvList (eps_inst_env eps)
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -121,8 +121,8 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
then follow_deps (filterOut isInteractiveModule mods)
emptyUniqDSet emptyUniqDSet;
else do
- (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods
- return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs))
+ mmods <- mapM get_mod_info all_home_mods
+ return (catMaybes mmods, mkUniqDSet all_dep_pkgs)
let
-- 2. Exclude ones already linked
@@ -152,44 +152,25 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
mod_graph = ldModuleGraph opts
unit_env = ldUnitEnv opts
- -- This code is used in `--make` mode to calculate the home package and unit dependencies
- -- for a set of modules.
- --
- -- It is significantly more efficient to use the shared transitive dependency
- -- calculation than to compute the transitive dependency set in the same manner as oneShot mode.
-
- -- It is also a matter of correctness to use the module graph so that dependencies between home units
- -- is resolved correctly.
- make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey)
- 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
- | 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)
-
- all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps]
+ mkNk m
+ = let k = NodeKey_Module (ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m))
+ in if mgMember mod_graph k
+ then k
+ else NodeKey_ExternalUnit (moduleUnitId m)
+
+ initial_keys = map mkNk (filterOut isInteractiveModule mods)
+ all_deps = initial_keys ++ map mkNodeKey (mgReachableLoop mod_graph initial_keys)
+
+ all_home_mods = [with_uid | NodeKey_Module with_uid <- all_deps]
+ all_dep_pkgs = [uid | NodeKey_ExternalUnit uid <- all_deps]
get_mod_info (ModNodeKeyWithUid gwib uid) =
case lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) of
Just hmi ->
let iface = (hm_iface hmi)
- mmod = case mi_hsc_src iface of
- HsBootFile -> link_boot_mod_error (mi_module iface)
- _ -> return $ Just (mi_module iface)
-
- in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod
+ in case mi_hsc_src iface of
+ HsBootFile -> link_boot_mod_error (mi_module iface)
+ _ -> return $ Just (mi_module iface)
Nothing -> throwProgramError opts $
text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid
=====================================
compiler/GHC/Unit/External.hs
=====================================
@@ -32,6 +32,7 @@ import GHC.Types.TypeEnv
import GHC.Types.Unique.DSet
import GHC.Linker.Types (Linkable)
+import GHC.Unit.Module.External.Graph
import Data.IORef
@@ -70,6 +71,7 @@ initExternalPackageState = EPS
, eps_PIT = emptyPackageIfaceTable
, eps_free_holes = emptyInstalledModuleEnv
, eps_PTE = emptyTypeEnv
+ , eps_module_graph = emptyExternalModuleGraph
, eps_iface_bytecode = emptyModuleEnv
, eps_inst_env = emptyInstEnv
, eps_fam_inst_env = emptyFamInstEnv
@@ -137,6 +139,8 @@ data ExternalPackageState
-- for every import, so cache it here. When the PIT
-- gets filled in we can drop these entries.
+ eps_module_graph :: ExternalModuleGraph,
+
eps_PTE :: !PackageTypeEnv,
-- ^ Result of typechecking all the external package
-- interface files we have sucked in. The domain of
=====================================
compiler/GHC/Unit/Module/External/Graph.hs
=====================================
@@ -0,0 +1,81 @@
+-- | Like GHC.Unit.Module.Graph but for the ExternalModuleGraph which
+-- is stored in the EPS.
+module GHC.Unit.Module.External.Graph where
+
+import GHC.Prelude
+import GHC.Unit.Module.Graph
+import GHC.Data.Graph.Directed.Reachability
+import GHC.Data.Graph.Directed
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Maybe
+
+data ExternalKey = ExternalModuleKey ModNodeKeyWithUid deriving (Eq, Ord)
+
+data ExternalGraphNode = NodeHomePackage {
+ externalNodeKey :: ModNodeKeyWithUid
+ , externalNodeDeps :: [ExternalKey] }
+
+externalKey :: ExternalGraphNode -> ExternalKey
+externalKey (NodeHomePackage k _) = ExternalModuleKey k
+
+type ExternalNode = Node Int ExternalGraphNode
+
+data ExternalModuleGraph = ExternalModuleGraph
+ { external_nodes :: [ExternalGraphNode]
+ , external_trans :: (ReachabilityIndex ExternalNode, ExternalKey -> Maybe ExternalNode)
+ , external_fully_loaded :: !(S.Set ExternalKey) }
+
+emptyExternalModuleGraph :: ExternalModuleGraph
+emptyExternalModuleGraph = ExternalModuleGraph [] (graphReachability emptyGraph, const Nothing) S.empty
+
+extendExternalModuleGraph :: ExternalGraphNode -> ExternalModuleGraph -> ExternalModuleGraph
+extendExternalModuleGraph node graph = mkExternalModuleGraph (node : external_nodes graph) (external_fully_loaded graph)
+
+setFullyLoadedModule :: ExternalKey -> ExternalModuleGraph -> ExternalModuleGraph
+setFullyLoadedModule key graph = graph { external_fully_loaded = S.insert key (external_fully_loaded graph)}
+
+isFullyLoadedModule :: ExternalKey -> ExternalModuleGraph -> Bool
+isFullyLoadedModule key graph = S.member key (external_fully_loaded graph)
+
+mkExternalModuleGraph :: [ExternalGraphNode] -> S.Set ExternalKey -> ExternalModuleGraph
+mkExternalModuleGraph nodes loaded =
+ ExternalModuleGraph {
+ external_nodes = nodes
+ , external_trans = let (g, f) = (externalGraphNodes nodes)
+ in (graphReachability g, f)
+ , external_fully_loaded = loaded }
+
+-- | Turn a list of graph nodes into an efficient queriable graph.
+-- The first boolean parameter indicates whether nodes corresponding to hs-boot files
+-- should be collapsed into their relevant hs nodes.
+externalGraphNodes ::
+ [ExternalGraphNode]
+ -> (Graph ExternalNode, ExternalKey -> Maybe ExternalNode)
+externalGraphNodes summaries =
+ (graphFromEdgedVerticesUniq nodes, lookup_node)
+ where
+ -- Map from module to extra boot summary dependencies which need to be merged in
+ nodes = map go numbered_summaries
+
+ where
+ go (s, key) = DigraphNode s key $ out_edge_keys $
+ (externalNodeDeps s)
+
+ numbered_summaries = zip summaries [1..]
+
+ lookup_node :: ExternalKey -> Maybe ExternalNode
+ lookup_node key = M.lookup key node_map
+
+ lookup_key :: ExternalKey -> Maybe Int
+ lookup_key = fmap node_key . lookup_node
+
+ node_map :: M.Map ExternalKey ExternalNode
+ node_map =
+ M.fromList [ (externalKey s, node)
+ | node <- nodes
+ , let s = node_payload node
+ ]
+
+ out_edge_keys :: [ExternalKey] -> [Int]
+ out_edge_keys = mapMaybe lookup_key
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -57,8 +57,10 @@ module GHC.Unit.Module.Graph
-- answer reachability queries -- is X reachable from Y; or, what is the
-- transitive closure of Z?
, mgReachable
+ , mgReachableLoop
, mgQuery
, mgQueryMany
+ , mgMember
-- ** Other operations
--
@@ -143,13 +145,22 @@ import Control.Monad
data ModuleGraph = ModuleGraph
{ mg_mss :: [ModuleGraphNode]
, 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)
+ , mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
+
+ -- `mg_graph` and `mg_loop_graph` cached transitive dependency calculations
+ -- so that a lot of work is not repeated whenever the transitive
+ -- dependencies need to be calculated (for example, hptInstances).
+ --
+ -- * `mg_graph` is a reachability index constructed from a module
+ -- graph /with/ boot nodes (which make the graph acyclic), and
+ --
+ -- * `mg_loop_graph` is a reachability index for the graph /without/
+ -- hs-boot nodes, that may be cyclic.
}
-- | Why do we ever need to construct empty graphs? Is it because of one shot mode?
emptyMG :: ModuleGraph
-emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing)
+emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (graphReachability emptyGraph, const Nothing)
-- | Construct a module graph. This function should be the only entry point for
-- building a 'ModuleGraph', since it is supposed to be built once and never modified.
@@ -160,7 +171,7 @@ emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing)
-- modification, perhaps like what is done for building arrays from mutable
-- arrays.
mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph
-mkModuleGraph = foldr (flip extendMG') emptyMG
+mkModuleGraph = foldr (flip extendMG) emptyMG
--------------------------------------------------------------------------------
-- * Module Graph Nodes
@@ -177,6 +188,8 @@ data ModuleGraphNode
| ModuleNode [NodeKey] ModSummary
-- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit.
| LinkNode [NodeKey] UnitId
+ -- | Package dependency
+ | PackageNode [UnitId] UnitId
-- | Collect the immediate dependencies of a ModuleGraphNode,
-- optionally avoiding hs-boot dependencies.
@@ -193,6 +206,7 @@ mgNodeDependencies drop_hs_boot_nodes = \case
NodeKey_Module . (\mod -> ModNodeKeyWithUid (GWIB mod NotBoot) uid) <$> uniqDSetToList (instUnitHoles iuid)
ModuleNode deps _ms ->
map drop_hs_boot deps
+ PackageNode deps _ -> map NodeKey_ExternalUnit deps
where
-- Drop hs-boot nodes by using HsSrcFile as the key
hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature
@@ -205,6 +219,7 @@ mgNodeModSum :: ModuleGraphNode -> Maybe ModSummary
mgNodeModSum (InstantiationNode {}) = Nothing
mgNodeModSum (LinkNode {}) = Nothing
mgNodeModSum (ModuleNode _ ms) = Just ms
+mgNodeModSum (PackageNode {}) = Nothing
mgNodeUnitId :: ModuleGraphNode -> UnitId
mgNodeUnitId mgn =
@@ -212,12 +227,14 @@ mgNodeUnitId mgn =
InstantiationNode uid _iud -> uid
ModuleNode _ ms -> toUnitId (moduleUnit (ms_mod ms))
LinkNode _ uid -> uid
+ PackageNode _ uid -> uid
instance Outputable ModuleGraphNode where
ppr = \case
InstantiationNode _ iuid -> ppr iuid
ModuleNode nks ms -> ppr (msKey ms) <+> ppr nks
LinkNode uid _ -> text "LN:" <+> ppr uid
+ PackageNode _ uid -> text "P:" <+> ppr uid
instance Eq ModuleGraphNode where
(==) = (==) `on` mkNodeKey
@@ -245,6 +262,7 @@ mapMG f mg at ModuleGraph{..} = mg
InstantiationNode uid iuid -> InstantiationNode uid iuid
LinkNode uid nks -> LinkNode uid nks
ModuleNode deps ms -> ModuleNode deps (f ms)
+ PackageNode deps uid -> PackageNode deps uid
}
-- | Map a function 'f' over all the 'ModSummaries', in 'IO'.
@@ -255,6 +273,7 @@ mgMapM f mg at ModuleGraph{..} = do
InstantiationNode uid iuid -> pure $ InstantiationNode uid iuid
LinkNode uid nks -> pure $ LinkNode uid nks
ModuleNode deps ms -> ModuleNode deps <$> (f ms)
+ PackageNode deps uid -> pure $ PackageNode deps uid
return mg
{ mg_mss = mss'
}
@@ -262,9 +281,9 @@ mgMapM f mg at ModuleGraph{..} = do
mgModSummaries :: ModuleGraph -> [ModSummary]
mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]
--- | Look up a ModSummary in the ModuleGraph
--- Looks up the non-boot ModSummary
--- Linear in the size of the module graph
+-- | Look up a non-boot ModSummary in the ModuleGraph.
+--
+-- Careful: Linear in the size of the module graph
mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
where
@@ -274,6 +293,9 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
= Just ms
go _ = Nothing
+mgMember :: ModuleGraph -> NodeKey -> Bool
+mgMember graph k = isJust $ snd (mg_graph graph) k
+
--------------------------------------------------------------------------------
-- ** Reachability
--------------------------------------------------------------------------------
@@ -285,6 +307,13 @@ mgReachable mg nk = map summaryNodeSummary <$> modules_below where
modules_below =
allReachable td_map <$> lookup_node nk
+-- | Things which are reachable if hs-boot files are ignored. Used by 'getLinkDeps'
+mgReachableLoop :: ModuleGraph -> [NodeKey] -> [ModuleGraphNode]
+mgReachableLoop mg nk = map summaryNodeSummary modules_below where
+ (td_map, lookup_node) = mg_loop_graph mg
+ modules_below =
+ allReachableMany td_map (mapMaybe lookup_node nk)
+
-- | Reachability Query.
--
-- @mgQuery(g, a, b)@ asks:
@@ -402,9 +431,8 @@ moduleGraphModulesBelow mg uid mn = filtered_mods [ mn | NodeKey_Module mn <- mo
filterToposortToModules
:: [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case
- InstantiationNode _ _ -> Nothing
- LinkNode{} -> Nothing
ModuleNode _deps node -> Just node
+ _ -> Nothing
where
-- This higher order function is somewhat bogus,
-- as the definition of "strongly connected component"
@@ -424,23 +452,27 @@ filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case
data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit
| NodeKey_Module {-# UNPACK #-} !ModNodeKeyWithUid
| NodeKey_Link !UnitId
+ | NodeKey_ExternalUnit !UnitId
deriving (Eq, Ord)
instance Outputable NodeKey where
ppr (NodeKey_Unit iu) = ppr iu
ppr (NodeKey_Module mk) = ppr mk
ppr (NodeKey_Link uid) = ppr uid
+ ppr (NodeKey_ExternalUnit uid) = ppr uid
mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey = \case
InstantiationNode _ iu -> NodeKey_Unit iu
ModuleNode _ x -> NodeKey_Module $ msKey x
LinkNode _ uid -> NodeKey_Link uid
+ PackageNode _ uid -> NodeKey_ExternalUnit uid
nodeKeyUnitId :: NodeKey -> UnitId
nodeKeyUnitId (NodeKey_Unit iu) = instUnitInstanceOf iu
nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk
nodeKeyUnitId (NodeKey_Link uid) = uid
+nodeKeyUnitId (NodeKey_ExternalUnit uid) = uid
nodeKeyModName :: NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk)
@@ -482,6 +514,7 @@ showModMsg dflags _ (LinkNode {}) =
arch_os = platformArchOS platform
exe_file = exeFileName arch_os staticLink (outputFile_ dflags)
in text exe_file
+showModMsg _ _ (PackageNode _deps uid) = ppr uid
showModMsg _ _ (InstantiationNode _uid indef_unit) =
ppr $ instUnitInstanceOf indef_unit
showModMsg dflags recomp (ModuleNode _ mod_summary) =
@@ -520,25 +553,16 @@ newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }
mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False
-extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
-extendMG' mg = \case
- InstantiationNode uid depUnitId -> extendMGInst mg uid depUnitId
- ModuleNode deps ms -> extendMG mg deps ms
- LinkNode deps uid -> extendMGLink mg uid deps
+mkTransLoopDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
+mkTransLoopDeps = first cyclicGraphReachability . moduleGraphNodes True
-- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is
-- not an element of the ModuleGraph.
-extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph
-extendMG ModuleGraph{..} deps ms = ModuleGraph
- { mg_mss = ModuleNode deps ms : mg_mss
- , mg_graph = mkTransDeps (ModuleNode deps ms : mg_mss)
- }
-
-extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph
-extendMGInst mg uid depUnitId = mg
- { mg_mss = InstantiationNode uid depUnitId : mg_mss mg
- }
-
-extendMGLink :: ModuleGraph -> UnitId -> [NodeKey] -> ModuleGraph
-extendMGLink mg uid nks = mg { mg_mss = LinkNode nks uid : mg_mss mg }
+extendMG :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
+extendMG ModuleGraph{..} node =
+ ModuleGraph
+ { mg_mss = node : mg_mss
+ , mg_graph = mkTransDeps (node : mg_mss)
+ , mg_loop_graph = mkTransLoopDeps (node : mg_mss)
+ }
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -82,6 +82,7 @@ module GHC.Unit.Module.ModIface
, IfaceImport(..)
, mi_boot
, mi_fix
+ , miKey
, mi_semantic_module
, mi_free_holes
, mi_mnwib
@@ -125,6 +126,7 @@ import GHC.Utils.Binary
import Control.DeepSeq
import Control.Exception
+import GHC.Unit.Module.Graph (ModNodeKeyWithUid(..))
{- Note [Interface file stages]
@@ -362,6 +364,9 @@ data ModIface_ (phase :: ModIfacePhase)
-- See Note [Sharing of ModIface].
}
+miKey :: ModIface -> ModNodeKeyWithUid
+miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi)))
+
-- Enough information to reconstruct the top level environment for a module
data IfaceTopEnv
= IfaceTopEnv
=====================================
compiler/ghc.cabal.in
=====================================
@@ -941,6 +941,7 @@ Library
GHC.Unit.Module.Deps
GHC.Unit.Module.Env
GHC.Unit.Module.Graph
+ GHC.Unit.Module.External.Graph
GHC.Unit.Module.Imported
GHC.Unit.Module.Location
GHC.Unit.Module.ModDetails
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a4db8f7223054067d1c3aa25b2eb637cd3605675
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a4db8f7223054067d1c3aa25b2eb637cd3605675
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/20241218/2af8ed16/attachment-0001.html>
More information about the ghc-commits
mailing list