Torsten Schmits pushed to branch wip/torsten.schmits/mercury-mhu-transitive-th-deps at Glasgow Haskell Compiler / GHC Commits: 8323b4b9 by Torsten Schmits at 2025-10-29T23:37:12+01:00 WIP: transitive TH deps with MHU - - - - - 14 changed files: - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - testsuite/tests/bytecode/T25090/all.T - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/DepA/A.hs - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/DepC/C.hs - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/Makefile - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/all.T - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/dep1/Dep1.hs - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/dep1/dep1.conf - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/mhu-transitive-th-deps-bc.stdout - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/mhu-transitive-th-deps-obj.stdout - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/unita - + testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/unitc Changes: ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -11,6 +11,7 @@ module GHC.Linker.Deps ( LinkDepsOpts (..) , LinkDeps (..) + , LibraryUnits (..) , getLinkDeps ) where @@ -84,10 +85,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. @@ -142,6 +149,7 @@ instance Outputable LinkExternalDetails where data LinkExternal = LinkExternal { le_details :: LinkExternalDetails, + le_unit_for_dbs :: !UnitId, le_module :: !Module } @@ -215,7 +223,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do -- entire set for oneshot mode. separate_home_deps = if ldOneShotMode opts - then pure ([], LinkExternal LinkAllDeps <$!> noninteractive) + then pure ([], LinkExternal LinkAllDeps (ue_currentUnit unit_env) <$!> noninteractive) else make_deps make_deps = do @@ -239,7 +247,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do Nothing -> let (ModNodeKeyWithUid (GWIB mod_name _) uid) = nk mod = Module (RealUnit (Definite uid)) mod_name - in make_deps_loop (LinkExternal LinkAllDeps mod : external, found_mods) nexts + in make_deps_loop (LinkExternal LinkAllDeps (ue_currentUnit unit_env) mod : external, 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 @@ -256,7 +264,8 @@ get_link_deps opts pls maybe_normal_osuf span mods = do case lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) of Just hmi -> do let iface = hm_iface hmi - pure (LinkExternal (LinkOnlyPackages iface) (mi_module iface), hmi) + mod = mi_module iface + pure (LinkExternal (LinkOnlyPackages iface) (moduleUnitId mod) mod, hmi) Nothing -> throwProgramError opts $ text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid @@ -319,12 +328,13 @@ get_link_deps opts pls maybe_normal_osuf span mods = do 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 = NoInterface !MissingInterfaceError @@ -397,7 +407,7 @@ external_deps_loop opts (job@LinkExternal {le_module = 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 @@ -429,7 +439,7 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do = add_library add_library = - pure (addToUDFM acc mod_unit_id (LinkLibrary mod_unit_id), [], Just "library") + pure (addToUDFM acc mod_unit_id (LinkLibrary (LibraryUnits {home_unit = le_unit_for_dbs, library_unit = mod_unit_id})), [], Just "library") add_module iface lmod action = with_deps with_mod iface True action @@ -437,7 +447,7 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do with_mod = alterUDFM (add_package_module lmod) acc mod_unit_id add_package_module lmod = \case - Just (LinkLibrary u) -> Just (LinkLibrary u) + Just (LinkLibrary lib) -> Just (LinkLibrary lib) Just (LinkModules old) -> Just (LinkModules (addToUDFM old mod_name lmod)) Nothing -> Just (LinkModules (unitUDFM mod_name lmod)) @@ -449,7 +459,7 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do local_deps iface = [ - LinkExternal LinkAllDeps (mkModule mod_unit m) + LinkExternal LinkAllDeps le_unit_for_dbs (mkModule mod_unit m) | (_, GWIB m _) <- Set.toList (dep_direct_mods (mi_deps iface)) ] @@ -458,9 +468,9 @@ external_deps_loop opts (job@LinkExternal {le_module = mod, ..} : mods) acc = do -- Otherwise, link all package deps as libraries. package_deps iface | package_bc - = ([], [LinkExternal LinkAllDeps usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface]) + = ([], [LinkExternal LinkAllDeps le_unit_for_dbs usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface]) | otherwise - = ([(u, LinkLibrary u) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))], []) + = ([(u, LinkLibrary (LibraryUnits {home_unit = le_unit_for_dbs, library_unit = u})) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))], []) load_reason = text "need to link module" <+> ppr mod <+> @@ -500,7 +510,7 @@ classify_deps :: LoaderState -> [HomeModInfo] -> [LinkDep] -> - ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId]) + ([Linkable], [LinkModule], UniqDSet UnitId, [LibraryUnits]) classify_deps pls hmis deps = (loaded_modules' ++ loaded_modules'', needed_modules' ++ needed_modules'', all_packages, needed_packages) where @@ -509,11 +519,13 @@ classify_deps pls hmis deps = partitionWith loaded_or_needed_module (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 ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -95,9 +95,10 @@ import Control.Monad import qualified Data.Set as Set import Data.Char (isSpace) +import Data.Foldable (for_) import Data.Functor ((<&>)) 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 @@ -177,7 +178,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 = @@ -329,9 +330,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 @@ -881,7 +881,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] @@ -892,6 +898,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) @@ -1102,36 +1121,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 ===================================== @@ -204,6 +204,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] @@ -212,8 +213,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 ] ===================================== testsuite/tests/bytecode/T25090/all.T ===================================== @@ -1,51 +1,51 @@ -# This test compiles the boot file separately from its source file, which causes -# a debug assertion warning. -# Since this appears to be intentional according to the Note [Loading your own hi-boot file], -# the warning is added to the expected stderr for debugged builds. -def test_T25090(name): - assert_warn_spec = {'stderr': 'T25090-debug.stderr'} - extra_specs = assert_warn_spec if name == 'T25090a' and compiler_debugged() else {} - return test(name, - [extra_files(['A.hs', 'B.hs', 'C.hs-boot', 'C.hs', 'D.hs']), - req_th, - js_skip, - use_specs(dict(stdout = 'T25090.stdout', **extra_specs)), - ], - makefile_test, - []) - -test_T25090('T25090a') -test_T25090('T25090b') - -def test_pkg(name, files = []): - test( - name, - [ - extra_files([ - 'PkgBytecode.hs', - 'Local.hs', - 'Dep.hs', - 'DepApi.hs', - 'Num.hs', - 'Num.hs-boot', - 'dep.conf', - 'prep.bash', - 'run.bash', - ] + files), - req_th, - js_skip, - windows_skip, - use_specs({'stdout': 'PkgBytecode.stdout'}), - ], - makefile_test, - [], - ) - -test_pkg('T25090_pkg') -test_pkg('T25090_pkg_empty') -test_pkg('T25090_pkg_nolib') -test_pkg('T25090_pkg_obj_code') -test_pkg('T25090_pkg_multi_unit', ['unit1', 'unit2']) -# TODO this doesn't work, because `locateLib` ignores static archives when the interpreter is dynamic, even though a -# comment says "search for .so libraries _first_" (rather than "only"). -# test_pkg('T25090_pkg_archive') +# # This test compiles the boot file separately from its source file, which causes +# # a debug assertion warning. +# # Since this appears to be intentional according to the Note [Loading your own hi-boot file], +# # the warning is added to the expected stderr for debugged builds. +# def test_T25090(name): +# assert_warn_spec = {'stderr': 'T25090-debug.stderr'} +# extra_specs = assert_warn_spec if name == 'T25090a' and compiler_debugged() else {} +# return test(name, +# [extra_files(['A.hs', 'B.hs', 'C.hs-boot', 'C.hs', 'D.hs']), +# req_th, +# js_skip, +# use_specs(dict(stdout = 'T25090.stdout', **extra_specs)), +# ], +# makefile_test, +# []) +# +# test_T25090('T25090a') +# test_T25090('T25090b') +# +# def test_pkg(name, files = []): +# test( +# name, +# [ +# extra_files([ +# 'PkgBytecode.hs', +# 'Local.hs', +# 'Dep.hs', +# 'DepApi.hs', +# 'Num.hs', +# 'Num.hs-boot', +# 'dep.conf', +# 'prep.bash', +# 'run.bash', +# ] + files), +# req_th, +# js_skip, +# windows_skip, +# use_specs({'stdout': 'PkgBytecode.stdout'}), +# ], +# makefile_test, +# [], +# ) +# +# test_pkg('T25090_pkg') +# test_pkg('T25090_pkg_empty') +# test_pkg('T25090_pkg_nolib') +# test_pkg('T25090_pkg_obj_code') +# test_pkg('T25090_pkg_multi_unit', ['unit1', 'unit2']) +# # TODO this doesn't work, because `locateLib` ignores static archives when the interpreter is dynamic, even though a +# # comment says "search for .so libraries _first_" (rather than "only"). +# # test_pkg('T25090_pkg_archive') ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/DepA/A.hs ===================================== @@ -0,0 +1,9 @@ + +module A (a) where + +import Dep1 (d) + +import Data.Text qualified as Text + +a :: Int +a = d ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/DepC/C.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + +module C where + +import Language.Haskell.TH.Syntax (lift) +import A (a) + +c :: Int +c = $(lift a) + ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/Makefile ===================================== @@ -0,0 +1,28 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +test-bc: prepare + '$(TEST_HC)' -fprefer-byte-code -fbyte-code-and-object-code -dynamic -unit @unita -unit @unitc + +test-obj: prepare + '$(TEST_HC)' -dynamic -unit @unita -unit @unitc + +# make test should not yield +# <no location info>: error: unknown unit: dep1-1 + +prepare: clean + '$(TEST_HC)' -c ./dep1/Dep1.hs -this-unit-id dep1-1 -dynamic -no-link -fPIC -osuf dyn_o -hisuf dyn_hi -o ./dep1/Dep1.dyn_o + '$(TEST_HC)' -shared -dynamic -fPIC -o ./dep1/libHSdep1-1-ghc9.10.1.so ./dep1/Dep1.dyn_o + '$(GHC_PKG)' --package-db dep1 recache + +clean: + $(RM) **/*.dyn_hi + $(RM) **/*.dyn_o + $(RM) **/*.hi + $(RM) **/*.o + $(RM) **/*.so + $(RM) dep1/package.cache + $(RM) dep1/package.cache.lock + $(RM) libHSdep1-1-ghc9.10.1.so + ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/all.T ===================================== @@ -0,0 +1,9 @@ +# We just want compilation to succeed here +test('mhu-transitive-th-deps-bc', + [ extra_files(["dep1", "DepA", "DepC", "unita","unitc"]) + ], makefile_test, ['test-bc']) + +test('mhu-transitive-th-deps-obj', + [ extra_files(["dep1", "DepA", "DepC", "unita","unitc"]) + ], makefile_test, ['test-obj']) + ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/dep1/Dep1.hs ===================================== @@ -0,0 +1,6 @@ + +module Dep1 (d) where + +d :: Int +d = 42 + ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/dep1/dep1.conf ===================================== @@ -0,0 +1,9 @@ +name: dep1 +version: 1 +visibility: public +id: dep1-1 +exposed: False +exposed-modules: Dep1 +import-dirs: ${pkgroot}/dep1 +library-dirs: ${pkgroot}/dep1 +hs-libraries: HSdep1-1 ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/mhu-transitive-th-deps-bc.stdout ===================================== @@ -0,0 +1,2 @@ +[1 of 2] Compiling A ( DepA/A.hs, DepA/A.o, interpreted )[unita] +[2 of 2] Compiling C ( DepC/C.hs, DepC/C.o, interpreted )[unitc] ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/mhu-transitive-th-deps-obj.stdout ===================================== @@ -0,0 +1,2 @@ +[1 of 2] Compiling A ( DepA/A.hs, DepA/A.o )[unita] +[2 of 2] Compiling C ( DepC/C.hs, DepC/C.o )[unitc] ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/unita ===================================== @@ -0,0 +1 @@ +-iDepA -this-unit-id unita -hide-all-packages -package base -package text -package-db dep1 -package dep1 A ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-transitive-th-deps/unitc ===================================== @@ -0,0 +1 @@ +-iDepC -this-unit-id unitc -hide-all-packages -package-id unita -package base -package template-haskell C View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8323b4b98a498628021d037253034f64... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8323b4b98a498628021d037253034f64... You're receiving this email because of your account on gitlab.haskell.org.