[Git][ghc/ghc][wip/T24634-oneshot-bytecode] 2 commits: store IO in the EPS
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Tue Sep 3 18:59:14 UTC 2024
Torsten Schmits pushed to branch wip/T24634-oneshot-bytecode at Glasgow Haskell Compiler / GHC
Commits:
ff2e1919 by Torsten Schmits at 2024-09-03T20:24:14+02:00
store IO in the EPS
- - - - -
6ae0c945 by Torsten Schmits at 2024-09-03T20:58:11+02:00
Move lazy bytecode storage from Linkable to HomeModLinkable
This shifts the responsibility of handling the laziness properly from
the rather generic Linkable to a type that is more specific to the
domain that necessitates the laziness.
- - - - -
14 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Main.hs-boot
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Unit/External.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- ghc/GHCi/Leak.hs
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -50,7 +50,7 @@ module GHC.Driver.Main
, HscBackendAction (..), HscRecompStatus (..)
, initModDetails
, initWholeCoreBindings
- , initWholeCoreBindingsEps
+ , loadIfaceByteCode
, hscMaybeWriteIface
, hscCompileCmmFile
@@ -277,7 +277,7 @@ import GHC.SysTools (initSysTools)
import GHC.SysTools.BaseDir (findTopDir)
import Data.Data hiding (Fixity, TyCon)
-import Data.Foldable (fold)
+import Data.Functor ((<&>))
import Data.List ( nub, isPrefixOf, partition )
import qualified Data.List.NonEmpty as NE
import Control.Monad
@@ -868,7 +868,7 @@ hscRecompStatus
-- Do need linkable
-- 1. Just check whether we have bytecode/object linkables and then
-- we will decide if we need them or not.
- bc_linkable <- checkByteCode checked_iface mod_summary (homeMod_bytecode old_linkable)
+ let bc_linkable = checkByteCode checked_iface mod_summary (homeMod_bytecode old_linkable)
obj_linkable <- liftIO $ checkObjects lcl_dflags (homeMod_object old_linkable) mod_summary
trace_if (hsc_logger hsc_env) (vcat [text "BCO linkable", nest 2 (ppr bc_linkable), text "Object Linkable", ppr obj_linkable])
@@ -955,25 +955,21 @@ checkObjects dflags mb_old_linkable summary = do
-- | Check to see if we can reuse the old linkable, by this point we will
-- have just checked that the old interface matches up with the source hash, so
-- no need to check that again here
-checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable)
-checkByteCode iface mod_sum mb_old_linkable =
- case mb_old_linkable of
- Just old_linkable
- | not (linkableIsNativeCodeOnly old_linkable)
- -> return $ (UpToDateItem old_linkable)
- _ -> loadByteCode iface mod_sum
-
-loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)
-loadByteCode iface mod_sum = do
- let
- this_mod = ms_mod mod_sum
- 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 (ms_location mod_sum)
- (mi_foreign iface)
- return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))
- _ -> return $ outOfDateItemBecause MissingBytecode Nothing
+checkByteCode ::
+ ModIface ->
+ ModSummary ->
+ HomeModByteCode ->
+ MaybeValidated HomeModByteCode
+checkByteCode iface mod_sum = \case
+ NoHomeModByteCode -> HomeModIfaceCore <$> loadByteCode iface mod_sum
+ old_bytecode -> UpToDateItem old_bytecode
+
+loadByteCode :: ModIface -> ModSummary -> MaybeValidated WholeCoreBindings
+loadByteCode iface mod_sum =
+ case iface_core_bindings iface (ms_location mod_sum) of
+ Just wcb -> UpToDateItem wcb
+ Nothing -> outOfDateItemBecause MissingBytecode Nothing
+
--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------
@@ -996,9 +992,43 @@ initModDetails hsc_env iface =
-- in make mode, since this HMI will go into the HPT.
genModDetails hsc_env' iface
--- | If the 'Linkable' contains Core bindings loaded from an interface, replace
--- them with a lazy IO thunk that compiles them to bytecode and foreign objects,
--- using the supplied environment for type checking.
+-- | Assemble 'WholeCoreBindings' if the interface contains Core bindings.
+iface_core_bindings :: ModIface -> ModLocation -> Maybe WholeCoreBindings
+iface_core_bindings iface wcb_mod_location =
+ mi_extra_decls <&> \ wcb_bindings ->
+ WholeCoreBindings {
+ wcb_bindings,
+ wcb_module = mi_module,
+ wcb_mod_location,
+ wcb_foreign = mi_foreign
+ }
+ where
+ ModIface {mi_module, mi_extra_decls, mi_foreign} = iface
+
+-- | Return an 'IO' that hydrates Core bindings and compiles them to bytecode if
+-- the interface contains any, using the supplied type env for typechecking.
+--
+-- Unlike 'initWholeCoreBindings', this does not use lazy IO.
+-- Instead, the 'IO' is only evaluated (in @get_link_deps@) when it is clear
+-- that it will be used immediately (because we're linking TH with
+-- @-fprefer-byte-code@ in oneshot mode), and the result is cached in
+-- 'LoaderState'.
+--
+-- 'initWholeCoreBindings' needs the laziness because it is used to populate
+-- 'HomeModInfo', which is done preemptively, in anticipation of downstream
+-- modules using the bytecode for TH in make mode, which might never happen.
+loadIfaceByteCode ::
+ HscEnv ->
+ ModIface ->
+ ModLocation ->
+ TypeEnv ->
+ Maybe (IO Linkable)
+loadIfaceByteCode hsc_env iface location type_env =
+ compileWholeCoreBindings hsc_env type_env <$> iface_core_bindings iface location
+
+-- | If the 'HomeModByteCode' contains Core bindings loaded from an interface,
+-- replace them with a lazy IO thunk that compiles them to bytecode and foreign
+-- objects, using the supplied environment for type checking.
--
-- The laziness is necessary because this value is stored purely in a
-- 'HomeModLinkable' in the home package table, rather than some dedicated
@@ -1012,53 +1042,97 @@ initModDetails hsc_env iface =
--
-- This is sound because generateByteCode just depends on things already loaded
-- in the interface file.
-initWcbWithTcEnv ::
+initWholeCoreBindings ::
HscEnv ->
+ ModIface ->
+ ModLocation ->
+ ModDetails ->
+ HomeModByteCode ->
+ IO HomeModByteCode
+initWholeCoreBindings hsc_env iface location details = \case
+ NoHomeModByteCode
+ -- REVIEW this is not necessary, but maybe nice to be safe anyway?
+ -- If @NoHomeModByteCode@ was returned by @runHscBackendPhase@, it's because
+ -- @-fprefer@ is off.
+ | gopt Opt_UseBytecodeRatherThanObjects (hsc_dflags hsc_env) ->
+ maybe (pure NoHomeModByteCode) defer $
+ loadIfaceByteCode hsc_env' iface location type_env
+ | otherwise ->
+ pure NoHomeModByteCode
+ HomeModIfaceCore wcb ->
+ defer $ compileWholeCoreBindings hsc_env' type_env wcb
+ HomeModByteCode bc ->
+ pure (HomeModByteCode bc)
+ HomeModLazyByteCode bc ->
+ pure (HomeModLazyByteCode bc)
+ where
+ hsc_env' = add_iface_to_hpt iface details hsc_env
+ type_env = md_types details
+
+ -- Run an IO lazily and wrap its result in a lazy datacon, so that the IO
+ -- is executed only when 'HomeModLazyByteCode' is pattern-matched and the
+ -- value inside is forced.
+ defer = fmap HomeModLazyByteCode . unsafeInterleaveIO
+
+-- | Hydrate interface Core bindings and compile them to bytecode.
+--
+-- This consists of:
+--
+-- 1. Running a typechecking step to insert the global names that were removed
+-- when the interface was written or were unavailable due to boot import
+-- cycles, converting the bindings to 'CoreBind'.
+--
+-- 2. Restoring the foreign build inputs from their serialized format, resulting
+-- in a set of foreign import stubs and source files added via
+-- 'qAddForeignFilePath'.
+--
+-- 3. Generating bytecode and foreign objects from the results of the previous
+-- steps using the usual pipeline actions.
+--
+-- 4. Wrapping the build products in 'Linkable' with the proper modification
+-- time obtained from the interface.
+compileWholeCoreBindings ::
HscEnv ->
TypeEnv ->
- Linkable ->
+ WholeCoreBindings ->
IO Linkable
-initWcbWithTcEnv tc_hsc_env hsc_env type_env (Linkable utc_time this_mod uls) =
- Linkable utc_time this_mod <$> mapM go uls
+compileWholeCoreBindings hsc_env type_env wcb = do
+ core_binds <- typecheck
+ (stubs, foreign_files) <- decode_foreign
+ parts <- gen_bytecode core_binds stubs foreign_files
+ linkable parts
where
- go (CoreBindings wcb at WholeCoreBindings {wcb_foreign, wcb_mod_location}) = do
- types_var <- newIORef type_env
- let
- tc_hsc_env_with_kv = tc_hsc_env {
- hsc_type_env_vars =
- knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
- }
- ~(bcos, fos) <- unsafeInterleaveIO $ do
- core_binds <- initIfaceCheck (text "l") tc_hsc_env_with_kv $
- typecheckWholeCoreBindings types_var wcb
- (stubs, foreign_files) <-
- decodeIfaceForeign logger (hsc_tmpfs hsc_env)
- (tmpDir (hsc_dflags hsc_env)) wcb_foreign
- let cgi_guts = CgInteractiveGuts this_mod core_binds
- (typeEnvTyCons type_env) stubs foreign_files
- Nothing []
- trace_if logger (text "Generating ByteCode for" <+> ppr this_mod)
- generateByteCode hsc_env cgi_guts wcb_mod_location
- pure (LazyBCOs bcos fos)
- go ul = return ul
+ typecheck = do
+ types_var <- newIORef type_env
+ let
+ tc_env = hsc_env {
+ hsc_type_env_vars =
+ knotVarsFromModuleEnv (mkModuleEnv [(wcb_module, types_var)])
+ }
+ initIfaceCheck (text "l") tc_env $
+ typecheckWholeCoreBindings types_var wcb
+
+ decode_foreign =
+ decodeIfaceForeign logger (hsc_tmpfs hsc_env)
+ (tmpDir (hsc_dflags hsc_env)) wcb_foreign
+
+ gen_bytecode core_binds stubs foreign_files = do
+ let cgi_guts = CgInteractiveGuts wcb_module core_binds
+ (typeEnvTyCons type_env) stubs foreign_files
+ Nothing []
+ trace_if logger (text "Generating ByteCode for" <+> ppr wcb_module)
+ (bcos, fos) <- generateByteCode hsc_env cgi_guts wcb_mod_location
+ pure $ BCOs bcos :| [DotO fo ForeignObject | fo <- fos]
+
+ linkable parts = do
+ if_time <- modificationTimeIfExists (ml_hi_file wcb_mod_location)
+ time <- maybe getCurrentTime pure if_time
+ return $! Linkable time wcb_module parts
+
+ WholeCoreBindings {wcb_module, wcb_mod_location, wcb_foreign} = wcb
logger = hsc_logger hsc_env
--- | Hydrate core bindings for a module in the home package table, for which we
--- can obtain a 'ModDetails'.
-initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
-initWholeCoreBindings hsc_env iface details =
- initWcbWithTcEnv (add_iface_to_hpt iface details hsc_env) hsc_env (md_types details)
-
--- | Hydrate core bindings for a module in the external package state.
--- This is used for home modules as well when compiling in oneshot mode.
-initWholeCoreBindingsEps :: HscEnv -> ModIface -> Linkable -> IO Linkable
-initWholeCoreBindingsEps hsc_env iface lnk = do
- eps <- hscEPS hsc_env
- let type_env = fold (lookupModuleEnv (eps_PTT eps) (mi_module iface))
- initWcbWithTcEnv hsc_env hsc_env type_env lnk
-
-
{-
Note [ModDetails and --make mode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Driver/Main.hs-boot
=====================================
@@ -1,8 +1,15 @@
module GHC.Driver.Main where
-import GHC.Driver.Env
-import GHC.Linker.Types
-import GHC.Prelude
-import GHC.Unit.Module.ModIface
+import GHC.Driver.Env.Types (HscEnv)
+import GHC.Linker.Types (Linkable)
+import GHC.Prelude.Basic
+import GHC.Types.TypeEnv (TypeEnv)
+import GHC.Unit.Module.Location (ModLocation)
+import GHC.Unit.Module.ModIface (ModIface)
-initWholeCoreBindingsEps :: HscEnv -> ModIface -> Linkable -> IO Linkable
+loadIfaceByteCode ::
+ HscEnv ->
+ ModIface ->
+ ModLocation ->
+ TypeEnv ->
+ Maybe (IO Linkable)
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1310,8 +1310,10 @@ upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do
-- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module
-- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I
-- am unsure if this is sound (wrt running TH splices for example).
- -- This function only does anything if the linkable produced is a BCO, which only happens with the
- -- bytecode backend, no need to guard against the backend type additionally.
+ -- This function only does anything if the linkable produced is a BCO, which
+ -- used to only happen with the bytecode backend, but with
+ -- @-fprefer-byte-code@, @HomeModInfo@ has bytecode even when generating
+ -- object code, see #25230.
addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)
(homeModInfoByteCode hmi)
@@ -1319,11 +1321,12 @@ upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do
-- | Add the entries from a BCO linkable to the SPT table, see
-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
-addSptEntries :: HscEnv -> Maybe Linkable -> IO ()
+addSptEntries :: HscEnv -> HomeModByteCode -> IO ()
addSptEntries hsc_env mlinkable =
hscAddSptEntries hsc_env
[ spt
- | linkable <- maybeToList mlinkable
+ -- This ignores lazy bytecode from interfaces, see #25230
+ | HomeModByteCode linkable <- [mlinkable]
, bco <- linkableBCOs linkable
, spt <- bc_spt_entries bco
]
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -248,7 +248,8 @@ compileOne' mHscMessage
(iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline
-- See Note [ModDetails and --make mode]
details <- initModDetails plugin_hsc_env iface
- linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable)
+ linkable' <- initWholeCoreBindings plugin_hsc_env iface
+ (ms_location summary) details (homeMod_bytecode linkable)
return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' })
where lcl_dflags = ms_hspp_opts summary
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -602,7 +602,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
if gopt Opt_ByteCodeAndObjectCode dflags
then do
bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location
- return $ emptyHomeModInfoLinkable { homeMod_bytecode = Just bc }
+ return $ emptyHomeModInfoLinkable { homeMod_bytecode = HomeModByteCode bc }
else return emptyHomeModInfoLinkable
@@ -619,7 +619,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing NoStubs []
hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location
bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location
- return ([], final_iface, emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } , panic "interpreter")
+ return ([], final_iface, emptyHomeModInfoLinkable { homeMod_bytecode = HomeModByteCode bc } , panic "interpreter")
runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -115,6 +115,7 @@ import Data.Map ( toList )
import System.FilePath
import System.Directory
import GHC.Driver.Env.KnotVars
+import {-# source #-} GHC.Driver.Main (loadIfaceByteCode)
import GHC.Iface.Errors.Types
import Data.Function ((&))
@@ -474,7 +475,7 @@ loadInterface doc_str mod from
-- Template Haskell original-name).
Succeeded (iface, loc) ->
let
- loc_doc = text loc
+ loc_doc = text (ml_hi_file loc)
in
initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $
@@ -505,6 +506,7 @@ loadInterface doc_str mod from
|| mod == gHC_PRIM)
(text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod))
; ignore_prags <- goptM Opt_IgnoreInterfacePragmas
+ ; prefer_bytecode <- goptM Opt_UseBytecodeRatherThanObjects
; new_eps_decls <- tcIfaceDecls ignore_prags (mi_decls iface)
; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
@@ -518,13 +520,34 @@ loadInterface doc_str mod from
& 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")
+ & set_mi_extra_decls (panic "No mi_extra_decls in PIT")
+ -- REVIEW can't do that because we use it for
+ -- fingerprinting.
+ -- & set_mi_foreign (panic "No mi_foreign in PIT")
- ; let bad_boot = mi_boot iface == IsBoot
+ bad_boot = mi_boot iface == IsBoot
&& isJust (lookupKnotVars (if_rec_types gbl_env) mod)
-- Warn against an EPS-updating import
-- of one's own boot file! (one-shot only)
-- See Note [Loading your own hi-boot file]
+ -- Create an IO action that loads and compiles bytecode from Core
+ -- bindings.
+ --
+ -- See Note [Interface Files with Core Definitions]
+ add_bytecode old
+ -- REVIEW in @getLinkDeps@ we fall back to bytecode when the HMI
+ -- doesn't have object code, even if the flag is not given –
+ -- what's the rule? Should we provide it unconditionally if it
+ -- exists?
+ | prefer_bytecode
+ , Just action <- loadIfaceByteCode hsc_env iface loc (mkNameEnv new_eps_decls)
+ = extendModuleEnv old mod action
+ -- Don't add an entry if the iface doesn't have @extra_decls@
+ -- so @getLinkDeps@ knows that it should load object code.
+ | otherwise
+ = old
+
; warnPprTrace bad_boot "loadInterface" (ppr mod) $
updateEps_ $ \ eps ->
if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface
@@ -536,8 +559,7 @@ loadInterface doc_str mod from
eps {
eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
- eps_PTT =
- extendModuleEnv (eps_PTT eps) mod (mkNameEnv new_eps_decls),
+ eps_iface_bytecode = add_bytecode (eps_iface_bytecode eps),
eps_rule_base = extendRuleBaseList (eps_rule_base eps)
new_eps_rules,
eps_complete_matches
@@ -700,7 +722,7 @@ computeInterface
-> SDoc
-> IsBootInterface
-> Module
- -> IO (MaybeErr MissingInterfaceError (ModIface, FilePath))
+ -> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation))
computeInterface hsc_env doc_str hi_boot_file mod0 = do
massert (not (isHoleModule mod0))
let mhome_unit = hsc_home_unit_maybe hsc_env
@@ -847,7 +869,7 @@ findAndReadIface
-- this to check the consistency of the requirements of the
-- module we read out.
-> IsBootInterface -- ^ Looking for .hi-boot or .hi file
- -> IO (MaybeErr MissingInterfaceError (ModIface, FilePath))
+ -> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation))
findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
let profile = targetProfile dflags
@@ -877,7 +899,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
let iface = case ghcPrimIfaceHook hooks of
Nothing -> ghcPrimIface
Just h -> h
- return (Succeeded (iface, "<built in interface for GHC.Prim>"))
+ return (Succeeded (iface, panic "GHC.Prim ModLocation (findAndReadIface)"))
else do
let fopts = initFinderOpts dflags
-- Look for the file
@@ -902,7 +924,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
iface loc
case r2 of
Failed sdoc -> return (Failed sdoc)
- Succeeded {} -> return $ Succeeded (iface,_fp)
+ Succeeded {} -> return $ Succeeded (iface, loc)
err -> do
trace_if logger (text "...not found")
return $ Failed $ cannotFindInterface
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -35,7 +35,6 @@ import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.WholeCoreBindings
import GHC.Unit.Module.Deps
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo
@@ -56,26 +55,20 @@ import Data.List (isSuffixOf)
import System.FilePath
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
{ ldObjSuffix :: !String -- ^ Suffix of .o files
, ldOneShotMode :: !Bool -- ^ Is the driver in one-shot mode?
- , ldModuleGraph :: !ModuleGraph -- ^ Module graph
- , ldUnitEnv :: !UnitEnv -- ^ Unit environment
+ , ldModuleGraph :: !ModuleGraph
+ , ldUnitEnv :: !UnitEnv
, ldPprOpts :: !SDocContext -- ^ Rendering options for error messages
- , ldFinderCache :: !FinderCache -- ^ Finder cache
- , ldFinderOpts :: !FinderOpts -- ^ Finder options
, 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
+ , ldFinderCache :: !FinderCache
+ , ldFinderOpts :: !FinderOpts
+ , ldLoadIface :: !(SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface))
+ , ldLoadByteCode :: !(Module -> IO (Maybe Linkable))
}
data LinkDeps = LinkDeps
@@ -269,8 +262,8 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
homeModLinkable :: HomeModInfo -> Maybe Linkable
homeModLinkable hmi =
if ldUseByteCode opts
- then homeModInfoByteCode hmi <|> homeModInfoObject hmi
- else homeModInfoObject hmi <|> homeModInfoByteCode hmi
+ then evalHomeModByteCode hmi <|> homeModInfoObject hmi
+ else homeModInfoObject hmi <|> evalHomeModByteCode hmi
get_linkable osuf mod -- A home-package module
| Just mod_info <- lookupHugByModule mod (ue_home_unit_graph unit_env)
@@ -281,39 +274,21 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
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)
+ from_bc <- ldLoadByteCode opts mod
+ maybe (fallback_no_bytecode home_unit mod) pure from_bc
where
- found loc mod
- | prefer_bytecode = do
- Succeeded iface <- ldLoadIface opts (text "load core bindings") mod
- case mi_extra_decls iface of
- Just extra_decls -> do
- t <- getCurrentTime
- let
- stubs = mi_foreign iface
- wcb = WholeCoreBindings extra_decls mod loc stubs
- linkable = Linkable t mod (pure (CoreBindings wcb))
- initWholeCoreBindingsEps hsc_env iface linkable
- _ -> 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
+
+ fallback_no_bytecode home_unit mod = do
+ let fc = ldFinderCache opts
+ let fopts = ldFinderOpts opts
+ mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
+ case mb_stuff of
+ Found loc _ -> do
+ mb_lnk <- findObjectLinkableMaybe mod loc
+ case mb_lnk of
+ Nothing -> no_obj mod
+ Just lnk -> adjust_linkable lnk
+ _ -> no_obj (moduleName mod)
adjust_linkable lnk
| Just new_osuf <- maybe_normal_osuf = do
@@ -338,9 +313,6 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
DotA fp -> panic ("adjust_ul DotA " ++ show fp)
DotDLL fp -> panic ("adjust_ul DotDLL " ++ show fp)
BCOs {} -> pure part
- LazyBCOs{} -> pure part
- CoreBindings WholeCoreBindings {wcb_module} ->
- pprPanic "Unhydrated core bindings" (ppr wcb_module)
{-
Note [Using Byte Code rather than Object Code for Template Haskell]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -76,6 +76,7 @@ import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Unit.Env
+import GHC.Unit.External (ExternalPackageState (EPS, eps_iface_bytecode))
import GHC.Unit.Module
import GHC.Unit.State as Packages
@@ -641,19 +642,23 @@ initLinkDepsOpts hsc_env = opts
, ldOneShotMode = isOneShot (ghcMode dflags)
, ldModuleGraph = hsc_mod_graph hsc_env
, ldUnitEnv = hsc_unit_env hsc_env
- , ldLoadIface = load_iface
, ldPprOpts = initSDocContext dflags defaultUserStyle
, ldFinderCache = hsc_FC hsc_env
, ldFinderOpts = initFinderOpts dflags
, ldUseByteCode = gopt Opt_UseBytecodeRatherThanObjects dflags
, ldMsgOpts = initIfaceMessageOpts dflags
, ldWays = ways dflags
- , ldHscEnv = hsc_env
+ , ldLoadIface
+ , ldLoadByteCode
}
dflags = hsc_dflags hsc_env
- load_iface msg mod = initIfaceCheck (text "loader") hsc_env
+ ldLoadIface msg mod = initIfaceCheck (text "loader") hsc_env
$ loadInterface msg mod (ImportByUser NotBoot)
+ ldLoadByteCode mod = do
+ EPS {eps_iface_bytecode} <- hscEPS hsc_env
+ sequence (lookupModuleEnv eps_iface_bytecode mod)
+
{- **********************************************************************
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -65,7 +65,6 @@ import Data.Time ( UTCTime )
import GHC.Unit.Module.Env
import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM
-import GHC.Unit.Module.WholeCoreBindings
import Data.Maybe (mapMaybe)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty as NE
@@ -284,18 +283,6 @@ data LinkablePart
| DotDLL FilePath
-- ^ Dynamically linked library file (.so, .dll, .dylib)
- | CoreBindings WholeCoreBindings
- -- ^ Serialised core which we can turn into BCOs (or object files), or
- -- used by some other backend See Note [Interface Files with Core
- -- Definitions]
-
- | LazyBCOs
- CompiledByteCode
- -- ^ Some BCOs generated on-demand when forced. This is used for
- -- WholeCoreBindings, see Note [Interface Files with Core Definitions]
- [FilePath]
- -- ^ Objects containing foreign stubs and files
-
| BCOs CompiledByteCode
-- ^ A byte-code object, lives only in memory.
@@ -308,8 +295,6 @@ instance Outputable LinkablePart where
ppr (DotA path) = text "DotA" <+> text path
ppr (DotDLL path) = text "DotDLL" <+> text path
ppr (BCOs bco) = text "BCOs" <+> ppr bco
- ppr (LazyBCOs{}) = text "LazyBCOs"
- ppr (CoreBindings {}) = text "CoreBindings"
-- | Return true if the linkable only consists of native code (no BCO)
linkableIsNativeCodeOnly :: Linkable -> Bool
@@ -350,8 +335,6 @@ isNativeCode = \case
DotA {} -> True
DotDLL {} -> True
BCOs {} -> False
- LazyBCOs{} -> False
- CoreBindings {} -> False
-- | Is the part a native library? (.so/.dll)
isNativeLib :: LinkablePart -> Bool
@@ -360,8 +343,6 @@ isNativeLib = \case
DotA {} -> True
DotDLL {} -> True
BCOs {} -> False
- LazyBCOs{} -> False
- CoreBindings {} -> False
-- | Get the FilePath of linkable part (if applicable)
linkablePartPath :: LinkablePart -> Maybe FilePath
@@ -369,8 +350,6 @@ linkablePartPath = \case
DotO fn _ -> Just fn
DotA fn -> Just fn
DotDLL fn -> Just fn
- CoreBindings {} -> Nothing
- LazyBCOs {} -> Nothing
BCOs {} -> Nothing
-- | Return the paths of all object code files (.o, .a, .so) contained in this
@@ -380,8 +359,6 @@ linkablePartNativePaths = \case
DotO fn _ -> [fn]
DotA fn -> [fn]
DotDLL fn -> [fn]
- CoreBindings {} -> []
- LazyBCOs _ fos -> fos
BCOs {} -> []
-- | Return the paths of all object files (.o) contained in this 'LinkablePart'.
@@ -390,8 +367,6 @@ linkablePartObjectPaths = \case
DotO fn _ -> [fn]
DotA _ -> []
DotDLL _ -> []
- CoreBindings {} -> []
- LazyBCOs _ fos -> fos
BCOs {} -> []
-- | Retrieve the compiled byte-code from the linkable part.
@@ -400,7 +375,6 @@ linkablePartObjectPaths = \case
linkablePartAllBCOs :: LinkablePart -> [CompiledByteCode]
linkablePartAllBCOs = \case
BCOs bco -> [bco]
- LazyBCOs bcos _ -> [bcos]
_ -> []
linkableFilter :: (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable
@@ -413,13 +387,11 @@ linkablePartNative = \case
u at DotO {} -> [u]
u at DotA {} -> [u]
u at DotDLL {} -> [u]
- LazyBCOs _ os -> [DotO f ForeignObject | f <- os]
_ -> []
linkablePartByteCode :: LinkablePart -> [LinkablePart]
linkablePartByteCode = \case
u at BCOs {} -> [u]
- LazyBCOs bcos _ -> [BCOs bcos]
_ -> []
-- | Transform the 'LinkablePart' list in this 'Linkable' to contain only
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -1275,14 +1275,14 @@ showModule mod_summary =
let interpreted =
case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of
Nothing -> panic "missing linkable"
- Just mod_info -> isJust (homeModInfoByteCode mod_info) && isNothing (homeModInfoObject mod_info)
+ Just mod_info -> homeModInfoHasByteCode mod_info && isNothing (homeModInfoObject mod_info)
return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary))
moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of
Nothing -> panic "missing linkable"
- Just mod_info -> return . isNothing $ homeModInfoByteCode mod_info
+ Just mod_info -> return . not $ homeModInfoHasByteCode mod_info
----------------------------------------------------------------------------
-- RTTI primitives
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -684,7 +684,8 @@ fromEvalResult (EvalSuccess a) = return a
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
- | Just linkable <- homeModInfoByteCode hmi,
+ -- This ignores lazy bytecode from interfaces, see #25230
+ | HomeModByteCode linkable <- homeModInfoByteCode hmi,
-- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
[cbc] <- linkableBCOs linkable
= fromMaybe emptyModBreaks (bc_breaks cbc)
=====================================
compiler/GHC/Unit/External.hs
=====================================
@@ -31,6 +31,8 @@ import GHC.Types.CompleteMatch
import GHC.Types.TypeEnv
import GHC.Types.Unique.DSet
+import GHC.Linker.Types (Linkable)
+
import Data.IORef
@@ -45,8 +47,6 @@ type PackageCompleteMatches = CompleteMatches
type PackageIfaceTable = ModuleEnv ModIface
-- Domain = modules in the imported packages
-type PackageTypeTable = ModuleEnv TypeEnv
-
-- | Constructs an empty PackageIfaceTable
emptyPackageIfaceTable :: PackageIfaceTable
emptyPackageIfaceTable = emptyModuleEnv
@@ -70,7 +70,7 @@ initExternalPackageState = EPS
, eps_PIT = emptyPackageIfaceTable
, eps_free_holes = emptyInstalledModuleEnv
, eps_PTE = emptyTypeEnv
- , eps_PTT = emptyModuleEnv
+ , eps_iface_bytecode = emptyModuleEnv
, eps_inst_env = emptyInstEnv
, eps_fam_inst_env = emptyFamInstEnv
, eps_rule_base = mkRuleBase builtinRules
@@ -142,7 +142,11 @@ data ExternalPackageState
-- interface files we have sucked in. The domain of
-- the mapping is external-package modules
- eps_PTT :: !PackageTypeTable,
+ -- | If an interface was written with @-fwrite-if-simplified-core@, this
+ -- will contain an IO action that compiles bytecode from core bindings.
+ --
+ -- See Note [Interface Files with Core Definitions]
+ eps_iface_bytecode :: !(ModuleEnv (IO Linkable)),
eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated
-- from all the external-package modules
=====================================
compiler/GHC/Unit/Home/ModInfo.hs
=====================================
@@ -1,13 +1,19 @@
+{-# LANGUAGE LambdaCase #-}
+
-- | Info about modules in the "home" unit
module GHC.Unit.Home.ModInfo
( HomeModInfo (..)
- , HomeModLinkable(..)
+ , HomeModLinkable (..)
+ , HomeModByteCode (..)
, homeModInfoObject
, homeModInfoByteCode
+ , homeModInfoHasByteCode
, emptyHomeModInfoLinkable
, justBytecode
, justObjects
, bytecodeAndObjects
+ , pureHomeModByteCode
+ , evalHomeModByteCode
, HomePackageTable
, emptyHomePackageTable
, lookupHpt
@@ -34,6 +40,7 @@ import GHC.Prelude
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module
+import GHC.Unit.Module.WholeCoreBindings (WholeCoreBindings)
import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly )
@@ -73,37 +80,79 @@ data HomeModInfo = HomeModInfo
-- 'ModIface' (only).
}
-homeModInfoByteCode :: HomeModInfo -> Maybe Linkable
+homeModInfoByteCode :: HomeModInfo -> HomeModByteCode
homeModInfoByteCode = homeMod_bytecode . hm_linkable
+homeModInfoHasByteCode :: HomeModInfo -> Bool
+homeModInfoHasByteCode hmi = case homeModInfoByteCode hmi of
+ NoHomeModByteCode -> False
+ _ -> True
+
homeModInfoObject :: HomeModInfo -> Maybe Linkable
homeModInfoObject = homeMod_object . hm_linkable
emptyHomeModInfoLinkable :: HomeModLinkable
-emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing
+emptyHomeModInfoLinkable = HomeModLinkable NoHomeModByteCode Nothing
-- See Note [Home module build products]
-data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable)
+data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !HomeModByteCode
, homeMod_object :: !(Maybe Linkable) }
instance Outputable HomeModLinkable where
ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2
-justBytecode :: Linkable -> HomeModLinkable
-justBytecode lm =
- assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
- $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm }
+justBytecode :: HomeModByteCode -> HomeModLinkable
+justBytecode bc =
+ emptyHomeModInfoLinkable { homeMod_bytecode = bc }
justObjects :: Linkable -> HomeModLinkable
justObjects lm =
assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)
$ emptyHomeModInfoLinkable { homeMod_object = Just lm }
-bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable
+bytecodeAndObjects :: HomeModByteCode -> Linkable -> HomeModLinkable
bytecodeAndObjects bc o =
- assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
- (HomeModLinkable (Just bc) (Just o))
-
+ assertPpr (linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
+ (HomeModLinkable bc (Just o))
+
+pureHomeModByteCode :: HomeModByteCode -> Maybe Linkable
+pureHomeModByteCode = \case
+ NoHomeModByteCode -> Nothing
+ HomeModIfaceCore _ -> Nothing
+ HomeModLazyByteCode {} -> Nothing
+ HomeModByteCode l -> Just l
+
+-- | Obtain the bytecode stored in this 'HomeModInfo', preferring the value in
+-- 'HomeModLinkable' that's already in memory before evaluating the lazy thunk
+-- in 'HomeModLazyByteCode' that hydrates and parses Core loaded from an
+-- interface.
+--
+-- This should only be called once in the module's lifecycle; afterwards, the
+-- bytecode is cached in 'LoaderState'.
+evalHomeModByteCode :: HomeModInfo -> Maybe Linkable
+evalHomeModByteCode HomeModInfo {hm_linkable}
+ | HomeModByteCode bc <- homeMod_bytecode hm_linkable
+ = Just bc
+ | HomeModLazyByteCode bc <- homeMod_bytecode hm_linkable
+ = Just bc
+ | otherwise
+ = Nothing
+
+data HomeModByteCode =
+ NoHomeModByteCode
+ |
+ HomeModIfaceCore !WholeCoreBindings
+ |
+ HomeModByteCode !Linkable
+ |
+ HomeModLazyByteCode Linkable
+
+instance Outputable HomeModByteCode where
+ ppr = \case
+ NoHomeModByteCode -> text "no bytecode"
+ HomeModIfaceCore {} -> text "dehydrated Core"
+ HomeModByteCode linkable -> ppr linkable
+ HomeModLazyByteCode {} -> text "lazy bytecode"
{-
Note [Home module build products]
=====================================
ghc/GHCi/Leak.hs
=====================================
@@ -50,7 +50,7 @@ getLeakIndicators hsc_env =
where
mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)]
mkWeakLinkables (HomeModLinkable mbc mo) =
- mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo]
+ mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [pureHomeModByteCode mbc, mo]
-- | Look at the LeakIndicators collected by an earlier call to
-- `getLeakIndicators`, and print messasges if any of them are still
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8baf8f1f3170aec0248b662e204aee884b0f8305...6ae0c945cdfab81c3f085b65f05c11cd1277f3f8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8baf8f1f3170aec0248b662e204aee884b0f8305...6ae0c945cdfab81c3f085b65f05c11cd1277f3f8
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/20240903/c261097d/attachment-0001.html>
More information about the ghc-commits
mailing list