[Git][ghc/ghc][wip/torsten.schmits/cross-package-objects] PoC for loading TH bytecode from package db core bindings
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Mon May 27 15:22:37 UTC 2024
Torsten Schmits pushed to branch wip/torsten.schmits/cross-package-objects at Glasgow Haskell Compiler / GHC
Commits:
3f5cc94c by Torsten Schmits at 2024-05-27T17:22:10+02:00
PoC for loading TH bytecode from package db core bindings
- - - - -
17 changed files:
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Types.hs
- + testsuite/tests/th/cross-package/Cross.hs
- + testsuite/tests/th/cross-package/CrossDep.hs
- + testsuite/tests/th/cross-package/CrossLocal.hs
- + testsuite/tests/th/cross-package/CrossNum.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/prep.bash
Changes:
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -148,10 +148,14 @@ resolvePtr
resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
BCOPtrName nm
| Just ix <- lookupNameEnv bco_ix nm
- -> return (ResolvedBCORef ix) -- ref to another BCO in this group
+ -> do
+ putStrLn ("\ESC[34mresolve\ESC[m: name in env: " ++ showPprUnsafe nm)
+ return (ResolvedBCORef ix) -- ref to another BCO in this group
| Just (_, rhv) <- lookupNameEnv (closure_env le) nm
- -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
+ -> do
+ putStrLn ("\ESC[34mresolve\ESC[m: name in closure env: " ++ showPprUnsafe nm)
+ return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
| otherwise
-> assertPpr (isExternalName nm) (ppr nm) $
@@ -159,14 +163,20 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
let sym_to_find = nameToCLabel nm "closure"
m <- lookupHsSymbol interp pkgs_loaded nm "closure"
case m of
- Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
+ Just p -> do
+ putStrLn ("\ESC[34mresolve\ESC[m: name in libs: " ++ showPprUnsafe nm)
+ return (ResolvedBCOStaticPtr (toRemotePtr p))
Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
BCOPtrPrimOp op
- -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
+ -> do
+ putStrLn ("\ESC[34mresolve\ESC[m: primop: " ++ showPprUnsafe op)
+ ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
BCOPtrBCO bco
- -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco
+ -> do
+ putStrLn "\ESC[34mresolve\ESC[m: bco"
+ ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco
BCOPtrBreakArray breakarray
-> withForeignRef breakarray $ \ba -> return (ResolvedBCOPtrBreakArray ba)
@@ -177,6 +187,7 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
-- See Note [Looking up symbols in the relevant objects].
lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
+ putStrLn (showSDocUnsafe (text "\ESC[35mlookupHsSymbol\ESC[m:" <+> ppr nm))
massertPpr (isExternalName nm) (ppr nm)
let sym_to_find = nameToCLabel nm sym_suffix
pkg_id = moduleUnitId $ nameModule nm
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2400,7 +2400,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
stg_binds data_tycons mod_breaks
let src_span = srcLocSpan interactiveSrcLoc
- _ <- liftIO $ loadDecls interp hsc_env src_span cbc
+ _ <- liftIO $ loadDecls interp hsc_env undefined src_span cbc
{- Load static pointer table entries -}
liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
@@ -2676,7 +2676,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
[] Nothing
{- load it -}
- (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan bcos
+ (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env (initWholeCoreBindings hsc_env) srcspan bcos
{- Get the HValue for the root -}
return (expectJust "hscCompileCoreExpr'"
$ lookup (idName binding_id) fv_hvs, mods_needed, units_needed)
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -11,6 +11,7 @@ module GHC.Linker.Deps
( LinkDepsOpts (..)
, LinkDeps (..)
, getLinkDeps
+ , dbg
)
where
@@ -56,7 +57,17 @@ import Data.List (isSuffixOf)
import System.FilePath
import System.Directory
-
+import Debug.Trace (trace)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+
+dbg ::
+ MonadIO m =>
+ String ->
+ [(String, SDoc)] ->
+ m ()
+dbg desc xs =
+ liftIO $ putStrLn $ showSDocUnsafe $
+ hang (text ("\ESC[35m" ++ desc ++ "\ESC[m:")) 2 (vcat [text ("\ESC[33m" ++ desc ++ "\ESC[m:") <+> x | (desc, x) <- xs])
data LinkDepsOpts = LinkDepsOpts
{ ldObjSuffix :: !String -- ^ Suffix of .o files
@@ -143,6 +154,18 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
-- compilation) we may need to use maybe_getFileLinkable
lnks_needed <- mapM (get_linkable (ldObjSuffix opts)) mods_needed
+ dbg "get_link_deps" [
+ ("mods", ppr mods),
+ ("all_deps", ppr all_deps),
+ ("mods_s", ppr mods_s),
+ ("mods_needed", ppr mods_needed),
+ ("all_home_mods", ppr all_home_mods),
+ ("init_pkg_set", ppr init_pkg_set),
+ ("pkgs_needed", ppr pkgs_needed),
+ ("pkgs_s", ppr pkgs_s),
+ ("lnks_needed", ppr lnks_needed)
+ ]
+
return $ LinkDeps
{ ldNeededLinkables = lnks_needed
, ldAllLinkables = links_got ++ lnks_needed
@@ -160,7 +183,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
-- calculation than to compute the transitive dependency set in the same manner as oneShot mode.
-- It is also a matter of correctness to use the module graph so that dependencies between home units
- -- is resolved correctly.
+ -- are resolved correctly.
make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey)
make_deps_loop found [] = found
make_deps_loop found@(found_units, found_mods) (nk:nexts)
@@ -172,7 +195,12 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
-- See #936 and the ghci.prog007 test for why we have to continue traversing through
-- boot modules.
todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps]
- in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
+ in
+ trace (showSDocUnsafe (hang (text "\ESC[35mmake_deps_loop\ESC[m:") 2 (vcat [
+ text "trans_deps:" <+> ppr trans_deps,
+ text "deps:" <+> ppr deps
+ ]))) $
+ make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
Nothing ->
let (ModNodeKeyWithUid _ uid) = nk
in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts
@@ -185,12 +213,19 @@ 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)
+ 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
+ f mod = trace (showSDocUnsafe (hang (text "\ESC[35mget_mod_info\ESC[m:") 2 (vcat [
+ text "uid:" <+> ppr uid,
+ text "iface:" <+> ppr (mi_module iface),
+ text "dep_direct_pkgs:" <+> ppr (dep_direct_pkgs (mi_deps iface)),
+ text "mod:" <+> ppr mod
+ ]))) (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface), mod)
+
+ in f <$> mmod
Nothing -> throwProgramError opts $
text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -110,6 +110,15 @@ import System.Win32.Info (getSystemDirectory)
#endif
import GHC.Utils.Exception
+import GHC.Unit.Module.ModIface (ModIface, ModIface_ (..))
+import GHC.Unit.Module.ModDetails (ModDetails (..), emptyModDetails)
+import GHC.Unit.Finder (FindResult(..), findImportedModule)
+import qualified GHC.Data.Maybe as ME
+import GHC.Unit.Module.ModSummary (ModSummary(..))
+import GHC.Unit.Module.WholeCoreBindings (WholeCoreBindings(..))
+import GHC.Types.PkgQual (PkgQual(OtherPkg))
+import Control.Monad.Trans.State.Strict (StateT(..))
+import GHC.Utils.Misc (modificationTimeIfExists)
-- Note [Linkers and loaders]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -199,7 +208,7 @@ loadName interp hsc_env name = do
(pls, links, pkgs) <- if not (isExternalName name)
then return (pls0, [], emptyUDFM)
else do
- (pls', ok, links, pkgs) <- loadDependencies interp hsc_env pls0 noSrcSpan
+ (pls', ok, links, pkgs) <- loadDependencies interp hsc_env pls0 undefined noSrcSpan
[nameModule name]
if failed ok
then throwGhcExceptionIO (ProgramError "")
@@ -220,28 +229,37 @@ loadDependencies
:: Interp
-> HscEnv
-> LoaderState
+ -> (ModIface -> ModDetails -> Linkable -> IO Linkable)
-> SrcSpan
-> [Module]
-> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required
-- When called, the loader state must have been initialized (see `initLoaderState`)
-loadDependencies interp hsc_env pls span needed_mods = do
+loadDependencies interp hsc_env pls hydrate span needed_mods = do
let opts = initLinkDepsOpts hsc_env
-- Find what packages and linkables are required
deps <- getLinkDeps opts interp pls span needed_mods
+ (pls1, links_needed) <- loadIfacesByteCode interp hsc_env hydrate pls (ldNeededLinkables deps)
let this_pkgs_needed = ldNeededUnits deps
-- Link the packages and modules required
- pls1 <- loadPackages' interp hsc_env (ldUnits deps) pls
- (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 (ldNeededLinkables deps)
+ pls2 <- loadPackages' interp hsc_env (ldUnits deps) pls1
+ (pls3, succ) <- loadModuleLinkables interp hsc_env pls2 links_needed
let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed
- all_pkgs_loaded = pkgs_loaded pls2
+ all_pkgs_loaded = pkgs_loaded pls3
trans_pkgs_needed = unionManyUniqDSets (this_pkgs_needed : [ loaded_pkg_trans_deps pkg
| pkg_id <- uniqDSetToList this_pkgs_needed
, Just pkg <- [lookupUDFM all_pkgs_loaded pkg_id]
])
- return (pls2, succ, ldAllLinkables deps, this_pkgs_loaded)
+ dbg "loadDependencies" [
+ ("needed_mods", ppr needed_mods),
+ ("objs_loaded", ppr (objs_loaded pls3)),
+ ("links_needed pre hydrate", ppr (ldNeededLinkables deps)),
+ ("links_needed post hydrate", ppr links_needed),
+ ("ldUnits", ppr (ldUnits deps))
+ ]
+ return (pls3, succ, ldAllLinkables deps, this_pkgs_loaded)
-- | Temporarily extend the loaded env.
@@ -264,6 +282,12 @@ withExtendedLoadedEnv interp new_env action
reset_old_env = liftIO $
deleteFromLoadedEnv interp (map fst new_env)
+pprLoaderState :: LoaderState -> SDoc
+pprLoaderState pls =
+ vcat [ text "Pkgs:" <+> ppr (map loaded_pkg_uid $ eltsUDFM $ pkgs_loaded pls)
+ , text "Objs:" <+> ppr (moduleEnvElts $ objs_loaded pls)
+ , text "BCOs:" <+> ppr (moduleEnvElts $ bcos_loaded pls)
+ ]
-- | Display the loader state.
showLoaderState :: Interp -> IO SDoc
@@ -608,7 +632,7 @@ loadExpr interp hsc_env span root_ul_bco = do
-- Take lock for the actual work.
modifyLoaderState interp $ \pls0 -> do
-- Load the packages and modules required
- (pls, ok, _, _) <- loadDependencies interp hsc_env pls0 span needed_mods
+ (pls, ok, _, _) <- loadDependencies interp hsc_env pls0 undefined span needed_mods
if failed ok
then throwGhcExceptionIO (ProgramError "")
else do
@@ -661,15 +685,138 @@ initLinkDepsOpts hsc_env = opts
********************************************************************* -}
-loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
-loadDecls interp hsc_env span cbc at CompiledByteCode{..} = do
+mod_summary ::
+ Module ->
+ ModLocation ->
+ ModIface ->
+ IO ModSummary
+mod_summary mod loc at ModLocation {..} ModIface {..} = do
+ hi_date <- modificationTimeIfExists ml_hi_file
+ hie_date <- modificationTimeIfExists ml_hie_file
+ o_mod <- modificationTimeIfExists ml_obj_file
+ dyn_o_mod <- modificationTimeIfExists ml_dyn_obj_file
+ pure ModSummary {
+ ms_mod = mod,
+ ms_hsc_src = mi_hsc_src,
+ ms_hspp_file = undefined,
+ ms_hspp_opts = undefined,
+ ms_hspp_buf = undefined,
+ ms_location = loc,
+ ms_hs_hash = mi_src_hash,
+ ms_obj_date = o_mod,
+ ms_dyn_obj_date = dyn_o_mod,
+ ms_parsed_mod = Nothing,
+ ms_iface_date = hi_date,
+ ms_hie_date = hie_date,
+ -- TODO this needs imports parsing and is accessed by our new logic
+ ms_ghc_prim_import = False,
+ ms_textual_imps = [],
+ ms_srcimps = []
+ }
+
+loadByteCode :: ModLocation -> ModIface -> ModSummary -> IO (Maybe Linkable)
+loadByteCode loc iface mod_sum = do
+ let
+ this_mod = mi_module iface
+ if_date = fromJust $ ms_iface_date mod_sum
+ case mi_extra_decls iface of
+ Just extra_decls -> do
+ let fi = WholeCoreBindings extra_decls this_mod loc
+ return (Just (LM if_date this_mod [CoreBindings fi]))
+ _ -> pure Nothing
+
+loadIfaceByteCode ::
+ Interp ->
+ HscEnv ->
+ (ModIface -> ModDetails -> Linkable -> IO Linkable) ->
+ LoaderState ->
+ Module ->
+ IO ([Linkable], LoaderState)
+loadIfaceByteCode interp hsc_env hydrate pls mod = do
+ mb_iface <- run_ifg $ loadInterface (text "blarkh") mod (ImportByUser NotBoot)
+ imp_mod <- findImportedModule hsc_env (moduleName mod) (OtherPkg (moduleUnitId mod))
+ let pprI =
+ case mb_iface of
+ ME.Succeeded iface -> ppr (mi_module iface)
+ ME.Failed _ -> text "missing"
+ dbg "loadIfaceByteCode" [
+ ("mod", ppr mod),
+ ("iface", ppr pprI)
+ ]
+ case (imp_mod, mb_iface) of
+ (Found loc _, ME.Succeeded iface) -> do
+ let det = emptyModDetails
+ summ <- mod_summary mod loc iface
+ l <- loadByteCode loc iface summ
+ lh <- maybeToList <$> traverse (hydrate iface det) l
+ dbg "loadIfaceByteCode found" [("loc", ppr loc), ("loaded", ppr lh)]
+ pls1 <- dynLinkBCOs interp pls lh
+ pure (lh, pls1)
+ (fr, _) -> do
+ dbg "loadIfaceByteCode not found" [("result", pprI), ("impo", debugFr fr)]
+ pure ([], pls)
+ where
+ run_ifg :: forall a . IfG a -> IO a
+ run_ifg = initIfaceCheck (text "loader") hsc_env
+
+ debugFr = \case
+ Found _ _ -> text "found"
+ NoPackage u -> text "NoPackage " <+> ppr u
+ FoundMultiple _ -> text "FoundMultiple"
+ NotFound {..} -> vcat [
+ text "paths:" <+> brackets (hsep (text <$> fr_paths)),
+ text "pkg:" <+> ppr fr_pkg,
+ text "fr_mods_hidden:" <+> ppr fr_mods_hidden,
+ text "fr_pkgs_hidden:" <+> ppr fr_pkgs_hidden,
+ text "fr_unusables:" <+> ppr (ModUnusable <$> fr_unusables)
+ ]
+
+loadIfacesByteCode ::
+ Interp ->
+ HscEnv ->
+ (ModIface -> ModDetails -> Linkable -> IO Linkable) ->
+ LoaderState ->
+ [Linkable] ->
+ IO (LoaderState, [Linkable])
+loadIfacesByteCode interp hsc_env hydrate pls lnks = do
+ (lnks1, pls1) <- runStateT (traverse one mods) pls
+ pure (pls1, mconcat (lnks : lnks1))
+ where
+ one :: Module -> StateT LoaderState IO [Linkable]
+ one a = StateT (\ s -> loadIfaceByteCode interp hsc_env hydrate s a)
+ mods :: [Module]
+ mods = mconcat (bco_deps . linkableUnlinked <$> lnks)
+ bco_free_names cbc =
+ uniqDSetToList $
+ foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet (bc_bcos cbc)
+
+ bco_deps = concatMap $ \case
+ BCOs cbc _ ->
+ [
+ nameModule n |
+ n <- bco_free_names cbc,
+ isExternalName n,
+ not (isWiredInName n)
+ ]
+ _ -> []
+
+loadDecls ::
+ Interp ->
+ HscEnv ->
+ (ModIface -> ModDetails -> Linkable -> IO Linkable) ->
+ SrcSpan ->
+ CompiledByteCode ->
+ IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
+loadDecls interp hsc_env hydrate span cbc at CompiledByteCode{..} = do
+ putStrLn "\ESC[36mstart loadDecls\ESC[m"
-- Initialise the linker (if it's not been done already)
initLoaderState interp hsc_env
+ putStrLn . showSDocUnsafe =<< showLoaderState interp
-- Take lock for the actual work.
modifyLoaderState interp $ \pls0 -> do
-- Link the packages and modules required
- (pls, ok, links_needed, units_needed) <- loadDependencies interp hsc_env pls0 span needed_mods
+ (pls, ok, links_needed, units_needed) <- loadDependencies interp hsc_env pls0 hydrate span needed_mods
if failed ok
then throwGhcExceptionIO (ProgramError "")
else do
@@ -708,7 +855,7 @@ loadModule :: Interp -> HscEnv -> Module -> IO ()
loadModule interp hsc_env mod = do
initLoaderState interp hsc_env
modifyLoaderState_ interp $ \pls -> do
- (pls', ok, _, _) <- loadDependencies interp hsc_env pls noSrcSpan [mod]
+ (pls', ok, _, _) <- loadDependencies interp hsc_env pls undefined noSrcSpan [mod]
if failed ok
then throwGhcExceptionIO (ProgramError "could not load module")
else return pls'
@@ -731,10 +878,16 @@ loadModuleLinkables interp hsc_env pls linkables
-- Load objects first; they can't depend on BCOs
(pls1, ok_flag) <- loadObjects interp hsc_env pls objs
+ dbg "loadModuleLinkables" [
+ ("objs", ppr objs),
+ ("bcos", ppr bcos)
+ ]
+
if failed ok_flag then
return (pls1, Failed)
else do
pls2 <- dynLinkBCOs interp pls1 bcos
+ dbg "after dynLinkBCOs" [("loader state", pprLoaderState pls2)]
return (pls2, Succeeded)
@@ -886,6 +1039,7 @@ rmDupLinkables already ls
dynLinkBCOs :: Interp -> LoaderState -> [Linkable] -> IO LoaderState
dynLinkBCOs interp pls bcos = do
+ dbg "start dynLinkBCOs" []
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
@@ -911,6 +1065,13 @@ dynLinkBCOs interp pls bcos = do
-- Wrap finalizers on the ones we want to keep
new_binds <- makeForeignNamedHValueRefs interp to_add
+ putStrLn (showSDocUnsafe (hang (text "\ESC[35mdynLinkBCOs\ESC[m:") 2 (vcat [
+ text "names_and_refs:" <+> ppr (fst <$> names_and_refs),
+ text "to_add:" <+> ppr (fst <$> to_add),
+ text "to_drop:" <+> ppr (fst <$> to_drop),
+ text "new_binds:" <+> ppr (fst <$> new_binds)
+ ])))
+
let ce2 = extendClosureEnv (closure_env le2) new_binds
return $! pls1 { linker_env = le2 { closure_env = ce2 } }
@@ -1088,6 +1249,11 @@ loadPackages' interp hsc_env new_pks pls = do
foldM link_one pkgs new_pkgs
link_one pkgs new_pkg
+ | new_pkg == stringToUnitId "dep-1.0"
+ = do
+ putStrLn "\ESC[31mskip loading dep!!\ESC[m"
+ pure pkgs
+
| new_pkg `elemUDFM` pkgs -- Already linked
= return pkgs
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -442,7 +442,8 @@ initObjLinker :: Interp -> IO ()
initObjLinker interp = interpCmd interp InitLinker
lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))
-lookupSymbol interp str = withSymbolCache interp str $
+lookupSymbol interp str = withSymbolCache interp str $ do
+ putStrLn ("\ESC[35mlookupSymbol\ESC[m: " ++ unpackFS str)
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
@@ -454,7 +455,8 @@ lookupSymbol interp str = withSymbolCache interp str $
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
-lookupSymbolInDLL interp dll str = withSymbolCache interp str $
+lookupSymbolInDLL interp dll str = withSymbolCache interp str $ do
+ putStrLn ("\ESC[35mlookupSymbolInDLL\ESC[m: " ++ unpackFS str)
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))
@@ -518,6 +520,7 @@ loadDLL interp str = interpCmd interp (LoadDLL str)
loadArchive :: Interp -> String -> IO ()
loadArchive interp path = do
+ putStrLn ("\ESC[35mloadArchive\ESC[m: " ++ path)
path' <- canonicalizePath path -- Note [loadObj and relative paths]
interpCmd interp (LoadArchive path')
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -29,6 +29,7 @@ module GHC.Tc.Gen.Splice(
finishTH, runTopSplice
) where
+import GHC.Linker.Loader (showLoaderState)
import GHC.Prelude
import GHC.Driver.Errors
@@ -1259,6 +1260,11 @@ runMeta' show_code ppr_hs run_and_convert expr
--
-- See Note [Exceptions in TH]
let expr_span = getLocA expr
+ ; interp <- tcGetInterp
+ ; liftIO $ putStrLn (showSDocUnsafe (hang (text "\ESC[35mrunMeta'\ESC[m:") 2 (vcat [
+ text "needed_mods:" <+> ppr needed_mods
+ ])))
+ ; liftIO (putStrLn . showSDocUnsafe =<< showLoaderState interp)
; recordThNeededRuntimeDeps needed_mods needed_pkgs
; either_tval <- tryAllM $
setSrcSpan expr_span $ -- Set the span so that qLocation can
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -547,14 +547,14 @@ pprHomeUnitEnv uid env =
Note [Multiple Home Units]
~~~~~~~~~~~~~~~~~~~~~~~~~~
The basic idea of multiple home units is quite simple. Instead of allowing one
-home unit, you can multiple home units
+home unit, you can have multiple home units.
The flow:
1. Dependencies between units are specified between each other in the normal manner,
a unit is identified by the -this-unit-id flag and dependencies specified by
the normal -package-id flag.
-2. Downsweep is augmented to know to know how to look for dependencies in any home unit.
+2. Downsweep is augmented to know how to look for dependencies in any home unit.
3. The rest of the compiler is modified appropriately to offset paths to the right places.
4. --make mode can parallelise between home units and multiple units are allowed to produce linkables.
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -277,7 +277,7 @@ data GenInstantiatedUnit unit
-- an InstantiatedUnit. This string is completely private to GHC
-- and is just used to get a unique.
instUnitFS :: !FastString,
- -- | Cached unique of 'unitFS'.
+ -- | Cached unique of 'instUnitFS'.
instUnitKey :: !Unique,
-- | The (indefinite) unit being instantiated.
instUnitInstanceOf :: !unit,
=====================================
testsuite/tests/th/cross-package/Cross.hs
=====================================
@@ -0,0 +1,11 @@
+{-# language TemplateHaskell #-}
+
+module Main where
+
+import CrossLocal (splc)
+
+a :: Int
+a = $(splc)
+
+main :: IO ()
+main = putStrLn (show a)
=====================================
testsuite/tests/th/cross-package/CrossDep.hs
=====================================
@@ -0,0 +1,4 @@
+module CrossDep where
+
+dep :: Int
+dep = 9681
=====================================
testsuite/tests/th/cross-package/CrossLocal.hs
=====================================
@@ -0,0 +1,12 @@
+{-# language PackageImports #-}
+
+module CrossLocal where
+
+import Language.Haskell.TH (ExpQ)
+import Language.Haskell.TH.Syntax (lift)
+-- just to be sure that the file isn't accidentally picked up locally
+import "dep" CrossDep (dep)
+import CrossNum (num)
+
+splc :: ExpQ
+splc = lift @_ @Int (num + dep)
=====================================
testsuite/tests/th/cross-package/CrossNum.hs
=====================================
@@ -0,0 +1,4 @@
+module CrossNum where
+
+num :: Int
+num = 48332
=====================================
testsuite/tests/th/cross-package/CrossPackage.stdout
=====================================
@@ -0,0 +1 @@
+58013
=====================================
testsuite/tests/th/cross-package/Makefile
=====================================
@@ -0,0 +1,8 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: CrossPackage
+CrossPackage:
+ # TODO do we need the filter-out?
+ ./prep.bash "$(TEST_HC)" " $(filter-out -rtsopts, $(TEST_HC_OPTS))" "$(GHC_PKG)"
=====================================
testsuite/tests/th/cross-package/all.T
=====================================
@@ -0,0 +1,11 @@
+test(
+ 'CrossPackage',
+ [
+ pre_cmd('$MAKE -s --no-print-directory CrossPackage'),
+ extra_files(['Cross.hs', 'CrossLocal.hs', 'CrossDep.hs', 'CrossNum.hs', 'prep.bash', 'dep.conf']),
+ # ignore_stderr,
+ ],
+ # multimod_compile_and_run,
+ multimod_compile,
+ ['Cross', '-package-db db -fprefer-byte-code -fbyte-code-and-object-code -package dep -v0'],
+)
=====================================
testsuite/tests/th/cross-package/dep.conf
=====================================
@@ -0,0 +1,9 @@
+name: dep
+version: 1.0
+id: dep-1.0
+key: dep-1.0
+exposed: True
+exposed-modules: CrossDep
+import-dirs: ${pkgroot}/dep
+library-dirs: ${pkgroot}/dep
+hs-libraries: HSdep-1.0
=====================================
testsuite/tests/th/cross-package/prep.bash
=====================================
@@ -0,0 +1,32 @@
+#!/usr/bin/env bash
+
+set -eu
+
+ghc_cmd="$1"
+ghc_opts="$2"
+ghc_pkg_cmd="$3"
+
+base="$PWD"
+lib="$base/dep"
+# TODO see if this can just be stored in pwd. $lib as well
+db="$base/db"
+
+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 "$lib" "$db"
+cp CrossDep.hs dep.conf "$lib/"
+
+ghc_pkg recache
+
+ghc "-package-db ${db at Q} -hidir ${lib at Q} -O0 -this-unit-id dep-1.0 -fbyte-code-and-object-code -c ${lib at Q}/CrossDep.hs"
+$AR cqs "${lib}/libHSdep-1.0.a" "${lib}/CrossDep.o"
+
+ghc_pkg -v0 register "${lib at Q}/dep.conf"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f5cc94c96ea0dd4980e316bbcd73e7b24e66466
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f5cc94c96ea0dd4980e316bbcd73e7b24e66466
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/20240527/7fadf264/attachment-0001.html>
More information about the ghc-commits
mailing list