[Git][ghc/ghc][wip/torsten.schmits/package-deps-bytecode-squashed] 2 commits: Oneshot bytecode linking
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Thu Jul 18 12:33:26 UTC 2024
Torsten Schmits pushed to branch wip/torsten.schmits/package-deps-bytecode-squashed at Glasgow Haskell Compiler / GHC
Commits:
79b0072b by Cheng Shao at 2024-07-18T14:30:21+02:00
Oneshot bytecode linking
- - - - -
f06853e2 by Torsten Schmits at 2024-07-18T14:33:04+02:00
Package deps bytecode linking
- - - - -
29 changed files:
- compiler/GHC/Driver/Main.hs
- + compiler/GHC/Driver/Main.hs-boot
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/ModIface.hs
- testsuite/tests/bytecode/T24634/Makefile
- + testsuite/tests/bytecode/T24634/T24634.stdout
- testsuite/tests/bytecode/T24634/all.T
- + 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/Driver/Main.hs
=====================================
@@ -106,6 +106,7 @@ module GHC.Driver.Main
, showModuleIndex
, hscAddSptEntries
, writeInterfaceOnlyMode
+ , loadByteCode
) where
import GHC.Prelude
@@ -292,6 +293,8 @@ import GHC.Types.TypeEnv
import System.IO
import {-# SOURCE #-} GHC.Driver.Pipeline
import Data.Time
+import Data.Traversable
+import qualified Data.ByteString as BS
import System.IO.Unsafe ( unsafeInterleaveIO )
import GHC.Iface.Env ( trace_if )
@@ -991,7 +994,18 @@ initModDetails hsc_env iface =
-- Hydrate any WholeCoreBindings linkables into BCOs
initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
-initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM utc_time this_mod <$> mapM go uls
+initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = do
+ -- If a module is compiled with -fbyte-code-and-object-code and it
+ -- makes use of foreign stubs, then the interface file will also
+ -- contain serialized stub dynamic objects, and we can simply write
+ -- them to temporary objects and refer to them as unlinked items
+ -- directly.
+ stub_uls <- for (mi_stub_objs mod_iface) $ \stub_obj -> do
+ f <- newTempName (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (tmpDir (hsc_dflags hsc_env)) TFL_GhcSession "dyn_o"
+ BS.writeFile f stub_obj
+ pure $ DotO f
+ bytecode_uls <- for uls go
+ pure $ LM utc_time this_mod $ stub_uls ++ bytecode_uls
where
go (CoreBindings fi) = do
let act hpt = addToHpt hpt (moduleName $ mi_module mod_iface)
@@ -1005,9 +1019,6 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM
-- in the interface file.
LoadedBCOs <$> (unsafeInterleaveIO $ do
core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
- -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do
- -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone
- -- reports a bug.
let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
trace_if (hsc_logger hsc_env) (text "Generating ByteCode for" <+> (ppr this_mod))
generateByteCode hsc_env cgi_guts (wcb_mod_location fi))
@@ -2044,7 +2055,10 @@ generateByteCode hsc_env cgguts mod_location = do
stub_o <- case hasStub of
Nothing -> return []
Just stub_c -> do
- stub_o <- compileForeign hsc_env LangC stub_c
+ -- Always compile foreign stubs as shared objects so
+ -- they can be properly loaded later when the bytecode
+ -- is loaded.
+ stub_o <- compileForeign (hscUpdateFlags setDynamicNow hsc_env) LangC stub_c
return [DotO stub_o]
let hs_unlinked = [BCOs comp_bc spt_entries]
=====================================
compiler/GHC/Driver/Main.hs-boot
=====================================
@@ -0,0 +1,11 @@
+module GHC.Driver.Main where
+
+import GHC.Driver.Env
+import GHC.Linker.Types
+import GHC.Prelude
+import GHC.Unit.Module.ModDetails
+import GHC.Unit.Module.ModIface
+
+initModDetails :: HscEnv -> ModIface -> IO ModDetails
+
+initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -796,7 +796,7 @@ hscBackendPipeline pipe_env hsc_env mod_sum result =
HscUpdate iface -> return (iface, emptyHomeModInfoLinkable)
HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure emptyHomeModInfoLinkable
-- TODO: Why is there not a linkable?
- -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing
+ -- Interpreter -> (,) <$> use (T_IO (mkFullIfaceWithForeignStubs hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing
hscGenBackendPipeline :: P m
=> PipeEnv
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -582,9 +582,23 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
do
output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)
(outputFilename, mStub, foreign_files, stg_infos, cg_infos) <-
-
hscGenHardCode hsc_env cgguts mod_location output_fn
- final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos
+
+ -- When compiling with -fprefer-byte-code, always
+ -- compile foreign stubs as shared objects to ensure
+ -- they can be properly loaded.
+ let hsc_env_stub
+ | gopt Opt_WriteIfSimplifiedCore dflags = hscUpdateFlags setDynamicNow hsc_env
+ | otherwise = hsc_env
+ stub_o <- mapM (compileStub hsc_env_stub) mStub
+ foreign_os <-
+ mapM (uncurry (compileForeign hsc_env_stub)) foreign_files
+ let fos = maybe [] return stub_o ++ foreign_os
+ iface_fos
+ | gopt Opt_WriteIfSimplifiedCore dflags = fos
+ | otherwise = []
+
+ final_iface <- mkFullIfaceWithForeignStubs hsc_env partial_iface stg_infos cg_infos iface_fos
-- See Note [Writing interface files]
hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
@@ -596,12 +610,6 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
else return emptyHomeModInfoLinkable
-
- stub_o <- mapM (compileStub hsc_env) mStub
- foreign_os <-
- mapM (uncurry (compileForeign hsc_env)) foreign_files
- let fos = (maybe [] return stub_o ++ foreign_os)
-
-- This is awkward, no linkable is produced here because we still
-- have some way to do before the object file is produced
-- In future we can split up the driver logic more so that this function
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -516,11 +516,6 @@ loadInterface doc_str mod from
; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
; let final_iface = iface
- & set_mi_decls (panic "No mi_decls in PIT")
- & set_mi_insts (panic "No mi_insts in PIT")
- & set_mi_fam_insts (panic "No mi_fam_insts in PIT")
- & set_mi_rules (panic "No mi_rules in PIT")
- & set_mi_anns (panic "No mi_anns in PIT")
; let bad_boot = mi_boot iface == IsBoot
&& isJust (lookupKnotVars (if_rec_types gbl_env) mod)
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -12,6 +12,7 @@
module GHC.Iface.Make
( mkPartialIface
, mkFullIface
+ , mkFullIfaceWithForeignStubs
, mkIfaceTc
, mkIfaceExports
)
@@ -89,6 +90,8 @@ import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Deps
+import qualified Data.ByteString as BS
+import Data.Traversable
import Data.Function
import Data.List ( sortBy )
import Data.Ord
@@ -127,23 +130,30 @@ mkPartialIface hsc_env core_prog mod_details mod_summary import_decls
= mkIface_ hsc_env this_mod core_prog hsc_src used_th deps rdr_env import_decls fix_env warns hpc_info self_trust
safe_mode usages docs mod_summary mod_details
+-- | Backwards compat interface for 'mkFullIfaceWithForeignStubs'.
+mkFullIface :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> IO ModIface
+mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos =
+ mkFullIfaceWithForeignStubs hsc_env partial_iface mb_stg_infos mb_cmm_infos []
+
-- | Fully instantiate an interface. Adds fingerprints and potentially code
-- generator produced information.
--
-- CmmCgInfos is not available when not generating code (-fno-code), or when not
-- generating interface pragmas (-fomit-interface-pragmas). See also
-- Note [Conveying CAF-info and LFInfo between modules] in GHC.StgToCmm.Types.
-mkFullIface :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> IO ModIface
-mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos = do
+mkFullIfaceWithForeignStubs :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> [FilePath] -> IO ModIface
+mkFullIfaceWithForeignStubs hsc_env partial_iface mb_stg_infos mb_cmm_infos fos = do
let decls
| gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)
= mi_decls partial_iface
| otherwise
= updateDecl (mi_decls partial_iface) mb_stg_infos mb_cmm_infos
+ stub_objs <- for fos BS.readFile
+
full_iface <-
{-# SCC "addFingerprints" #-}
- addFingerprints hsc_env (set_mi_decls decls partial_iface)
+ addFingerprints hsc_env $ set_mi_stub_objs stub_objs $ set_mi_decls decls partial_iface
-- Debug printing
let unit_state = hsc_units hsc_env
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
module GHC.Linker.Deps
( LinkDepsOpts (..)
@@ -47,15 +48,18 @@ 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 qualified Data.Set as Set
import qualified Data.Map as M
-import Data.List (isSuffixOf)
import System.FilePath
import System.Directory
+import GHC.Driver.Env
+import {-# SOURCE #-} GHC.Driver.Main
+import Data.Time.Clock
data LinkDepsOpts = LinkDepsOpts
@@ -66,18 +70,20 @@ 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
, ldLoadIface :: SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface)
-- ^ Interface loader function
+ , ldHscEnv :: !HscEnv
}
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
@@ -103,7 +109,6 @@ getLinkDeps opts interp pls span mods = do
get_link_deps opts pls maybe_normal_osuf span mods
-
get_link_deps
:: LinkDepsOpts
-> LoaderState
@@ -112,47 +117,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.
--
@@ -184,73 +190,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 " <>
@@ -259,6 +206,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
@@ -267,54 +228,228 @@ 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
-
- 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 = do {
- -- ...and then find the linkable for it
- mb_lnk <- findObjectLinkableMaybe mod loc ;
- case mb_lnk of {
- Nothing -> no_obj mod ;
- Just lnk -> adjust_linkable lnk
- }}
-
- 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
- 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)
- 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]
@@ -408,4 +543,3 @@ failNonStd opts srcspan = dieWith opts srcspan $
Prof -> "with -prof"
Dyn -> "with -dynamic"
#endif
-
=====================================
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,9 +645,11 @@ 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
+ , ldHscEnv = hsc_env
}
dflags = hsc_dflags hsc_env
load_iface msg mod = initIfaceCheck (text "loader") hsc_env
=====================================
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)
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -22,6 +22,7 @@ module GHC.Unit.Module.ModIface
, mi_anns
, mi_decls
, mi_extra_decls
+ , mi_stub_objs
, mi_top_env
, mi_insts
, mi_fam_insts
@@ -56,6 +57,7 @@ module GHC.Unit.Module.ModIface
, set_mi_rules
, set_mi_decls
, set_mi_extra_decls
+ , set_mi_stub_objs
, set_mi_top_env
, set_mi_hpc
, set_mi_trust
@@ -119,6 +121,7 @@ import GHC.Utils.Binary
import Control.DeepSeq
import Control.Exception
import qualified GHC.Data.Strict as Strict
+import Data.ByteString (ByteString)
{- Note [Interface file stages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -282,6 +285,13 @@ data ModIface_ (phase :: ModIfacePhase)
-- combined with mi_decls allows us to restart code generation.
-- See Note [Interface Files with Core Definitions] and Note [Interface File with Core: Sharing RHSs]
+ mi_stub_objs_ :: ![ByteString],
+ -- ^ Serialized foreign stub dynamic objects when
+ -- compiled with -fbyte-code-and-object-code, empty
+ -- and unused in other cases. This is required to make
+ -- whole core bindings properly work with foreign
+ -- stubs (see #24634).
+
mi_top_env_ :: !(Maybe IfaceTopEnv),
-- ^ Just enough information to reconstruct the top level environment in
-- the /original source/ code for this module. which
@@ -453,6 +463,7 @@ instance Binary ModIface where
mi_anns_ = anns,
mi_decls_ = decls,
mi_extra_decls_ = extra_decls,
+ mi_stub_objs_ = stub_objs,
mi_insts_ = insts,
mi_fam_insts_ = fam_insts,
mi_rules_ = rules,
@@ -497,6 +508,7 @@ instance Binary ModIface where
lazyPut bh anns
put_ bh decls
put_ bh extra_decls
+ put_ bh stub_objs
put_ bh insts
put_ bh fam_insts
lazyPut bh rules
@@ -529,6 +541,7 @@ instance Binary ModIface where
anns <- {-# SCC "bin_anns" #-} lazyGet bh
decls <- {-# SCC "bin_tycldecls" #-} get bh
extra_decls <- get bh
+ stub_objs <- get bh
insts <- {-# SCC "bin_insts" #-} get bh
fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
rules <- {-# SCC "bin_rules" #-} lazyGet bh
@@ -558,6 +571,7 @@ instance Binary ModIface where
mi_warns_ = warns,
mi_decls_ = decls,
mi_extra_decls_ = extra_decls,
+ mi_stub_objs_ = stub_objs,
mi_top_env_ = Nothing,
mi_insts_ = insts,
mi_fam_insts_ = fam_insts,
@@ -611,6 +625,7 @@ emptyPartialModIface mod
mi_rules_ = [],
mi_decls_ = [],
mi_extra_decls_ = Nothing,
+ mi_stub_objs_ = [],
mi_top_env_ = Nothing,
mi_hpc_ = False,
mi_trust_ = noIfaceTrustInfo,
@@ -664,7 +679,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
rnf (PrivateModIface
{ mi_module_, mi_sig_of_, mi_hsc_src_, mi_hi_bytes_, mi_deps_, mi_usages_
, mi_exports_, mi_used_th_, mi_fixities_, mi_warns_, mi_anns_
- , mi_decls_, mi_extra_decls_, mi_top_env_, mi_insts_
+ , mi_decls_, mi_extra_decls_, mi_stub_objs_, mi_top_env_, mi_insts_
, mi_fam_insts_, mi_rules_, mi_hpc_, mi_trust_, mi_trust_pkg_
, mi_complete_matches_, mi_docs_, mi_final_exts_
, mi_ext_fields_, mi_src_hash_ })
@@ -681,6 +696,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
`seq` rnf mi_anns_
`seq` rnf mi_decls_
`seq` rnf mi_extra_decls_
+ `seq` rnf mi_stub_objs_
`seq` rnf mi_top_env_
`seq` rnf mi_insts_
`seq` rnf mi_fam_insts_
@@ -844,6 +860,9 @@ set_mi_decls val iface = clear_mi_hi_bytes $ iface { mi_decls_ = val }
set_mi_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> ModIface_ phase -> ModIface_ phase
set_mi_extra_decls val iface = clear_mi_hi_bytes $ iface { mi_extra_decls_ = val }
+set_mi_stub_objs :: [ByteString] -> ModIface_ phase -> ModIface_ phase
+set_mi_stub_objs stub_objs iface = clear_mi_hi_bytes $ iface { mi_stub_objs_ = stub_objs }
+
set_mi_top_env :: Maybe IfaceTopEnv -> ModIface_ phase -> ModIface_ phase
set_mi_top_env val iface = clear_mi_hi_bytes $ iface { mi_top_env_ = val }
@@ -940,6 +959,7 @@ However, with the pragma, the correct core is generated:
{-# INLINE mi_anns #-}
{-# INLINE mi_decls #-}
{-# INLINE mi_extra_decls #-}
+{-# INLINE mi_stub_objs #-}
{-# INLINE mi_top_env #-}
{-# INLINE mi_insts #-}
{-# INLINE mi_fam_insts #-}
@@ -957,7 +977,7 @@ However, with the pragma, the correct core is generated:
pattern ModIface ::
Module -> Maybe Module -> HscSource -> Dependencies -> [Usage] ->
[IfaceExport] -> Bool -> [(OccName, Fixity)] -> IfaceWarnings ->
- [IfaceAnnotation] -> [IfaceDeclExts phase] -> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] ->
+ [IfaceAnnotation] -> [IfaceDeclExts phase] -> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> [ByteString] ->
Maybe IfaceTopEnv -> [IfaceClsInst] -> [IfaceFamInst] -> [IfaceRule] ->
AnyHpcUsage -> IfaceTrustInfo -> Bool -> [IfaceCompleteMatch] -> Maybe Docs ->
IfaceBackendExts phase -> ExtensibleFields -> Fingerprint -> IfaceBinHandle phase ->
@@ -975,6 +995,7 @@ pattern ModIface
, mi_anns
, mi_decls
, mi_extra_decls
+ , mi_stub_objs
, mi_top_env
, mi_insts
, mi_fam_insts
@@ -1001,6 +1022,7 @@ pattern ModIface
, mi_anns_ = mi_anns
, mi_decls_ = mi_decls
, mi_extra_decls_ = mi_extra_decls
+ , mi_stub_objs_ = mi_stub_objs
, mi_top_env_ = mi_top_env
, mi_insts_ = mi_insts
, mi_fam_insts_ = mi_fam_insts
=====================================
testsuite/tests/bytecode/T24634/Makefile
=====================================
@@ -2,8 +2,8 @@ TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
-bytecode-capi:
- $(TEST_HC) -c hello.c
+T24634:
+ $(TEST_HC) -c -dynamic hello.c -o hello.o
$(TEST_HC) -c -fbyte-code-and-object-code Hello.hs
$(TEST_HC) -fprefer-byte-code hello.o Main.hs
./Main
=====================================
testsuite/tests/bytecode/T24634/T24634.stdout
=====================================
@@ -0,0 +1,3 @@
+[2 of 3] Compiling Main ( Main.hs, Main.o )
+[3 of 3] Linking Main
+42
=====================================
testsuite/tests/bytecode/T24634/all.T
=====================================
@@ -1,7 +1,8 @@
test('T24634',
[extra_files(['hello.h', 'hello.c', 'Hello.hs', 'Main.hs']),
- req_interp,
- expect_broken(24634),
+ req_c,
+ req_th,
+ ignore_stderr
],
makefile_test,
- [''])
+ [])
=====================================
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/-/compare/063136e957d557a18d4bb8a2e908caa72dbb56b9...f06853e2ecdb80d6bcc09833f1c7faf1fbe65685
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/063136e957d557a18d4bb8a2e908caa72dbb56b9...f06853e2ecdb80d6bcc09833f1c7faf1fbe65685
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/20240718/012ee894/attachment-0001.html>
More information about the ghc-commits
mailing list