Torsten Schmits pushed to branch wip/torsten.schmits/mercury-ghc910-mhu-transitive-th-deps at Glasgow Haskell Compiler / GHC Commits: 1c80ba27 by Torsten Schmits at 2025-10-30T17:58:26+01:00 Load TH deps from home unit states of the modules that import them - - - - - 3 changed files: - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs Changes: ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -11,6 +11,7 @@ module GHC.Linker.Deps ( LinkDepsOpts (..) , LinkDeps (..) + , LibraryUnits (..) , getLinkDeps ) where @@ -83,10 +84,16 @@ data LinkDepsOpts = LinkDepsOpts data LinkDeps = LinkDeps { ldNeededLinkables :: [Linkable] , ldAllLinkables :: [Linkable] - , ldNeededUnits :: [UnitId] + , ldNeededUnits :: [LibraryUnits] , ldAllUnits :: UniqDSet UnitId } +data LibraryUnits + = LibraryUnits + { home_unit :: !UnitId + , library_unit :: !UnitId + } + -- | Find all the packages and linkables that a set of modules depends on -- -- Return the module and package dependencies for the needed modules. @@ -155,10 +162,10 @@ get_link_deps opts pls maybe_normal_osuf span mods = do link_mods = listToUDFM [(moduleName (mi_module (hm_iface m)), m) | m <- mmods] link_libs = - uniqDSetToList (unionManyUniqDSets (init_pkg_set : pkgs)) + eltsUDFM (foldl' plusUDFM emptyUDFM (init_pkg_set : pkgs)) pure $ LinkModules (LinkHomeModule <$> link_mods) : - (LinkLibrary <$> link_libs) + link_libs -- This code is used in `--make` mode to calculate the home package and unit dependencies -- for a set of modules. @@ -168,7 +175,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do -- 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 :: (UniqDFM UnitId LinkDep, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDFM UnitId LinkDep, 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 @@ -176,7 +183,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do 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 + in make_deps_loop (addToUDFM found_units uid (LinkLibrary LibraryUnits {library_unit = uid, home_unit = (ue_current_unit (ldUnitEnv opts))}), 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 @@ -185,7 +192,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do 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) + (init_pkg_set, all_deps) = make_deps_loop (emptyUDFM, Set.empty) $ map mkNk (filterOut isInteractiveModule mods) all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps] @@ -195,7 +202,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do let iface = hm_iface hmi case mi_hsc_src iface of HsBootFile -> throwProgramError opts $ link_boot_mod_error (mi_module iface) - _ -> pure (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface), hmi) + _ -> pure (listToUDFM [(u, LinkLibrary LibraryUnits {library_unit = u, home_unit = (moduleUnitId (mi_module iface))}) | u <- Set.toList $ dep_direct_pkgs (mi_deps iface)], hmi) Nothing -> throwProgramError opts $ text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid @@ -279,12 +286,13 @@ instance Outputable LinkModule where data LinkDep = LinkModules (UniqDFM ModuleName LinkModule) | - LinkLibrary UnitId + LinkLibrary LibraryUnits instance Outputable LinkDep where ppr = \case LinkModules mods -> text "modules:" <+> ppr (eltsUDFM mods) - LinkLibrary uid -> text "library:" <+> ppr uid + LinkLibrary (LibraryUnits {home_unit, library_unit}) -> + text "library:" <+> ppr library_unit <+> parens (ppr home_unit) data OneshotError = NoLocation Module @@ -337,7 +345,7 @@ oneshot_deps_loop opts (mod : mods) acc = do already_seen | Just (LinkModules mods) <- mod_dep = elemUDFM mod_name mods - | Just (LinkLibrary _) <- mod_dep + | Just (LinkLibrary {}) <- mod_dep = True | otherwise = False @@ -362,7 +370,7 @@ oneshot_deps_loop opts (mod : mods) acc = do | otherwise = add_library - add_library = pure (addToUDFM acc mod_unit_id (LinkLibrary mod_unit_id), []) + add_library = pure (addToUDFM acc mod_unit_id (LinkLibrary LibraryUnits {library_unit = mod_unit_id, home_unit}), []) add_module iface lmod = (addListToUDFM with_mod (direct_pkgs iface), new_deps iface) @@ -378,7 +386,7 @@ oneshot_deps_loop opts (mod : mods) acc = do | bytecode = [] | otherwise - = [(u, LinkLibrary u) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))] + = [(u, LinkLibrary LibraryUnits {library_unit = u, home_unit}) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))] new_deps iface | bytecode @@ -418,6 +426,7 @@ oneshot_deps_loop opts (mod : mods) acc = do text "due to use of Template Haskell" bytecode = ldUseByteCode opts + home_unit = homeUnitId (expectJust "oneshot_deps" mb_home) mb_home = ue_homeUnit (ldUnitEnv opts) link_boot_mod_error :: Module -> SDoc @@ -428,7 +437,7 @@ link_boot_mod_error mod = classify_deps :: LoaderState -> [LinkDep] -> - ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId]) + ([Linkable], [LinkModule], UniqDSet UnitId, [LibraryUnits]) classify_deps pls deps = (loaded_modules, needed_modules, all_packages, needed_packages) where @@ -436,13 +445,15 @@ classify_deps pls deps = partitionWith loaded_or_needed (concatMap eltsUDFM modules) needed_packages = - eltsUDFM (getUniqDSet all_packages `minusUDFM` pkgs_loaded pls) + eltsUDFM (packages `minusUDFM` pkgs_loaded pls) + + packages = listToUDFM [(library_unit p, p) | p <- packages_with_home_units] - all_packages = mkUniqDSet packages + all_packages = mkUniqDSet (map library_unit packages_with_home_units) - (modules, packages) = flip partitionWith deps $ \case + (modules, packages_with_home_units) = flip partitionWith deps $ \case LinkModules mods -> Left mods - LinkLibrary lib -> Right lib + LinkLibrary units -> Right units loaded_or_needed lm = maybe (Right lm) Left (loaded_linkable (mi_module (link_module_iface lm))) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -93,8 +93,9 @@ import Control.Monad import qualified Data.Set as Set import Data.Char (isSpace) +import Data.Foldable (for_) import Data.IORef -import Data.List (intercalate, isPrefixOf, nub, partition) +import Data.List (intercalate, isPrefixOf, nub, partition, sortOn) import Data.Maybe import Control.Concurrent.MVar import qualified Control.Monad.Catch as MC @@ -109,6 +110,7 @@ import System.Win32.Info (getSystemDirectory) #endif import GHC.Utils.Exception +import qualified Data.List.NonEmpty as NE -- Note [Linkers and loaders] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -173,7 +175,7 @@ emptyLoaderState = LoaderState -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet) + where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId Nothing [] [] [] emptyUniqDSet) extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings = @@ -325,9 +327,8 @@ reallyInitLoaderState interp hsc_env = do -- (a) initialise the C dynamic linker initObjLinker interp - -- (b) Load packages from the command-line (Note [preload packages]) - pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env) + pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp hsc_env [LibraryUnits {home_unit = u, library_unit = pre} | pre <- preloadUnits (homeUnitEnv_units env)] pls') (return pls0) (hsc_HUG hsc_env) -- steps (c), (d) and (e) loadCmdLineLibs' interp hsc_env pls @@ -855,7 +856,13 @@ dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do -- link all "loaded packages" so symbols in those can be resolved -- Note: We are loading packages with local scope, so to see the -- symbols in this link we must link all loaded packages again. - linkDynLib logger tmpfs dflags2 unit_env objs (loaded_pkg_uid <$> eltsUDFM pkgs_loaded) + do + let groupedLoadedPackageInfos = groupLoadedPackageInfosByParent pkgs_loaded + for_ groupedLoadedPackageInfos $ \(mParent, loaded_pkg_uids) -> do + let unit_env' = case mParent of + Nothing -> unit_env + Just parent -> ue_setActiveUnit parent unit_env + linkDynLib logger tmpfs dflags2 unit_env' objs loaded_pkg_uids -- if we got this far, extend the lifetime of the library file changeTempFilesLifetime tmpfs TFL_GhcSession [soFile] @@ -866,6 +873,19 @@ dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do where msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" + groupOn :: Eq k => (a -> k) -> [a] -> [NE.NonEmpty a] + groupOn f = NE.groupBy ((==) `on2` f) + -- redefine on so we avoid duplicate computation for most values. + where (.*.) `on2` f = \x -> let fx = f x in \y -> fx .*. f y + + groupLoadedPackageInfosByParent :: PkgsLoaded -> [(Maybe UnitId, [UnitId])] + groupLoadedPackageInfosByParent pkgs = + map (\l -> (loaded_pkg_parent (NE.head l), NE.toList $ NE.map loaded_pkg_uid l)) + $ groupOn loaded_pkg_parent + $ sortOn loaded_pkg_parent + $ eltsUDFM pkgs + + rmDupLinkables :: LinkableSet -- Already loaded -> [Linkable] -- New linkables -> (LinkableSet, -- New loaded set (including new ones) @@ -1075,36 +1095,39 @@ loadPackages interp hsc_env new_pkgs = do -- a lock. initLoaderState interp hsc_env modifyLoaderState_ interp $ \pls -> - loadPackages' interp hsc_env new_pkgs pls + loadPackages' interp hsc_env [LibraryUnits {home_unit = hscActiveUnitId hsc_env, library_unit} | library_unit <- new_pkgs] pls -loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState -loadPackages' interp hsc_env new_pks pls = do +loadPackages' :: Interp -> HscEnv -> [LibraryUnits] -> LoaderState -> IO LoaderState +loadPackages' interp hsc_env0 new_pks pls = do pkgs' <- link (pkgs_loaded pls) new_pks return $! pls { pkgs_loaded = pkgs' } where - link :: PkgsLoaded -> [UnitId] -> IO PkgsLoaded + link :: PkgsLoaded -> [LibraryUnits] -> IO PkgsLoaded link pkgs new_pkgs = foldM link_one pkgs new_pkgs - link_one pkgs new_pkg - | new_pkg `elemUDFM` pkgs -- Already linked + link_one pkgs (LibraryUnits {home_unit, library_unit}) + | library_unit `elemUDFM` pkgs -- Already linked = return pkgs - | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg + | Just pkg_cfg <- lookupUnitId (hsc_units (hscSetActiveUnitId home_unit hsc_env)) library_unit = do { let deps = unitDepends pkg_cfg -- Link dependents first - ; pkgs' <- link pkgs deps + ; pkgs' <- link pkgs [LibraryUnits {home_unit, library_unit} | library_unit <- deps] + -- Now link the package itself ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg | dep_pkg <- deps , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg) ] - ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) } + ; return (addToUDFM pkgs' library_unit (LoadedPkgInfo library_unit (Just home_unit) hs_cls extra_cls loaded_dlls trans_deps)) } | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS library_unit))) + where + hsc_env = hscSetActiveUnitId home_unit hsc_env0 loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL]) ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -192,6 +192,7 @@ type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo data LoadedPkgInfo = LoadedPkgInfo { loaded_pkg_uid :: !UnitId + , loaded_pkg_parent :: !(Maybe UnitId) , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL] @@ -200,8 +201,9 @@ data LoadedPkgInfo } instance Outputable LoadedPkgInfo where - ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) = - vcat [ppr uid + ppr (LoadedPkgInfo uid parent_uid hs_objs non_hs_objs _ trans_deps) = + vcat [ ppr uid + , ppr parent_uid , ppr hs_objs , ppr non_hs_objs , ppr trans_deps ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c80ba274d942b854db9fd8f029a5c28... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c80ba274d942b854db9fd8f029a5c28... You're receiving this email because of your account on gitlab.haskell.org.