[Git][ghc/ghc][wip/torsten.schmits/package-deps-bytecode-squashed] Link interface bytecode from package DBs if possible
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Mon Sep 30 17:58:51 UTC 2024
Torsten Schmits pushed to branch wip/torsten.schmits/package-deps-bytecode-squashed at Glasgow Haskell Compiler / GHC
Commits:
aac0c1be by Torsten Schmits at 2024-09-30T19:58:37+02:00
Link interface bytecode from package DBs if possible
Part of #25090.
MR !?????
When splices are executed with `-fprefer-byte-code`, the loader will
compile Core bindings to bytecode if those are present in interfaces of
module dependencies.
So far, this only applied to local modules (i.e. home modules in make
mode and non-package deps in oneshot mode).
This patch extends support to interfaces loaded from a package DB.
In `getLinkDeps`, the dependencies chosen for recursion were restricted
to `dep_direct_mods`, which has been changed to include `mi_usages`.
In order to unify treatment of the different link variants across
make/oneshot mode, the algorithm's intermediate results have been
abstracted into the data types `LinkDep` and `LinkModule`.
At the moment, following package deps is only implemented for oneshot
mode.
- - - - -
19 changed files:
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- + testsuite/tests/bytecode/T25090/Dep.hs
- + testsuite/tests/bytecode/T25090/DepApi.hs
- + testsuite/tests/bytecode/T25090/Local.hs
- testsuite/tests/bytecode/T25090/Makefile
- + testsuite/tests/bytecode/T25090/Num.hs
- + testsuite/tests/bytecode/T25090/Num.hs-boot
- + testsuite/tests/bytecode/T25090/PkgBytecode.hs
- + testsuite/tests/bytecode/T25090/PkgBytecode.stdout
- testsuite/tests/bytecode/T25090/all.T
- + testsuite/tests/bytecode/T25090/dep.conf
- + testsuite/tests/bytecode/T25090/prep.bash
- + testsuite/tests/bytecode/T25090/run.bash
- + testsuite/tests/bytecode/T25090/unit1
- + testsuite/tests/bytecode/T25090/unit2
Changes:
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -672,7 +672,11 @@ dontLeakTheHUG thing_inside = do
in
hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets"
, hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph"
- , hsc_IC = panic "cleanTopEnv: hsc_IC"
+ -- TODO this is needed for bytecode compilation of package deps
+ -- only. local EPS modules work fine.
+ -- Also it appears to work when the local modules use multiple
+ -- home units?!?!?
+ -- , hsc_IC = panic "cleanTopEnv: hsc_IC"
, hsc_type_env_vars = case maybe_type_vars of
Just vars -> vars
Nothing -> panic "cleanTopEnv: hsc_type_env_vars"
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
module GHC.Linker.Deps
( LinkDepsOpts (..)
@@ -28,6 +29,7 @@ import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM
import GHC.Utils.Outputable
+import qualified GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Error
@@ -47,9 +49,11 @@ import GHC.Utils.Misc
import GHC.Unit.Home
import GHC.Data.Maybe
-import Control.Monad
import Control.Applicative
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
+import Data.Foldable (traverse_)
import qualified Data.Set as Set
import qualified Data.Map as M
import Data.List (isSuffixOf)
@@ -68,15 +72,16 @@ data LinkDepsOpts = LinkDepsOpts
, ldWays :: !Ways -- ^ Enabled ways
, ldFinderCache :: !FinderCache
, ldFinderOpts :: !FinderOpts
- , ldLoadIface :: !(SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface))
- , ldLoadByteCode :: !(Module -> IO (Maybe Linkable))
+ , ldLoadIface :: !(SDoc -> Module -> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation)))
+ , ldLoadByteCode :: !(Module -> IO (Maybe (IO Linkable)))
+ , ldDebugTrace :: !(SDoc -> IO ())
}
data LinkDeps = LinkDeps
{ ldNeededLinkables :: [Linkable]
, ldAllLinkables :: [Linkable]
- , ldUnits :: [UnitId]
- , ldNeededUnits :: UniqDSet UnitId
+ , ldNeededUnits :: [UnitId]
+ , ldAllUnits :: UniqDSet UnitId
}
-- | Find all the packages and linkables that a set of modules depends on
@@ -102,7 +107,14 @@ getLinkDeps opts interp pls span mods = do
get_link_deps opts pls maybe_normal_osuf span mods
-
+-- | Compute the linkables for the given module set's dependencies.
+--
+-- Home modules in make mode are treated separately in a preprocessing step,
+-- then all the remaining external deps are processed for both modes.
+-- If bytecode is available, transitive external deps are included, otherwise
+-- the module's library is linked and processing stops.
+--
+-- The results are split into sets of needed/loaded modules/packages.
get_link_deps
:: LinkDepsOpts
-> LoaderState
@@ -111,46 +123,40 @@ get_link_deps
-> [Module]
-> IO LinkDeps
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)
- (mods_s, pkgs_s) <-
- -- Why two code paths here? There is a significant amount of repeated work
- -- performed calculating transitive dependencies
- -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests)
- if ldOneShotMode opts
- 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))
-
- let
- -- 2. Exclude ones already linked
- -- Main reason: avoid findModule calls in get_linkable
- (mods_needed, links_got) = partitionWith split_mods mods_s
- pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls
-
- split_mods mod =
- let is_linked = lookupModuleEnv (objs_loaded pls) mod
- <|> lookupModuleEnv (bcos_loaded pls) mod
- in case is_linked of
- Just linkable -> Right linkable
- Nothing -> Left mod
-
- -- 3. For each dependent module, find its linkable
- -- This will either be in the HPT or (in the case of one-shot
- -- compilation) we may need to use maybe_getFileLinkable
- lnks_needed <- mapM (get_linkable (ldObjSuffix opts)) mods_needed
-
- return $ LinkDeps
- { ldNeededLinkables = lnks_needed
- , ldAllLinkables = links_got ++ lnks_needed
- , ldUnits = pkgs_needed
- , ldNeededUnits = pkgs_s
- }
+ (link_deps_home, module_deps_external) <- separate_home_deps
+ link_deps_external <- external_deps opts module_deps_external
+ let (loaded_modules, needed_modules, ldAllUnits, ldNeededUnits) =
+ classify_deps pls (link_deps_home ++ link_deps_external)
+ ldNeededLinkables <- mapM module_linkable needed_modules
+ pure LinkDeps {
+ ldNeededLinkables,
+ ldAllLinkables = loaded_modules ++ ldNeededLinkables,
+ ldNeededUnits,
+ ldAllUnits
+ }
where
mod_graph = ldModuleGraph opts
unit_env = ldUnitEnv opts
+ noninteractive = filterOut isInteractiveModule mods
+
+ -- | Preprocess the dependencies in make mode to remove all home modules,
+ -- since the transitive dependency closure is already cached for those in
+ -- the HUG (see MultiLayerModulesTH_* tests for the performance impact).
+ --
+ -- Returns the remaining, external, dependencies on the right, which is the
+ -- entire set for oneshot mode.
+ separate_home_deps =
+ if ldOneShotMode opts
+ then pure ([], noninteractive)
+ else make_deps
+
+ make_deps = do
+ (dep_ext, mmods) <- unzip <$> mapM get_mod_info all_home_mods
+ let
+ link_mods =
+ listToUDFM [(moduleName (mi_module (hm_iface m)), m) | m <- mmods]
+ ext = uniqDSetToList (unionManyUniqDSets (init_ext : dep_ext))
+ pure ([LinkModules (LinkHomeModule <$> link_mods)], ext)
-- This code is used in `--make` mode to calculate the home package and unit dependencies
-- for a set of modules.
@@ -160,9 +166,9 @@ 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 :: (UniqDSet Module, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet Module, Set.Set NodeKey)
make_deps_loop found [] = found
- make_deps_loop found@(found_units, found_mods) (nk:nexts)
+ make_deps_loop found@(external, found_mods) (nk:nexts)
| NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts
| otherwise =
case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of
@@ -171,85 +177,26 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
-- 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) <- Set.toList trans_deps]
- in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
+ in make_deps_loop (external, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
Nothing ->
- let (ModNodeKeyWithUid _ uid) = nk
- in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts
+ let (ModNodeKeyWithUid (GWIB mod_name _) uid) = nk
+ in make_deps_loop (addOneToUniqDSet external (Module (RealUnit (Definite uid)) mod_name), found_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_ext, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk noninteractive
all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList 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
+ Just hmi -> do
+ let iface = hm_iface hmi
+ case mi_hsc_src iface of
+ HsBootFile -> throwProgramError opts $ link_boot_mod_error (mi_module iface)
+ _ -> pure (mkUniqDSet $ [usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface], hmi)
Nothing -> throwProgramError opts $
text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid
-
- -- This code is used in one-shot mode to traverse downwards through the HPT
- -- to find all link dependencies.
- -- The ModIface contains the transitive closure of the module dependencies
- -- within the current package, *except* for boot modules: if we encounter
- -- a boot module, we have to find its real interface and discover the
- -- dependencies of that. Hence we need to traverse the dependency
- -- tree recursively. See bug #936, testcase ghci/prog007.
- follow_deps :: [Module] -- modules to follow
- -> UniqDSet Module -- accum. module dependencies
- -> UniqDSet UnitId -- accum. package dependencies
- -> IO ([Module], UniqDSet UnitId) -- result
- follow_deps [] acc_mods acc_pkgs
- = return (uniqDSetToList acc_mods, acc_pkgs)
- follow_deps (mod:mods) acc_mods acc_pkgs
- = do
- mb_iface <- ldLoadIface opts msg mod
- iface <- case mb_iface of
- Failed err -> throwProgramError opts $
- missingInterfaceErrorDiagnostic (ldMsgOpts opts) err
- Succeeded iface -> return iface
-
- when (mi_boot iface == IsBoot) $ link_boot_mod_error mod
-
- let
- pkg = moduleUnit mod
- deps = mi_deps iface
-
- pkg_deps = dep_direct_pkgs deps
- (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $
- \case
- (_, GWIB m IsBoot) -> Left m
- (_, GWIB m NotBoot) -> Right m
-
- mod_deps' = case ue_homeUnit unit_env of
- Nothing -> []
- Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps))
- acc_mods' = case ue_homeUnit unit_env of
- Nothing -> acc_mods
- Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps)
- acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)
-
- case ue_homeUnit unit_env of
- Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods)
- acc_mods' acc_pkgs'
- _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))
- where
- msg = text "need to link module" <+> ppr mod <+>
- text "due to use of Template Haskell"
-
-
-
- link_boot_mod_error :: Module -> IO a
- 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 " <>
@@ -258,6 +205,20 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
while_linking_expr = text "while linking an interpreted expression"
+ -- | Extract the 'Linkable's for unlinked modules from the intermediate
+ -- results.
+ module_linkable = \case
+ LinkHomeModule hmi ->
+ adjust_linkable (expectJust "getLinkDeps" (homeModLinkable hmi))
+
+ LinkObjectModule iface loc -> do
+ let mod = mi_module iface
+ findObjectLinkableMaybe mod loc >>= \case
+ Nothing -> no_obj mod
+ Just lnk -> adjust_linkable lnk
+
+ LinkByteCodeModule _ load_bytecode ->
+ load_bytecode
-- See Note [Using Byte Code rather than Object Code for Template Haskell]
homeModLinkable :: HomeModInfo -> Maybe Linkable
@@ -266,57 +227,257 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
then homeModInfoByteCode hmi <|> homeModInfoObject hmi
else homeModInfoObject hmi <|> homeModInfoByteCode hmi
- get_linkable osuf mod -- A home-package module
- | Just mod_info <- lookupHugByModule mod (ue_home_unit_graph unit_env)
- = adjust_linkable (expectJust "getLinkDeps" (homeModLinkable mod_info))
- | otherwise
- = do -- It's not in the HPT because we are in one shot mode,
- -- so use the Finder to get a ModLocation...
- case ue_homeUnit unit_env of
- Nothing -> no_obj mod
- Just home_unit -> do
- from_bc <- ldLoadByteCode opts mod
- maybe (fallback_no_bytecode home_unit mod) pure from_bc
- where
-
- fallback_no_bytecode home_unit mod = do
- let fc = ldFinderCache opts
- let fopts = ldFinderOpts opts
- mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
- case mb_stuff of
- Found loc _ -> do
- mb_lnk <- findObjectLinkableMaybe mod loc
- case mb_lnk of
- Nothing -> no_obj mod
- Just lnk -> adjust_linkable lnk
- _ -> no_obj (moduleName mod)
-
- adjust_linkable lnk
- | Just new_osuf <- maybe_normal_osuf = do
- new_parts <- mapM (adjust_part new_osuf)
- (linkableParts lnk)
- return lnk{ linkableParts=new_parts }
- | otherwise =
- return lnk
-
- adjust_part new_osuf part = case part of
- DotO file ModuleObject -> do
- massert (osuf `isSuffixOf` file)
- let file_base = fromJust (stripExtension osuf file)
- new_file = file_base <.> new_osuf
- ok <- doesFileExist new_file
- if (not ok)
- then dieWith opts span $
- text "cannot find object file "
- <> quotes (text new_file) $$ while_linking_expr
- else return (DotO new_file ModuleObject)
- DotO file ForeignObject -> pure (DotO file ForeignObject)
- DotA fp -> panic ("adjust_ul DotA " ++ show fp)
- DotDLL fp -> panic ("adjust_ul DotDLL " ++ show fp)
- BCOs {} -> pure part
- LazyBCOs{} -> pure part
- CoreBindings WholeCoreBindings {wcb_module} ->
- pprPanic "Unhydrated core bindings" (ppr wcb_module)
+ adjust_linkable lnk
+ | Just new_osuf <- maybe_normal_osuf = do
+ new_uls <- mapM (adjust_part (ldObjSuffix opts) new_osuf)
+ (linkableParts lnk)
+ return lnk {linkableParts = new_uls}
+ | otherwise =
+ return lnk
+
+ adjust_part osuf new_osuf part = case part of
+ DotO file ModuleObject -> do
+ massert (osuf `isSuffixOf` file)
+ let file_base = fromJust (stripExtension osuf file)
+ new_file = file_base <.> new_osuf
+ ok <- doesFileExist new_file
+ if (not ok)
+ then dieWith opts span $
+ text "cannot find object file "
+ <> quotes (text new_file) $$ while_linking_expr
+ else return (DotO new_file ModuleObject)
+ DotO file ForeignObject -> pure (DotO file ForeignObject)
+ DotA fp -> panic ("adjust_part DotA " ++ show fp)
+ DotDLL fp -> panic ("adjust_part DotDLL " ++ show fp)
+ BCOs {} -> pure part
+ LazyBCOs{} -> pure part
+ CoreBindings WholeCoreBindings {wcb_module} ->
+ pprPanic "Unhydrated core bindings" (ppr wcb_module)
+
+data LinkModule =
+ LinkHomeModule !HomeModInfo
+ |
+ LinkObjectModule !ModIface !ModLocation
+ |
+ LinkByteCodeModule !ModIface !(IO Linkable)
+
+link_module_iface :: LinkModule -> ModIface
+link_module_iface = \case
+ LinkHomeModule hmi -> hm_iface hmi
+ LinkObjectModule iface _ -> iface
+ LinkByteCodeModule iface _ -> iface
+
+instance Outputable LinkModule where
+ ppr = \case
+ LinkHomeModule hmi -> ppr (mi_module (hm_iface hmi)) <+> brackets (text "HMI")
+ LinkObjectModule iface _ -> ppr (mi_module iface)
+ LinkByteCodeModule iface _ -> ppr (mi_module iface) <+> brackets (text "BC")
+
+data LinkDep =
+ LinkModules !(UniqDFM ModuleName LinkModule)
+ |
+ LinkLibrary !UnitId
+
+instance Outputable LinkDep where
+ ppr = \case
+ LinkModules mods -> text "modules:" <+> ppr (eltsUDFM mods)
+ LinkLibrary uid -> text "library:" <+> ppr uid
+
+data OneshotError =
+ NoLocation !Module
+ |
+ NoInterface !MissingInterfaceError
+ |
+ LinkBootModule !Module
+
+-- Compute the transitive dependency closure of the given modules.
+--
+-- Used for all oneshot mode dependencies and for external dependencies of home
+-- modules in make mode.
+--
+-- TODO is the following still relevant?
+-- The ModIface contains the transitive closure of the module dependencies
+-- within the current package, *except* for boot modules: if we encounter
+-- a boot module, we have to find its real interface and discover the
+-- dependencies of that. Hence we need to traverse the dependency
+-- tree recursively. See bug #936, testcase ghci/prog007.
+external_deps ::
+ LinkDepsOpts ->
+ -- | Modules whose imports to follow
+ [Module] ->
+ IO [LinkDep]
+external_deps opts mods =
+ runExceptT (external_deps_loop opts mods emptyUDFM) >>= \case
+ Right a -> pure (eltsUDFM a)
+ Left err -> throwProgramError opts (message err)
+ where
+ message = \case
+ NoLocation mod ->
+ pprPanic "found iface but no location" (ppr mod)
+ NoInterface err ->
+ missingInterfaceErrorDiagnostic (ldMsgOpts opts) err
+ LinkBootModule mod ->
+ link_boot_mod_error mod
+
+external_deps_loop ::
+ LinkDepsOpts ->
+ [Module] ->
+ UniqDFM UnitId LinkDep ->
+ ExceptT OneshotError IO (UniqDFM UnitId LinkDep)
+external_deps_loop _ [] acc =
+ pure acc
+external_deps_loop opts (mod : mods) acc = do
+ (new_acc, new_mods, action) <- process_module
+ traverse_ debug_log action
+ external_deps_loop opts (new_mods ++ mods) new_acc
+ where
+ debug_log action =
+ liftIO $ ldDebugTrace opts $
+ text "TH dep" <+> ppr mod <+> brackets (sep [
+ if is_home then text "home" else Outputable.empty,
+ text action
+ ])
+
+ -- | Decide how this module needs to be processed.
+ -- We only need an interface if we want to load bytecode or if we have to
+ -- link an object file (which happens for home unit modules, since those
+ -- have no libraries).
+ process_module
+ | already_seen = pure (acc, [], Nothing)
+ | is_home || prefer_bytecode = try_iface
+ | otherwise = add_library
+
+ -- | Check whether the current module was processed before.
+ -- Since the accumulator is keyed by unit ID, we have to perform two
+ -- lookups.
+ -- If another module from this module's unit has been determined to be
+ -- linked as a library previously, we skip this module, assuming that no
+ -- bytecode is available for the entire package.
+ already_seen
+ | Just (LinkModules mods) <- mod_dep
+ = elemUDFM mod_name mods
+ | Just (LinkLibrary _) <- mod_dep
+ = True
+ | otherwise
+ = False
+
+ -- | Load the iface and attempt to get bytecode from Core bindings.
+ try_iface =
+ liftIO (ldLoadIface opts load_reason mod) >>= \case
+ Failed err -> throwE (NoInterface err)
+ Succeeded (iface, loc) -> do
+ mb_load_bc <- liftIO (ldLoadByteCode opts (mi_module iface))
+ with_iface loc iface mb_load_bc
+
+ -- | Decide how to link this module.
+ -- If bytecode or an object file is available, use those in that order.
+ -- Otherwise fall back to linking a library.
+ with_iface loc iface mb_load_bc
+ | IsBoot <- mi_boot iface
+ = throwE (LinkBootModule mod)
+
+ | prefer_bytecode
+ , Just load_bc <- mb_load_bc
+ = pure (add_module iface (LinkByteCodeModule iface load_bc) "bytecode")
+
+ | is_home
+ = pure (add_module iface (LinkObjectModule iface loc) "object")
+
+ | otherwise
+ = add_library
+
+ add_library =
+ pure (addToUDFM acc mod_unit_id (LinkLibrary mod_unit_id), [], Just "library")
+
+ add_module iface lmod action =
+ (addListToUDFM with_mod (direct_pkgs iface), new_deps iface, Just action)
+ where
+ with_mod = alterUDFM (add_package_module lmod) acc mod_unit_id
+
+ add_package_module lmod = \case
+ Just (LinkLibrary u) -> Just (LinkLibrary u)
+ Just (LinkModules old) -> Just (LinkModules (addToUDFM old mod_name lmod))
+ Nothing -> Just (LinkModules (unitUDFM mod_name lmod))
+
+ direct_pkgs iface
+ | prefer_bytecode
+ = []
+ | otherwise
+ = [(u, LinkLibrary u) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))]
+
+ new_deps iface
+ | prefer_bytecode
+ -- TODO How can we better determine the external deps?
+ -- OTOH, we probably don't want to link unused dependencies anyway.
+ = [usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface] ++ local
+ | is_home
+ = local
+ | otherwise
+ = []
+ where
+ local =
+ [
+ mkModule mod_unit m
+ -- TODO Somehow this just works, no idea what the deal was in the
+ -- old code with boot modules.
+ | (_, GWIB m _) <- Set.toList (dep_direct_mods (mi_deps iface))
+ ]
+
+ is_home
+ | Just home <- mb_home
+ = homeUnitAsUnit home == mod_unit
+ | otherwise
+ = False
+
+ mod_dep = lookupUDFM acc mod_unit_id
+ mod_name = moduleName mod
+ mod_unit_id = moduleUnitId mod
+ mod_unit = moduleUnit mod
+ load_reason =
+ text "need to link module" <+> ppr mod <+>
+ text "due to use of Template Haskell"
+
+ prefer_bytecode = ldUseByteCode opts
+ mb_home = ue_homeUnit (ldUnitEnv opts)
+
+link_boot_mod_error :: Module -> SDoc
+link_boot_mod_error mod =
+ text "module" <+> ppr mod <+>
+ text "cannot be linked; it is only available as a boot module"
+
+-- | Split link dependencies into the sets of modules and packages that have
+-- been linked previously and those that need to be linked now by checking for
+-- their presence in the 'LoaderState':
+--
+-- - For module dependencies, in the sets of loaded objects and BCOs
+-- ('objs_loaded' and 'bcos_loaded')
+-- - For package dependencies, in the set of loaded packages ('pkgs_loaded')
+classify_deps ::
+ LoaderState ->
+ [LinkDep] ->
+ ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId])
+classify_deps pls deps =
+ (loaded_modules, needed_modules, all_packages, needed_packages)
+ where
+ (loaded_modules, needed_modules) =
+ partitionWith loaded_or_needed_module (concatMap eltsUDFM modules)
+
+ needed_packages =
+ eltsUDFM (getUniqDSet all_packages `minusUDFM` pkgs_loaded pls)
+
+ all_packages = mkUniqDSet packages
+
+ (modules, packages) = flip partitionWith deps $ \case
+ LinkModules mods -> Left mods
+ LinkLibrary lib -> Right lib
+
+ loaded_or_needed_module lm =
+ maybe (Right lm) Left (loaded_module (mi_module (link_module_iface lm)))
+
+ loaded_module mod =
+ lookupModuleEnv (objs_loaded pls) mod
+ <|>
+ lookupModuleEnv (bcos_loaded pls) mod
{-
Note [Using Byte Code rather than Object Code for Template Haskell]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -77,11 +77,13 @@ import GHC.Utils.TmpFs
import GHC.Unit.Env
import GHC.Unit.External (ExternalPackageState (EPS, eps_iface_bytecode))
+import GHC.Unit.Finder
import GHC.Unit.Module
import GHC.Unit.State as Packages
import qualified GHC.Data.ShortText as ST
import GHC.Data.FastString
+import qualified GHC.Data.Maybe as Maybe
import GHC.Linker.Deps
import GHC.Linker.MacOS
@@ -94,6 +96,7 @@ import Control.Monad
import qualified Data.Set as Set
import Data.Char (isSpace)
import qualified Data.Foldable as Foldable
+import Data.Functor ((<&>))
import Data.IORef
import Data.List (intercalate, isPrefixOf, nub, partition)
import Data.Maybe
@@ -231,10 +234,10 @@ loadDependencies interp hsc_env pls span needed_mods = do
-- Find what packages and linkables are required
deps <- getLinkDeps opts interp pls span needed_mods
- let this_pkgs_needed = ldNeededUnits deps
+ let this_pkgs_needed = ldAllUnits deps
-- Link the packages and modules required
- pls1 <- loadPackages' interp hsc_env (ldUnits deps) pls
+ pls1 <- loadPackages' interp hsc_env (ldNeededUnits deps) pls
(pls2, succ) <- loadModuleLinkables interp hsc_env pls1 (ldNeededLinkables deps)
let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed
all_pkgs_loaded = pkgs_loaded pls2
@@ -650,14 +653,34 @@ initLinkDepsOpts hsc_env = opts
, ldWays = ways dflags
, ldLoadIface
, ldLoadByteCode
+ , ldDebugTrace = debugTraceMsg (hsc_logger hsc_env) 3
}
dflags = hsc_dflags hsc_env
- ldLoadIface msg mod = initIfaceCheck (text "loader") hsc_env
- $ loadInterface msg mod (ImportByUser NotBoot)
+
+ ldLoadIface msg mod =
+ initIfaceCheck (text "loader") hsc_env (loadInterface msg mod (ImportByUser NotBoot)) >>= \case
+ Maybe.Failed err -> pure (Maybe.Failed err)
+ Maybe.Succeeded iface ->
+ find_location mod <&> \case
+ InstalledFound loc _ -> Maybe.Succeeded (iface, loc)
+ err -> Maybe.Failed $
+ cannotFindInterface unit_state home_unit
+ (targetProfile dflags) (moduleName mod) err
+
+ find_location mod =
+ liftIO $
+ findExactModule (hsc_FC hsc_env) (initFinderOpts dflags)
+ (initFinderOpts . homeUnitEnv_dflags <$> hsc_HUG hsc_env)
+ unit_state home_unit
+ (toUnitId <$> mod)
+
+ unit_state = hsc_units hsc_env
+
+ home_unit = ue_homeUnit (hsc_unit_env hsc_env)
ldLoadByteCode mod = do
EPS {eps_iface_bytecode} <- hscEPS hsc_env
- sequence (lookupModuleEnv eps_iface_bytecode mod)
+ pure (lookupModuleEnv eps_iface_bytecode mod)
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -734,7 +734,7 @@ mkStubPaths fopts mod location = do
src_basename = OsPath.dropExtension <$> ml_hs_file_ospath location
-- -----------------------------------------------------------------------------
--- findLinkable isn't related to the other stuff in here,
+-- findObjectLinkable isn't related to the other stuff in here,
-- but there's no other obvious place for it
findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)
=====================================
compiler/GHC/Unit/Module/WholeCoreBindings.hs
=====================================
@@ -88,9 +88,10 @@ settings.
2. In oneshot mode, which compiles individual modules without a shared home unit
graph, a previously compiled module is not reprocessed as described for make
mode above.
- When 'get_link_deps' encounters a dependency on a local module, it requests
- its bytecode from the External Package State, who loads the interface
- on-demand.
+ 'get_link_deps' requests the bytecode of dependencies from the External
+ Package State, who loads the interface on-demand.
+ This works for modules in local directories (via @-i@ and @-hidir@) as well
+ as those exposed from a package DB.
Since the EPS stores interfaces for all package dependencies in addition to
local modules in oneshot mode, it has a substantial memory footprint.
@@ -210,7 +211,9 @@ If the 'HomeModLinkable' already contains bytecode (case 1), this is a no-op.
Otherwise, the stub objects from the interface are compiled to objects in
'generateByteCode' and added to the 'HomeModLinkable' as well.
-Case 3 is not implemented yet (!13042).
+In case 3, Core bindings are loaded from the EPS, where stubs only exist in
+their serialized form in the interface, so they must be regenerated like in case
+2.
Problem 3:
=====================================
testsuite/tests/bytecode/T25090/Dep.hs
=====================================
@@ -0,0 +1,15 @@
+module Dep where
+
+data A = A Int
+
+used :: Int
+used = 9681
+
+dep :: A
+dep = A used
+
+unused1 :: A
+unused1 = A 1
+
+unused2 :: A
+unused2 = unused1
=====================================
testsuite/tests/bytecode/T25090/DepApi.hs
=====================================
@@ -0,0 +1,7 @@
+module DepApi (A (A), dep) where
+
+import Dep (A (A))
+import qualified Dep
+
+dep :: A
+dep = Dep.dep
=====================================
testsuite/tests/bytecode/T25090/Local.hs
=====================================
@@ -0,0 +1,15 @@
+{-# language PackageImports #-}
+
+module Local where
+
+import GHC.Prim
+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" DepApi (dep, A (A))
+import {-# source #-} Num (num)
+
+splc :: ExpQ
+splc = lift @_ @Int (num + d)
+ where
+ A d = dep
=====================================
testsuite/tests/bytecode/T25090/Makefile
=====================================
@@ -19,3 +19,35 @@ T25090a:
T25090b:
$(TEST_HC) -fbyte-code-and-object-code -fprefer-byte-code A -o exe -v0
./exe
+
+DB := -package-db db -package dep
+BASIC := $(TEST_HC_OPTS) $(DB) -this-unit-id=pkgdep -v0
+BC := -fprefer-byte-code -fbyte-code-and-object-code
+ARGS := $(BASIC) $(BC)
+
+T25090_pkg:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" "shared"
+ ./run.bash "$(TEST_HC)" "$(ARGS) -dynamic"
+
+T25090_pkg_empty:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" "shared-empty"
+ ./run.bash "$(TEST_HC)" "$(ARGS) -dynamic"
+
+T25090_pkg_nolib:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" "none"
+ ./run.bash "$(TEST_HC)" "$(ARGS)"
+
+T25090_pkg_obj_code:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" "shared"
+ ./run.bash "$(TEST_HC)" "$(BASIC) -dynamic -fbyte-code-and-object-code"
+
+T25090_pkg_multi_unit:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" "shared"
+ mkdir -p unit2-src/
+ mv Local.hs Num.hs Num.hs-boot unit2-src/
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ARGS) -dynamic -unit @unit1 -unit @unit2
+ ./PkgBytecode
+
+T25090_pkg_archive:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" "archive"
+ ./run.bash "$(TEST_HC)" "$(ARGS)"
=====================================
testsuite/tests/bytecode/T25090/Num.hs
=====================================
@@ -0,0 +1,4 @@
+module Num where
+
+num :: Int
+num = 48332
=====================================
testsuite/tests/bytecode/T25090/Num.hs-boot
=====================================
@@ -0,0 +1,3 @@
+module Num where
+
+num :: Int
=====================================
testsuite/tests/bytecode/T25090/PkgBytecode.hs
=====================================
@@ -0,0 +1,12 @@
+{-# language TemplateHaskell #-}
+
+module Main where
+
+import GHC.Prim
+import Local (splc)
+
+a :: Int
+a = $(splc)
+
+main :: IO ()
+main = putStrLn (show a)
=====================================
testsuite/tests/bytecode/T25090/PkgBytecode.stdout
=====================================
@@ -0,0 +1 @@
+58013
=====================================
testsuite/tests/bytecode/T25090/all.T
=====================================
@@ -16,3 +16,33 @@ def test_T25090(name):
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),
+ 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/bytecode/T25090/dep.conf
=====================================
@@ -0,0 +1,8 @@
+name: dep
+version: 1.0
+id: dep-1.0
+key: dep-1.0
+exposed: True
+exposed-modules: DepApi
+import-dirs: ${pkgroot}/dep
+library-dirs: ${pkgroot}/dep
=====================================
testsuite/tests/bytecode/T25090/prep.bash
=====================================
@@ -0,0 +1,57 @@
+#!/usr/bin/env bash
+
+set -eu
+
+ghc_cmd="$1"
+ghc_opts="$2"
+ghc_pkg_cmd="$3"
+library="$4"
+
+base="$PWD"
+db="$base/db"
+dep="$base/dep"
+conf_dep="${dep}/dep.conf"
+
+mkdir -p "$dep" "$db"
+mv Dep.hs DepApi.hs "$dep/"
+cp dep.conf "$dep/"
+
+ghc_pkg()
+{
+ eval "${ghc_pkg_cmd at Q} --no-user-package-db --package-db=${db at Q} $@"
+}
+
+ghc()
+{
+ eval "${ghc_cmd at Q} ${ghc_opts/-rtsopts/} -package-db ${db at Q} -hidir ${dep at Q} -O0 -this-unit-id dep-1.0 -fbyte-code-and-object-code $@"
+}
+
+version=$(ghc "--numeric-version")
+
+ghc_pkg recache
+
+ghc "-dynamic-too -c ${dep at Q}/Dep.hs ${dep at Q}/DepApi.hs"
+
+if [[ "$library" == 'shared' ]]
+then
+ ghc "-dynamic -shared -o ${dep at Q}/libHSdep-1.0-ghc$version.so ${dep at Q}/Dep.dyn_o ${dep at Q}/DepApi.dyn_o"
+ echo 'hs-libraries: HSdep-1.0' >> "$conf_dep"
+elif [[ "$library" == 'shared-empty' ]]
+then
+ echo 'module Dummy where' > Dummy.hs
+ ghc "-dynamic-too -c Dummy.hs"
+ ghc "-dynamic -shared -o ${dep at Q}/libHSdep-1.0-ghc$version.so Dummy.dyn_o"
+ echo 'hs-libraries: HSdep-1.0' >> "$conf_dep"
+elif [[ "$library" == 'archive' ]]
+then
+ $AR cqs "${dep}/libHSdep-1.0.a" "${dep}/Dep.o" "${dep}/DepApi.o"
+ echo 'hs-libraries: HSdep-1.0' >> "$conf_dep"
+elif [[ "$library" == 'none' ]]
+then
+ :
+else
+ echo "Invalid argument for 'library': $library"
+ exit 1
+fi
+
+ghc_pkg -v0 register "${conf_dep at Q}"
=====================================
testsuite/tests/bytecode/T25090/run.bash
=====================================
@@ -0,0 +1,16 @@
+#!/usr/bin/env bash
+
+set -eu
+
+ghc_cmd="$1"
+ghc_opts="$2"
+
+ghc()
+{
+ eval "${ghc_cmd at Q} $ghc_opts $@"
+}
+
+ghc -c Num.hs-boot Num.hs Local.hs
+ghc -c PkgBytecode.hs
+ghc PkgBytecode.o -o PkgBytecode
+./PkgBytecode
=====================================
testsuite/tests/bytecode/T25090/unit1
=====================================
@@ -0,0 +1 @@
+-i -i. PkgBytecode -this-unit-id unit1 -package-id unit2
=====================================
testsuite/tests/bytecode/T25090/unit2
=====================================
@@ -0,0 +1 @@
+-i -i./unit2-src Local Num -this-unit-id unit2
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aac0c1be7597052551d36529018fd229df5149cd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aac0c1be7597052551d36529018fd229df5149cd
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/20240930/8be211e6/attachment-0001.html>
More information about the ghc-commits
mailing list