[Git][ghc/ghc][wip/torsten.schmits/cross-package-objects] load modules recursively
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Thu Jun 6 18:08:04 UTC 2024
Torsten Schmits pushed to branch wip/torsten.schmits/cross-package-objects at Glasgow Haskell Compiler / GHC
Commits:
32fba601 by Torsten Schmits at 2024-06-06T20:07:54+02:00
load modules recursively
- - - - -
6 changed files:
- compiler/GHC/Linker/Loader.hs
- + testsuite/tests/th/cross-package/CrossDepApi.hs
- testsuite/tests/th/cross-package/CrossLocal.hs
- testsuite/tests/th/cross-package/all.T
- testsuite/tests/th/cross-package/dep.conf
- testsuite/tests/th/cross-package/prep.bash
Changes:
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -111,13 +111,11 @@ import System.Win32.Info (getSystemDirectory)
import GHC.Utils.Exception
import GHC.Unit.Module.ModIface (ModIface, ModIface_ (..))
-import GHC.Unit.Module.ModDetails (ModDetails (..))
import GHC.Unit.Finder (FindResult(..), findImportedModule)
-import qualified GHC.Data.Maybe as ME
import GHC.Unit.Module.ModSummary (ModSummary(..))
import GHC.Unit.Module.WholeCoreBindings (WholeCoreBindings(..))
import GHC.Types.PkgQual (PkgQual(OtherPkg))
-import Control.Monad.Trans.State.Strict (StateT(..))
+import Control.Monad.Trans.State.Strict (StateT(..), state)
import GHC.Utils.Misc (modificationTimeIfExists)
-- Note [Linkers and loaders]
@@ -239,7 +237,10 @@ loadDependencies interp hsc_env pls hydrate span needed_mods = do
-- Find what packages and linkables are required
deps <- getLinkDeps opts interp pls span needed_mods
- (pls1, links_needed) <- loadIfacesByteCode interp hsc_env hydrate pls (ldNeededLinkables deps)
+ let s0 = LIBC {libc_loader = pls, libc_seen = emptyUniqDSet}
+ needed = ldNeededLinkables deps
+ load_bc = loadIfacesByteCode interp hsc_env hydrate needed
+ (links_needed, LIBC {libc_loader = pls1}) <- runStateT load_bc s0
let this_pkgs_needed = ldNeededUnits deps
@@ -725,31 +726,43 @@ loadByteCode loc iface mod_sum = do
return (Just (LM if_date this_mod [CoreBindings fi]))
_ -> pure Nothing
+data LIBC =
+ LIBC {
+ libc_loader :: LoaderState,
+ libc_seen :: UniqDSet Module
+ }
+
loadIfaceByteCode ::
Interp ->
HscEnv ->
(ModIface -> Linkable -> IO Linkable) ->
- LoaderState ->
Module ->
- IO ([Linkable], LoaderState)
-loadIfaceByteCode interp hsc_env hydrate pls mod = do
- iface <- run_ifg $ loadSysInterface (text "blarkh") mod
- imp_mod <- findImportedModule hsc_env (moduleName mod) (OtherPkg (moduleUnitId mod))
+ StateT LIBC IO [Linkable]
+loadIfaceByteCode interp hsc_env hydrate mod = do
+ iface <- liftIO $ run_ifg $ loadSysInterface (text "blarkh") mod
+ imp_mod <- liftIO $ findImportedModule hsc_env (moduleName mod) (OtherPkg (moduleUnitId mod))
dbg "loadIfaceByteCode" [
("mod", ppr mod),
("iface", ppr (mi_module iface))
]
case imp_mod of
(Found loc _) -> do
- summ <- mod_summary mod loc iface
- l <- loadByteCode loc iface summ
- lh <- maybeToList <$> traverse (hydrate iface) l
- dbg "loadIfaceByteCode found" [("hi", text (ml_hi_file loc)), ("loaded", ppr lh)]
- pls1 <- dynLinkBCOs interp pls lh
- pure (lh, pls1)
+ summ <- liftIO $ mod_summary mod loc iface
+ l <- liftIO $ loadByteCode loc iface summ
+ lh <- liftIO $ maybeToList <$> traverse (hydrate iface) l
+ lh1 <- loadIfacesByteCode interp hsc_env hydrate lh
+ dbg "loadIfaceByteCode found" [
+ ("hi", text (ml_hi_file loc)),
+ ("loaded", ppr lh),
+ ("loaded recursive", ppr lh1)
+ ]
+ StateT $ \ s -> do
+ pls <- dynLinkBCOs interp (libc_loader s) lh1
+ pure ((), s {libc_loader = pls})
+ pure lh1
fr -> do
dbg "loadIfaceByteCode not found" [("impo", debugFr fr)]
- pure ([], pls)
+ pure []
where
run_ifg :: forall a . IfG a -> IO a
run_ifg = initIfaceCheck (text "loader") hsc_env
@@ -770,30 +783,34 @@ loadIfacesByteCode ::
Interp ->
HscEnv ->
(ModIface -> Linkable -> IO Linkable) ->
- LoaderState ->
[Linkable] ->
- IO (LoaderState, [Linkable])
-loadIfacesByteCode interp hsc_env hydrate pls lnks = do
- (lnks1, pls1) <- runStateT (traverse one mods) pls
- pure (pls1, mconcat (lnks : lnks1))
+ StateT LIBC IO [Linkable]
+loadIfacesByteCode interp hsc_env hydrate lnks = do
+ all <- state (filter_deps all_deps)
+ lnks1 <- traverse one (uniqDSetToList all)
+ pure (mconcat (lnks : lnks1))
where
- one :: Module -> StateT LoaderState IO [Linkable]
- one a = StateT (\ s -> loadIfaceByteCode interp hsc_env hydrate s a)
- mods :: [Module]
- mods = mconcat (bco_deps . linkableUnlinked <$> lnks)
+ one :: Module -> StateT LIBC IO [Linkable]
+ one = loadIfaceByteCode interp hsc_env hydrate
+
+ all_deps = linkables_deps (concatMap linkableUnlinked lnks)
+
+ linkables_deps = unionManyUniqDSets . fmap linkable_deps
+
+ linkable_deps = \case
+ BCOs cbc _ ->
+ mapUniqDSet nameModule $ filterUniqDSet loadable (bco_free_names cbc)
+ LoadedBCOs l -> linkables_deps l
+ _ -> emptyUniqDSet
+
+ loadable n = isExternalName n && not (isWiredInName n) && not (moduleUnitId (nameModule n) `elem` wiredInUnitIds)
+
bco_free_names cbc =
- uniqDSetToList $
foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet (bc_bcos cbc)
- bco_deps = concatMap $ \case
- BCOs cbc _ ->
- [
- nameModule n |
- n <- bco_free_names cbc,
- isExternalName n,
- not (isWiredInName n)
- ]
- _ -> []
+ filter_deps new s at LIBC {libc_seen} =
+ (minusUniqDSet new libc_seen, s {libc_seen = unionUniqDSets new libc_seen})
+
loadDecls ::
Interp ->
=====================================
testsuite/tests/th/cross-package/CrossDepApi.hs
=====================================
@@ -0,0 +1,7 @@
+module CrossDepApi (A (A), dep) where
+
+import CrossDep (A (A))
+import qualified CrossDep
+
+dep :: A
+dep = CrossDep.dep
=====================================
testsuite/tests/th/cross-package/CrossLocal.hs
=====================================
@@ -5,7 +5,7 @@ module CrossLocal where
import Language.Haskell.TH (ExpQ)
import Language.Haskell.TH.Syntax (lift)
-- just to be sure that the file isn't accidentally picked up locally
-import "dep" CrossDep (dep, A (A))
+import "dep" CrossDepApi (dep, A (A))
import CrossNum (num)
splc :: ExpQ
=====================================
testsuite/tests/th/cross-package/all.T
=====================================
@@ -2,7 +2,7 @@ test(
'CrossPackage',
[
pre_cmd('$MAKE -s --no-print-directory CrossPackage'),
- extra_files(['Cross.hs', 'CrossLocal.hs', 'CrossDep.hs', 'CrossNum.hs', 'prep.bash', 'dep.conf']),
+ extra_files(['Cross.hs', 'CrossLocal.hs', 'CrossDep.hs', 'CrossDepApi.hs', 'CrossNum.hs', 'prep.bash', 'dep.conf']),
# ignore_stderr,
],
# multimod_compile_and_run,
=====================================
testsuite/tests/th/cross-package/dep.conf
=====================================
@@ -3,7 +3,7 @@ version: 1.0
id: dep-1.0
key: dep-1.0
exposed: True
-exposed-modules: CrossDep
+exposed-modules: CrossDep CrossDepApi
import-dirs: ${pkgroot}/dep
library-dirs: ${pkgroot}/dep
hs-libraries: HSdep-1.0
=====================================
testsuite/tests/th/cross-package/prep.bash
=====================================
@@ -22,11 +22,13 @@ ghc()
}
mkdir -p "$lib" "$db"
-cp CrossDep.hs dep.conf "$lib/"
+mv CrossDep.hs CrossDepApi.hs dep.conf "$lib/"
ghc_pkg recache
-ghc "-package-db ${db at Q} -hidir ${lib at Q} -O0 -this-unit-id dep-1.0 -fbyte-code-and-object-code -c ${lib at Q}/CrossDep.hs"
-$AR cqs "${lib}/libHSdep-1.0.a" "${lib}/CrossDep.o"
+ghc "-package-db ${db at Q} -hidir ${lib at Q} -O0 -this-unit-id dep-1.0 -fbyte-code-and-object-code -c ${lib at Q}/CrossDep.hs ${lib at Q}/CrossDepApi.hs"
+$AR cqs "${lib}/libHSdep-1.0.a" "${lib}/CrossDep.o" "${lib}/CrossDepApi.o"
ghc_pkg -v0 register "${lib at Q}/dep.conf"
+
+tree >&2
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32fba6015863cba2538d8a995fe63bd3563ae5cb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32fba6015863cba2538d8a995fe63bd3563ae5cb
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/20240606/fb4e48a4/attachment-0001.html>
More information about the ghc-commits
mailing list