[Git][ghc/ghc][wip/mpickering/get-link-deps] 2 commits: fix external module graph extending
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Fri Dec 20 19:11:02 UTC 2024
Rodrigo Mesquita pushed to branch wip/mpickering/get-link-deps at Glasgow Haskell Compiler / GHC
Commits:
593a6149 by Rodrigo Mesquita at 2024-12-20T18:18:12+00:00
fix external module graph extending
- - - - -
d8599307 by Rodrigo Mesquita at 2024-12-20T19:10:53+00:00
Fixes wip
- - - - -
4 changed files:
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Unit/Module/External/Graph.hs
Changes:
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -435,12 +435,12 @@ loadHomePackageInterfacesBelow msg (Just home_unit) mods = do
dflags <- getDynFlags
let ctx = initSDocContext dflags defaultUserStyle
- forM_ mods $ \mod -> do
+ forM_ mods $ \mod -> pprTrace "modsloadhomepkgbeloW" (ppr mod) $ do
graph <- eps_module_graph <$> getEps
let key = ExternalModuleKey $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod)
- if isFullyLoadedModule key graph
+ if pprTrace "==============" (ppr graph) $ isFullyLoadedModule key graph
then return ()
else do
iface <- withIfaceErr ctx $
@@ -454,10 +454,6 @@ loadHomePackageInterfacesBelow msg (Just home_unit) mods = do
-- dependencies of that. Hence we need to traverse the dependency
-- tree recursively. See bug #936, testcase ghci/prog007.
- -- RM:TODO: WHAT WAS THIS DOING BEFORE IN FOLLOW_DEPS?
- -- (was in follow_deps)
- -- when (mi_boot iface == IsBoot) $ link_boot_mod_error mod
-
let deps = mi_deps iface
mod_deps = dep_direct_mods deps
@@ -506,10 +502,11 @@ loadInterface doc_str mod from
-- Check whether we have the interface already
; hsc_env <- getTopEnv
+ ; eps <- liftIO $ hscEPS hsc_env
; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)
; case lookupIfaceByModule hug (eps_PIT eps) mod of {
Just iface
- -> return (Succeeded iface) ; -- Already loaded
+ -> pprTrace "HWATTTT" (ppr (mi_module iface) <+> ppr (eps_module_graph eps)) $ return (Succeeded iface) ; -- Already loaded
_ -> do {
-- READ THE MODULE IN
@@ -580,19 +577,23 @@ loadInterface doc_str mod from
; purged_hsc_env <- getTopEnv
; let direct_deps = map (uncurry (flip ModNodeKeyWithUid)) $ (Set.toList (dep_direct_mods $ mi_deps iface))
- ; let direct_pkg_deps = Set.toList (dep_direct_pkgs $ mi_deps iface)
- ; let !module_graph_key =
+ ; let direct_pkg_deps = dep_direct_pkgs $ mi_deps iface
+ ; let !module_graph_key = pprTrace "module_graph_on_load" (ppr (eps_module_graph eps)) $
if moduleUnitId mod `elem` hsc_all_home_unit_ids hsc_env
--- ^ home unit mods in eps can only happen in oneshot mode
then Just $ NodeHomePackage (miKey iface) (map ExternalModuleKey direct_deps)
else Nothing
- ; let !module_graph_pkg_key = do
+ ; let !module_graph_pkg_key =
+ -- ROMES:TODO: This doesn't work as expected. Insertions on the
+ -- graph don't override previous nodes, they just create new
+ -- ones. We get multiple duplicate nodes with incomplete dependencies each.
let pkg_key = toUnitId $ moduleUnit (mi_module iface)
- pkg_node <- emgLookupKey (ExternalPackageKey pkg_key) (eps_module_graph eps)
- case pkg_node of
- NodeHomePackage{} -> panic "ExternalPackageKey lookup should never return a NodeHomePackage node"
- NodeExternalPackage _ deps_uids -> pure $
- NodeExternalPackage pkg_key (deps_uids ++ direct_pkg_deps)
+ in case emgLookupKey (ExternalPackageKey pkg_key) (eps_module_graph eps) of
+ Nothing -> NodeExternalPackage pkg_key direct_pkg_deps
+ Just pkg_node -> case pkg_node of
+ NodeHomePackage{} -> panic "ExternalPackageKey lookup should never return a NodeHomePackage node"
+ NodeExternalPackage _ deps_uids ->
+ NodeExternalPackage pkg_key (deps_uids `Set.union` direct_pkg_deps)
; let final_iface = iface
@@ -639,9 +640,7 @@ loadInterface doc_str mod from
let eps_graph' = case module_graph_key of
Just k -> extendExternalModuleGraph k (eps_module_graph eps)
Nothing -> eps_module_graph eps
- eps_graph'' = case module_graph_pkg_key of
- Just k -> extendExternalModuleGraph k eps_graph'
- Nothing -> eps_graph'
+ eps_graph'' = extendExternalModuleGraph module_graph_pkg_key eps_graph'
in eps_graph'',
eps_complete_matches
= eps_complete_matches eps ++ new_eps_complete_matches,
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -44,6 +44,7 @@ import GHC.Iface.Errors.Types
import GHC.Utils.Misc
import GHC.Unit.Home
+import GHC.Unit.External (ExternalPackageState, eps_module_graph, eps_PIT)
import GHC.Data.Maybe
import Control.Applicative
@@ -54,7 +55,7 @@ import System.FilePath
import System.Directory
import GHC.Utils.Monad (mapMaybeM)
import Data.Either (partitionEithers)
-import Data.Bifunctor (Bifunctor(..))
+import Control.Monad (forM)
data LinkDepsOpts = LinkDepsOpts
{ ldObjSuffix :: !String -- ^ Suffix of .o files
@@ -69,8 +70,8 @@ data LinkDepsOpts = LinkDepsOpts
, ldFinderCache :: !FinderCache
, ldFinderOpts :: !FinderOpts
, ldLoadByteCode :: !(Module -> IO (Maybe Linkable))
- , ldLoadHomeIfacesBelow :: !((Module -> SDoc) -> Maybe HomeUnit {- current home unit -}
- -> [Module] -> IO ExternalModuleGraph)
+ , ldLoadHomeIfacesBelow :: !((Module -> SDoc) -> Maybe HomeUnit {-^ current home unit -}
+ -> [Module] -> IO ExternalPackageState {-^ EPS after loading -})
}
data LinkDeps = LinkDeps
@@ -116,8 +117,8 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
-- 1. Find the dependent home-pkg-modules/packages from each iface
-- (omitting modules from the interactive package, which is already linked)
- (all_home_mods, pkgs_s) <- get_reachable_nodes opts relevant_mods
- mods_s <- mapMaybeM get_mod_info all_home_mods
+ (mods_s, pkgs_s) <- get_reachable_nodes opts relevant_mods
+ pprTraceM "Linkable deps:" (ppr relevant_mods $$ ppr mods_s $$ ppr pkgs_s)
let
-- 2. Exclude ones already linked
@@ -144,24 +145,9 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
, ldNeededUnits = pkgs_s
}
where
- unit_env = ldUnitEnv opts
-
+ unit_env = ldUnitEnv opts
relevant_mods = filterOut isInteractiveModule mods
- 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)
- 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
-
- link_boot_mod_error mod = throwProgramError opts $
- text "module" <+> ppr mod <+>
- text "cannot be linked; it is only available as a boot module"
-
no_obj :: Outputable a => a -> IO b
no_obj mod = dieWith opts span $
text "cannot find object file for module " <>
@@ -231,22 +217,32 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
pprPanic "Unhydrated core bindings" (ppr wcb_module)
-- See Note [Reachability in One-shot mode vs Make mode]
-get_reachable_nodes :: LinkDepsOpts -> [Module] -> IO ([ModNodeKeyWithUid], UniqDSet UnitId)
+get_reachable_nodes :: LinkDepsOpts -> [Module] -> IO ([Module], UniqDSet UnitId)
get_reachable_nodes opts mods
-- Reachability on 'ExternalModuleGraph' (for one shot mode)
| ldOneShotMode opts
= do
- emg <- ldLoadHomeIfacesBelow opts msg (ue_homeUnit (ldUnitEnv opts)) mods
- go (ExternalModuleKey . mkModuleNk) emgNodeKey (emgReachableMany emg) (map emgProject)
- --romes:todo:^ make sure we only get non-boot files out of this. perhaps as
- --easy as filtering them out by ModNodeKeyWithUid with is boot information.
+ eps <- ldLoadHomeIfacesBelow opts msg (ue_homeUnit (ldUnitEnv opts)) mods
+ let
+ emg = eps_module_graph eps
+ get_mod_info_eps (ModNodeKeyWithUid gwib uid)
+ | Just iface <- lookupModuleEnv (eps_PIT eps) (Module (RealUnit $ Definite uid) (gwib_mod gwib))
+ = return iface
+ | otherwise
+ = moduleNotLoaded "(in EPS)" gwib uid
+
+ go (ExternalModuleKey . mkModuleNk) emgNodeKey (emgReachableMany emg) (map emgProject) get_mod_info_eps
+ --romes:todo:^ do we need to make sure we only get non-boot files out of
+ --this. perhaps as easy as filtering them out by ModNodeKeyWithUid with is
+ --boot information?
-- Reachability on 'ModuleGraph' (for --make mode)
| otherwise
- = go hmgModKey mkNodeKey (mgReachableLoop hmGraph) (catMaybes . map hmgProject)
+ = go hmgModKey mkNodeKey (mgReachableLoop hmGraph) (catMaybes . map hmgProject) get_mod_info_hug
where
+ unit_env = ldUnitEnv opts
mkModuleNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)
msg mod =
text "need to link module" <+> ppr mod <+>
@@ -274,11 +270,31 @@ get_reachable_nodes opts mods
-> (node -> key)
-> ([key] -> [node])
-> ([key] -> [Either ModNodeKeyWithUid UnitId])
- -> IO ([ModNodeKeyWithUid], UniqDSet UnitId)
- go modKey nodeKey manyReachable project
+ -> (ModNodeKeyWithUid -> IO ModIface)
+ -> IO ([Module], UniqDSet UnitId)
+ go modKey nodeKey manyReachable project get_mod_info
| let mod_keys = map modKey mods
- = pure $ second mkUniqDSet $ partitionEithers $ project $
- mod_keys ++ map nodeKey (manyReachable mod_keys)
+ = do
+ let (all_home_mods, pkgs_s) = partitionEithers $ project $ mod_keys ++ map nodeKey (manyReachable mod_keys)
+ ifaces <- mapM get_mod_info all_home_mods
+ mods_s <- forM ifaces $ \iface -> case mi_hsc_src iface of
+ HsBootFile -> link_boot_mod_error (mi_module iface)
+ _ -> return $ mi_module iface
+ return (mods_s, mkUniqDSet pkgs_s)
+
+ get_mod_info_hug (ModNodeKeyWithUid gwib uid)
+ | Just hmi <- lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib)
+ = return (hm_iface hmi)
+ | otherwise
+ = moduleNotLoaded "(in HUG)" gwib uid
+
+ moduleNotLoaded m gwib uid = throwProgramError opts $
+ text "getLinkDeps: Home module not loaded" <+> text m <+> ppr (gwib_mod gwib) <+> ppr uid
+
+ link_boot_mod_error mod = throwProgramError opts $
+ text "module" <+> ppr mod <+>
+ text "cannot be linked; it is only available as a boot module"
+
{-
Note [Using Byte Code rather than Object Code for Template Haskell]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -76,7 +76,7 @@ import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Unit.Env
-import GHC.Unit.External (ExternalPackageState (EPS, eps_iface_bytecode, eps_module_graph))
+import GHC.Unit.External (ExternalPackageState (EPS, eps_iface_bytecode))
import GHC.Unit.Module
import GHC.Unit.State as Packages
@@ -611,8 +611,8 @@ initLinkDepsOpts hsc_env = opts
= do
initIfaceCheck (text "loader") hsc_env
$ loadHomePackageInterfacesBelow msg hu mods
- -- Read the module graph only after `loadHomePackageInterfacesBelow`
- eps_module_graph <$> hscEPS hsc_env
+ -- Read the EPS only after `loadHomePackageInterfacesBelow`
+ hscEPS hsc_env
ldLoadByteCode mod = do
EPS {eps_iface_bytecode} <- hscEPS hsc_env
=====================================
compiler/GHC/Unit/Module/External/Graph.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Like @'GHC.Unit.Module.Graph'@ but for the @'ExternalModuleGraph'@ which is
-- stored in the EPS.
@@ -59,6 +60,7 @@ 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.Bifunctor (first)
import Data.Maybe
import GHC.Utils.Outputable
import GHC.Unit.Types (UnitId)
@@ -89,7 +91,7 @@ data ExternalGraphNode
-- dependency.
| NodeExternalPackage
{ externalPkgKey :: UnitId
- , externalPkgDeps :: [UnitId]
+ , externalPkgDeps :: S.Set UnitId
}
data ExternalKey
@@ -100,20 +102,11 @@ data ExternalKey
emptyExternalModuleGraph :: ExternalModuleGraph
emptyExternalModuleGraph = ExternalModuleGraph [] (graphReachability emptyGraph, const Nothing) S.empty
-mkExternalModuleGraph :: [ExternalGraphNode] -> S.Set ExternalKey -> ExternalModuleGraph
--- romes:todo: does this also need to be defined in terms of extend (like for `ModuleGraph`?)
-mkExternalModuleGraph nodes loaded =
- ExternalModuleGraph {
- external_nodes = nodes
- , external_trans = let (g, f) = (externalGraphNodes nodes)
- in (graphReachability g, f)
- , external_fully_loaded = loaded }
-
-- | Get the dependencies of an 'ExternalNode'
emgNodeDeps :: ExternalGraphNode -> [ExternalKey]
emgNodeDeps = \case
NodeHomePackage _ dps -> dps
- NodeExternalPackage _ dps -> map ExternalPackageKey dps
+ NodeExternalPackage _ dps -> map ExternalPackageKey $ S.toList dps
-- | The graph key for a given node
emgNodeKey :: ExternalGraphNode -> ExternalKey
@@ -129,7 +122,14 @@ emgLookupKey k emg = node_payload <$> (snd (external_trans emg)) k
--------------------------------------------------------------------------------
extendExternalModuleGraph :: ExternalGraphNode -> ExternalModuleGraph -> ExternalModuleGraph
-extendExternalModuleGraph node graph = mkExternalModuleGraph (node : external_nodes graph) (external_fully_loaded graph)
+extendExternalModuleGraph node ExternalModuleGraph{..} =
+ ExternalModuleGraph
+ { external_fully_loaded = external_fully_loaded
+ , external_nodes = node : external_nodes
+ , external_trans = first graphReachability $
+ externalGraphNodes (node : external_nodes)
+ }
+
--------------------------------------------------------------------------------
-- * Loading
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1528985b4bcc6c49492ab266a8d4909dd37c2cf...d8599307d8fa6bdd30859e72b7273b723b1bd005
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1528985b4bcc6c49492ab266a8d4909dd37c2cf...d8599307d8fa6bdd30859e72b7273b723b1bd005
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/20241220/8aa63d80/attachment-0001.html>
More information about the ghc-commits
mailing list