[Git][ghc/ghc][wip/torsten.schmits/package-deps-bytecode-squashed] Package deps bytecode linking
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Fri Jul 12 14:27:40 UTC 2024
Torsten Schmits pushed to branch wip/torsten.schmits/package-deps-bytecode-squashed at Glasgow Haskell Compiler / GHC
Commits:
ee58ce1f by Torsten Schmits at 2024-07-12T16:27:28+02:00
Package deps bytecode linking
- - - - -
19 changed files:
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Unit/Finder.hs
- + testsuite/tests/th/cross-package/Cross.hs
- + testsuite/tests/th/cross-package/CrossDep.hs
- + testsuite/tests/th/cross-package/CrossDepApi.hs
- + testsuite/tests/th/cross-package/CrossLocal.hs
- + testsuite/tests/th/cross-package/CrossNum.hs
- + testsuite/tests/th/cross-package/CrossNum.hs-boot
- + testsuite/tests/th/cross-package/CrossObj.hs
- + testsuite/tests/th/cross-package/CrossPackage.stdout
- + testsuite/tests/th/cross-package/Makefile
- + testsuite/tests/th/cross-package/all.T
- + testsuite/tests/th/cross-package/dep.conf
- + testsuite/tests/th/cross-package/obj.conf
- + testsuite/tests/th/cross-package/prep.bash
- + testsuite/tests/th/cross-package/run.bash
- + testsuite/tests/th/cross-package/unit1
- + testsuite/tests/th/cross-package/unit2
Changes:
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
module GHC.Linker.Deps
( LinkDepsOpts (..)
@@ -47,8 +48,10 @@ import GHC.Utils.Misc
import GHC.Unit.Home
import GHC.Data.Maybe
-import Control.Monad
import Control.Applicative
+import Control.Monad
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import qualified Data.Set as Set
import qualified Data.Map as M
@@ -58,8 +61,6 @@ import System.Directory
import GHC.Driver.Env
import {-# SOURCE #-} GHC.Driver.Main
import Data.Time.Clock
-import GHC.Driver.Flags
-import GHC.Driver.Session
data LinkDepsOpts = LinkDepsOpts
@@ -70,6 +71,7 @@ data LinkDepsOpts = LinkDepsOpts
, ldPprOpts :: !SDocContext -- ^ Rendering options for error messages
, ldFinderCache :: !FinderCache -- ^ Finder cache
, ldFinderOpts :: !FinderOpts -- ^ Finder options
+ , ldHugFinderOpts :: !(UnitEnvGraph FinderOpts)
, ldUseByteCode :: !Bool -- ^ Use bytecode rather than objects
, ldMsgOpts :: !(DiagnosticOpts IfaceMessage) -- ^ Options for diagnostics
, ldWays :: !Ways -- ^ Enabled ways
@@ -81,8 +83,8 @@ data LinkDepsOpts = LinkDepsOpts
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
@@ -108,7 +110,6 @@ getLinkDeps opts interp pls span mods = do
get_link_deps opts pls maybe_normal_osuf span mods
-
get_link_deps
:: LinkDepsOpts
-> LoaderState
@@ -117,47 +118,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 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.
--
@@ -189,73 +191,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 " <>
@@ -264,6 +207,20 @@ 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 iface wcb -> do
+ details <- initModDetails (ldHscEnv opts) iface
+ t <- getCurrentTime
+ initWholeCoreBindings (ldHscEnv opts) iface details $ LM t (mi_module iface) [CoreBindings wcb]
-- See Note [Using Byte Code rather than Object Code for Template Haskell]
homeModLinkable :: HomeModInfo -> Maybe Linkable
@@ -272,73 +229,228 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
then homeModInfoByteCode hmi <|> homeModInfoObject hmi
else homeModInfoObject hmi <|> homeModInfoByteCode hmi
- get_linkable 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
-
- let fc = ldFinderCache opts
- let fopts = ldFinderOpts opts
- mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
- case mb_stuff of
- Found loc mod -> found loc mod
- _ -> no_obj (moduleName mod)
- where
- found loc mod
- | prefer_bytecode = do
- Succeeded iface <- ldLoadIface opts (text "makima") mod
- case mi_extra_decls iface of
- Just extra_decls -> do
- details <- initModDetails hsc_env iface
- t <- getCurrentTime
- initWholeCoreBindings hsc_env iface details $ LM t mod [CoreBindings $ WholeCoreBindings extra_decls mod undefined]
- _ -> fallback_no_bytecode loc mod
- | otherwise = fallback_no_bytecode loc mod
-
- fallback_no_bytecode loc mod = do
- mb_lnk <- findObjectLinkableMaybe mod loc
- case mb_lnk of
- Nothing -> no_obj mod
- Just lnk -> adjust_linkable lnk
-
- prefer_bytecode = gopt Opt_UseBytecodeRatherThanObjects dflags
-
- dflags = hsc_dflags hsc_env
-
- hsc_env = ldHscEnv opts
-
- adjust_linkable lnk
- | Just new_osuf <- maybe_normal_osuf = do
- new_uls <- mapM (adjust_ul new_osuf)
- (linkableUnlinked lnk)
- return lnk{ linkableUnlinked=new_uls }
- | otherwise =
- return lnk
-
- adjust_ul new_osuf (DotO file) = do
- -- file may already has new_osuf suffix. One example
- -- is when we load bytecode from whole core bindings,
- -- then the corresponding foreign stub objects are
- -- compiled as shared objects and file may already has
- -- .dyn_o suffix. And it's okay as long as the file to
- -- load is already there.
- let new_file = file -<.> 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)
- adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
- adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
- adjust_ul _ l@(BCOs {}) = return l
- adjust_ul _ l at LoadedBCOs{} = return l
- adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _)) = pprPanic "Unhydrated core bindings" (ppr mod)
+ adjust_linkable lnk
+ | Just new_osuf <- maybe_normal_osuf = do
+ new_uls <- mapM (adjust_ul new_osuf)
+ (linkableUnlinked lnk)
+ return lnk{ linkableUnlinked=new_uls }
+ | otherwise =
+ return lnk
+
+ adjust_ul new_osuf (DotO file) = do
+ -- file may already has new_osuf suffix. One example
+ -- is when we load bytecode from whole core bindings,
+ -- then the corresponding foreign stub objects are
+ -- compiled as shared objects and file may already has
+ -- .dyn_o suffix. And it's okay as long as the file to
+ -- load is already there.
+ let new_file = file -<.> 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)
+ adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
+ adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
+ adjust_ul _ l@(BCOs {}) = return l
+ adjust_ul _ l at LoadedBCOs{} = return l
+ adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _)) = pprPanic "Unhydrated core bindings" (ppr mod)
+
+data LinkModule =
+ LinkHomeModule HomeModInfo
+ |
+ LinkObjectModule ModIface ModLocation
+ |
+ LinkByteCodeModule ModIface WholeCoreBindings
+
+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 _ wcb -> ppr (wcb_module wcb) <+> 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) <- process_module
+ oneshot_deps_loop opts (new_mods ++ mods) new_acc
+ where
+ process_module
+ | already_seen = pure (acc, [])
+ | 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 ->
+ location >>= \case
+ InstalledFound loc _ -> with_iface loc iface
+ _ -> throwE (NoLocation mod)
+
+ with_iface loc iface
+ | mi_boot iface == IsBoot
+ = throwE (LinkBootModule mod)
+ | bytecode
+ , Just core_bindings <- mi_extra_decls iface
+ , let wcb = WholeCoreBindings core_bindings mod loc
+ = pure (add_module iface (LinkByteCodeModule iface wcb))
+ | is_home
+ = pure (add_module iface (LinkObjectModule iface loc))
+ | otherwise
+ = add_library
+
+ add_library = pure (addToUDFM acc mod_unit_id (LinkLibrary mod_unit_id), [])
+
+ add_module iface lmod =
+ (addListToUDFM with_mod (direct_pkgs iface), new_deps iface)
+ 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
+
+ location =
+ liftIO $
+ findExactModule (ldFinderCache opts) (ldFinderOpts opts)
+ (ldHugFinderOpts opts) (hsc_units (ldHscEnv opts)) mb_home
+ (toUnitId <$> mod)
+
+ 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
=====================================
@@ -230,10 +230,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,6 +645,7 @@ 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
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -748,7 +748,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/th/cross-package/Cross.hs
=====================================
@@ -0,0 +1,12 @@
+{-# language TemplateHaskell #-}
+
+module Main where
+
+import GHC.Prim
+import CrossLocal (splc)
+
+a :: Int
+a = $(splc)
+
+main :: IO ()
+main = putStrLn (show a)
=====================================
testsuite/tests/th/cross-package/CrossDep.hs
=====================================
@@ -0,0 +1,15 @@
+module CrossDep 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/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
=====================================
@@ -0,0 +1,16 @@
+{-# language PackageImports #-}
+
+module CrossLocal 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" CrossDepApi (dep, A (A))
+import {-# source #-} CrossNum (num)
+import CrossObj (numo)
+
+splc :: ExpQ
+splc = lift @_ @Int (num + d + numo)
+ where
+ A d = dep
=====================================
testsuite/tests/th/cross-package/CrossNum.hs
=====================================
@@ -0,0 +1,4 @@
+module CrossNum where
+
+num :: Int
+num = 48332
=====================================
testsuite/tests/th/cross-package/CrossNum.hs-boot
=====================================
@@ -0,0 +1,3 @@
+module CrossNum where
+
+num :: Int
=====================================
testsuite/tests/th/cross-package/CrossObj.hs
=====================================
@@ -0,0 +1,4 @@
+module CrossObj where
+
+numo :: Int
+numo = 0
=====================================
testsuite/tests/th/cross-package/CrossPackage.stdout
=====================================
@@ -0,0 +1 @@
+58013
=====================================
testsuite/tests/th/cross-package/Makefile
=====================================
@@ -0,0 +1,37 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+# 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=cross -v0
+BC := -fprefer-byte-code -fbyte-code-and-object-code
+ARGS := $(BASIC) $(BC)
+
+.PHONY: CrossPackageArchive
+CrossPackageArchive:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 1
+ ./run.bash "$(TEST_HC)" "$(ARGS)"
+
+.PHONY: CrossPackageEmptyArchive
+CrossPackageEmptyArchive:
+ ./prep.bash "$(TEST_HC)" " $(TEST_HC_OPTS)" "$(GHC_PKG)" 2
+ ./run.bash "$(TEST_HC)" "$(ARGS)"
+
+.PHONY: CrossPackageNoArchive
+CrossPackageNoArchive:
+ ./prep.bash "$(TEST_HC)" " $(TEST_HC_OPTS)" "$(GHC_PKG)" 3
+ ./run.bash "$(TEST_HC)" "$(ARGS)"
+
+.PHONY: CrossPackageArchiveObjCode
+CrossPackageArchiveObjCode:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 1
+ ./run.bash "$(TEST_HC)" "$(BASIC)"
+
+.PHONY: CrossPackageMultiUnit
+CrossPackageMultiUnit:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 1
+ mkdir -p unit2-src/
+ mv CrossLocal.hs CrossNum.hs CrossNum.hs-boot unit2-src/
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ARGS) -unit @unit1 -unit @unit2
+ ./Cross
=====================================
testsuite/tests/th/cross-package/all.T
=====================================
@@ -0,0 +1,29 @@
+def cross_test(suf, files = []):
+ name = f'CrossPackage{suf}'
+ test(
+ name,
+ [
+ extra_files([
+ 'Cross.hs',
+ 'CrossLocal.hs',
+ 'CrossDep.hs',
+ 'CrossDepApi.hs',
+ 'CrossNum.hs',
+ 'CrossNum.hs-boot',
+ 'CrossObj.hs',
+ 'dep.conf',
+ 'obj.conf',
+ 'prep.bash',
+ 'run.bash',
+ ] + files),
+ use_specs({'stdout': 'CrossPackage.stdout'}),
+ ],
+ makefile_test,
+ [name],
+ )
+
+cross_test('Archive')
+cross_test('EmptyArchive')
+cross_test('NoArchive')
+cross_test('ArchiveObjCode')
+cross_test('MultiUnit', ['unit1', 'unit2'])
=====================================
testsuite/tests/th/cross-package/dep.conf
=====================================
@@ -0,0 +1,8 @@
+name: dep
+version: 1.0
+id: dep-1.0
+key: dep-1.0
+exposed: True
+exposed-modules: CrossDepApi
+import-dirs: ${pkgroot}/dep
+library-dirs: ${pkgroot}/dep
=====================================
testsuite/tests/th/cross-package/obj.conf
=====================================
@@ -0,0 +1,8 @@
+name: obj
+version: 1.0
+id: obj-1.0
+key: obj-1.0
+exposed: True
+exposed-modules: CrossObj
+import-dirs: ${pkgroot}/obj
+library-dirs: ${pkgroot}/obj
=====================================
testsuite/tests/th/cross-package/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 CrossDep.hs CrossDepApi.hs "$dep/"
+cp dep.conf "$dep/"
+mv CrossObj.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}/CrossDep.hs ${dep at Q}/CrossDepApi.hs"
+
+ghc "-package-db ${db at Q} -hidir ${obj at Q} -O0 -this-unit-id obj-1.0 -c ${obj at Q}/CrossObj.hs"
+$AR cqs "${obj}/libHSobj-1.0.a" "${obj}/CrossObj.o"
+echo 'hs-libraries: HSobj-1.0' >> "$conf_obj"
+
+if [[ "$archive" == 1 ]]
+then
+ $AR cqs "${dep}/libHSdep-1.0.a" "${dep}/CrossDep.o" "${dep}/CrossDepApi.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/th/cross-package/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 CrossNum.hs-boot CrossNum.hs CrossLocal.hs
+ghc -c Cross.hs
+ghc Cross.o -o Cross
+./Cross
=====================================
testsuite/tests/th/cross-package/unit1
=====================================
@@ -0,0 +1 @@
+-i -i. Cross -this-unit-id unit1 -package-id unit2
=====================================
testsuite/tests/th/cross-package/unit2
=====================================
@@ -0,0 +1 @@
+-i -i./unit2-src CrossLocal CrossNum -this-unit-id unit2
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee58ce1f63e868462fab07da7ca7ce5b85e48672
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee58ce1f63e868462fab07da7ca7ce5b85e48672
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/20240712/c2c0eaef/attachment-0001.html>
More information about the ghc-commits
mailing list