[Git][ghc/ghc][wip/torsten.schmits/package-deps-bytecode-2024-09-23] Package deps bytecode linking
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Mon Sep 23 19:02:48 UTC 2024
Torsten Schmits pushed to branch wip/torsten.schmits/package-deps-bytecode-2024-09-23 at Glasgow Haskell Compiler / GHC
Commits:
56f3fbe9 by Torsten Schmits at 2024-09-23T21:02:37+02:00
Package deps bytecode linking
- - - - -
20 changed files:
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Unit/Finder.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/Obj.hs
- + 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/obj.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
=====================================
@@ -674,7 +674,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,6 @@ getLinkDeps opts interp pls span mods = do
get_link_deps opts pls maybe_normal_osuf span mods
-
get_link_deps
:: LinkDepsOpts
-> LoaderState
@@ -111,47 +115,48 @@ 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
- }
+ -- 1. Find the dependent home-pkg-modules/packages from each iface
+ -- (omitting modules from the interactive package, which is already linked)
+ -- 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)
+ deps <- if ldOneShotMode opts
+ then oneshot_deps opts (filterOut isInteractiveModule mods)
+ else make_deps
+
+ -- 2. Exclude ones already linked
+ -- Main reason: avoid findModule calls in get_linkable
+ -- TODO outdated
+ let (loaded_modules, needed_modules, ldAllUnits, ldNeededUnits) =
+ classify_deps pls deps
+
+ -- 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
+ -- TODO outdated
+ ldNeededLinkables <- mapM module_linkable needed_modules
+
+ pure LinkDeps {
+ ldNeededLinkables,
+ ldAllLinkables = loaded_modules ++ ldNeededLinkables,
+ ldNeededUnits,
+ ldAllUnits
+ }
where
mod_graph = ldModuleGraph opts
unit_env = ldUnitEnv opts
+ make_deps = do
+ (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods
+ let
+ link_mods =
+ listToUDFM [(moduleName (mi_module (hm_iface m)), m) | m <- mmods]
+ link_libs =
+ uniqDSetToList (unionManyUniqDSets (init_pkg_set : pkgs))
+ pure $
+ LinkModules (LinkHomeModule <$> link_mods) :
+ (LinkLibrary <$> link_libs)
+
-- This code is used in `--make` mode to calculate the home package and unit dependencies
-- for a set of modules.
--
@@ -183,73 +188,14 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
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 $ Set.toList $ dep_direct_pkgs (mi_deps 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 +204,18 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
while_linking_expr = text "while linking an interpreted expression"
+ 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 +224,256 @@ 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)
+
+ -- 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)
+
+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
+
+-- 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.
+oneshot_deps ::
+ LinkDepsOpts ->
+ -- | Modules whose imports to follow
+ [Module] ->
+ IO [LinkDep]
+oneshot_deps opts mods =
+ runExceptT (oneshot_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
+
+oneshot_deps_loop ::
+ LinkDepsOpts ->
+ [Module] ->
+ UniqDFM UnitId LinkDep ->
+ ExceptT OneshotError IO (UniqDFM UnitId LinkDep)
+oneshot_deps_loop _ [] acc =
+ pure acc
+oneshot_deps_loop opts (mod : mods) acc = do
+ (new_acc, new_mods, action) <- process_module
+ traverse_ debug_log action
+ oneshot_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
+ ])
+
+ process_module
+ | already_seen = pure (acc, [], Nothing)
+ | is_home || bytecode = try_iface
+ | otherwise = add_library
+
+ already_seen
+ | Just (LinkModules mods) <- mod_dep
+ = elemUDFM mod_name mods
+ | Just (LinkLibrary _) <- mod_dep
+ = True
+ | otherwise
+ = False
+
+ 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
+
+ with_iface loc iface mb_load_bc
+ | IsBoot <- mi_boot iface
+ = throwE (LinkBootModule mod)
+
+ | 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
+ | bytecode
+ = []
+ | otherwise
+ = [(u, LinkLibrary u) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))]
+
+ new_deps iface
+ | bytecode
+ -- TODO How can we better determine the external deps?
+ = [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"
+
+ 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"
+
+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 (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 lm =
+ maybe (Right lm) Left (loaded_linkable (mi_module (link_module_iface lm)))
+
+ loaded_linkable 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
@@ -645,19 +648,40 @@ initLinkDepsOpts hsc_env = opts
, ldPprOpts = initSDocContext dflags defaultUserStyle
, ldFinderCache = hsc_FC hsc_env
, ldFinderOpts = initFinderOpts dflags
+ -- , ldHugFinderOpts = initFinderOpts . homeUnitEnv_dflags <$> hsc_HUG hsc_env
, ldUseByteCode = gopt Opt_UseBytecodeRatherThanObjects dflags
, ldMsgOpts = initIfaceMessageOpts dflags
, 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)
@@ -1347,6 +1371,14 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0
| loading_dynamic_hs_libs -- search for .so libraries first.
= findHSDll `orElse`
findDynObject `orElse`
+ -- TODO Added the next two because static archives would be ignored when
+ -- linking bytecode.
+ -- Not sure if this is expected, but the condition for this branch is just
+ -- that ghc is _capable_ of dynamic linking, so maybe this function was just
+ -- never used when linking TH before this patch?
+ -- Add a test to the oneshot base MR that uses archives to compare.
+ findObject `orElse`
+ findArchive `orElse`
assumeDll
| otherwise
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -734,7 +734,7 @@ mkStubPaths fopts mod location
stub_basename <.> os "h"
-- -----------------------------------------------------------------------------
--- 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)
=====================================
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,16 @@
+{-# 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)
+import Obj (numo)
+
+splc :: ExpQ
+splc = lift @_ @Int (num + d + numo)
+ where
+ A d = dep
=====================================
testsuite/tests/bytecode/T25090/Makefile
=====================================
@@ -19,3 +19,37 @@ T25090a:
T25090b:
$(TEST_HC) -fbyte-code-and-object-code -fprefer-byte-code A -o exe -v0
./exe
+
+# TODO it works even without -package obj, but it should complain about the package not being exposed
+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)
+
+.PHONY: PkgArchive
+PkgArchive:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 1
+ ./run.bash "$(TEST_HC)" "$(ARGS)"
+
+.PHONY: PkgEmptyArchive
+PkgEmptyArchive:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 2
+ ./run.bash "$(TEST_HC)" "$(ARGS)"
+
+.PHONY: PkgNoArchive
+PkgNoArchive:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 3
+ ./run.bash "$(TEST_HC)" "$(ARGS)"
+
+.PHONY: PkgArchiveObjCode
+PkgArchiveObjCode:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 1
+ ./run.bash "$(TEST_HC)" "$(BASIC) -fbyte-code-and-object-code"
+
+.PHONY: PkgMultiUnit
+PkgMultiUnit:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 1
+ mkdir -p unit2-src/
+ mv Local.hs Num.hs Num.hs-boot unit2-src/
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ARGS) -unit @unit1 -unit @unit2
+ ./PkgBytecode
=====================================
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/Obj.hs
=====================================
@@ -0,0 +1,4 @@
+module Obj where
+
+numo :: Int
+numo = 0
=====================================
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,34 @@ def test_T25090(name):
test_T25090('T25090a')
test_T25090('T25090b')
+
+def test_pkg(suf, files = []):
+ name = f'Pkg{suf}'
+ test(
+ name,
+ [
+ extra_files([
+ 'PkgBytecode.hs',
+ 'Local.hs',
+ 'Dep.hs',
+ 'DepApi.hs',
+ 'Num.hs',
+ 'Num.hs-boot',
+ 'Obj.hs',
+ 'dep.conf',
+ 'obj.conf',
+ 'prep.bash',
+ 'run.bash',
+ ] + files),
+ use_specs({'stdout': 'PkgBytecode.stdout'}),
+ ],
+ makefile_test,
+ [name],
+ )
+
+test_pkg('Archive')
+test_pkg('EmptyArchive')
+test_pkg('NoArchive')
+# TODO broken
+# test_pkg('ArchiveObjCode')
+test_pkg('MultiUnit', ['unit1', 'unit2'])
=====================================
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/obj.conf
=====================================
@@ -0,0 +1,8 @@
+name: obj
+version: 1.0
+id: obj-1.0
+key: obj-1.0
+exposed: True
+exposed-modules: Obj
+import-dirs: ${pkgroot}/obj
+library-dirs: ${pkgroot}/obj
=====================================
testsuite/tests/bytecode/T25090/prep.bash
=====================================
@@ -0,0 +1,52 @@
+#!/usr/bin/env bash
+
+set -eu
+
+ghc_cmd="$1"
+ghc_opts="$2"
+ghc_pkg_cmd="$3"
+archive="$4"
+
+base="$PWD"
+db="$base/db"
+dep="$base/dep"
+conf_dep="${dep}/dep.conf"
+obj="$base/obj"
+conf_obj="${obj}/obj.conf"
+
+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 $@"
+}
+
+mkdir -p "$dep" "$obj" "$db"
+mv Dep.hs DepApi.hs "$dep/"
+cp dep.conf "$dep/"
+mv Obj.hs "$obj/"
+cp obj.conf "$obj/"
+
+ghc_pkg recache
+
+ghc "-package-db ${db at Q} -hidir ${dep at Q} -O0 -this-unit-id dep-1.0 -fbyte-code-and-object-code -c ${dep at Q}/Dep.hs ${dep at Q}/DepApi.hs"
+
+ghc "-package-db ${db at Q} -hidir ${obj at Q} -O0 -this-unit-id obj-1.0 -c ${obj at Q}/Obj.hs"
+$AR cqs "${obj}/libHSobj-1.0.a" "${obj}/Obj.o"
+echo 'hs-libraries: HSobj-1.0' >> "$conf_obj"
+
+if [[ "$archive" == 1 ]]
+then
+ $AR cqs "${dep}/libHSdep-1.0.a" "${dep}/Dep.o" "${dep}/DepApi.o"
+ echo 'hs-libraries: HSdep-1.0' >> "$conf_dep"
+elif [[ "$archive" == 2 ]]
+then
+ $AR cqs "${dep}/libHSdep-1.0.a"
+ echo 'hs-libraries: HSdep-1.0' >> "$conf_dep"
+fi
+
+ghc_pkg -v0 register "${conf_dep at Q}"
+ghc_pkg -v0 register "${conf_obj 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/56f3fbe9f747725dca63fc7420868fcb7fe9ee4a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56f3fbe9f747725dca63fc7420868fcb7fe9ee4a
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/20240923/e2f69850/attachment-0001.html>
More information about the ghc-commits
mailing list