[Git][ghc/ghc][wip/T24634-oneshot-bytecode] store IO actions in the EPS
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Mon Sep 2 13:04:10 UTC 2024
Torsten Schmits pushed to branch wip/T24634-oneshot-bytecode at Glasgow Haskell Compiler / GHC
Commits:
4de4d0f5 by Torsten Schmits at 2024-09-02T15:03:55+02:00
store IO actions in the EPS
- - - - -
18 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/Iface/Tidy.hs
- compiler/GHC/IfaceToCore.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
- compiler/GHC/Unit/Module/ModDetails.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- ghc/GHCi/Leak.hs
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -49,8 +49,8 @@ module GHC.Driver.Main
, Messager, batchMsg, batchMultiMsg
, HscBackendAction (..), HscRecompStatus (..)
, initModDetails
- , initWholeCoreBindings
- , initWholeCoreBindingsEps
+ , ensureHomeModuleByteCode
+ , 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
@@ -296,7 +296,6 @@ import System.IO
import {-# SOURCE #-} GHC.Driver.Pipeline
import Data.Time
-import System.IO.Unsafe ( unsafeInterleaveIO )
import GHC.Iface.Env ( trace_if )
import GHC.Stg.InferTags.TagSig (seqTagSig)
import GHC.StgToCmm.Utils (IPEStats)
@@ -868,7 +867,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 +954,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,69 +991,104 @@ 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.
---
--- The laziness is necessary because this value is stored purely in a
--- 'HomeModLinkable' in the home package table, rather than some dedicated
--- mutable state that would generate bytecode on demand, so we have to call this
--- function even when we don't know that we'll need the bytecode.
---
--- In addition, the laziness has to be hidden inside 'LazyBCOs' because
--- 'Linkable' is used too generally, so that looking at the constructor to
--- decide whether to discard it when linking native code would force the thunk
--- otherwise, incurring a significant performance penalty.
---
--- This is sound because generateByteCode just depends on things already loaded
--- in the interface file.
-initWcbWithTcEnv ::
+-- | 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
+
+-- | Hydrate core bindings for a module in the home package table, for which we
+-- can obtain a 'ModDetails' with a type env.
+ensureHomeModuleByteCode ::
HscEnv ->
+ ModIface ->
+ ModLocation ->
+ ModDetails ->
+ HomeModByteCode ->
+ Maybe (IO Linkable)
+ensureHomeModuleByteCode hsc_env iface location details = \case
+ NoHomeModByteCode ->
+ loadIfaceByteCode hsc_env' iface location type_env
+ HomeModIfaceCore wcb ->
+ Just (initWholeCoreBindings hsc_env' type_env wcb)
+ HomeModByteCode bc ->
+ Just (pure bc)
+ where
+ hsc_env' = add_iface_to_hpt iface details hsc_env
+ type_env = md_types details
+
+-- | Hydrate Core bindings if the interface contains any, using the supplied
+-- type env for typechecking.
+loadIfaceByteCode ::
HscEnv ->
+ ModIface ->
+ ModLocation ->
TypeEnv ->
- Linkable ->
- IO Linkable
-initWcbWithTcEnv tc_hsc_env hsc_env type_env (Linkable utc_time this_mod uls) =
- Linkable utc_time this_mod <$> mapM go uls
+ Maybe (IO Linkable)
+loadIfaceByteCode hsc_env iface location type_env =
+ initWholeCoreBindings hsc_env type_env <$> iface_core_bindings iface location
+
+-- | 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, 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.
+initWholeCoreBindings :: HscEnv -> TypeEnv -> WholeCoreBindings -> IO Linkable
+initWholeCoreBindings 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
=====================================
@@ -1319,11 +1319,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
+ -- TODO
+ | HomeModByteCode linkable <- [mlinkable]
, bco <- linkableBCOs linkable
, spt <- bc_spt_entries bco
]
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -124,6 +124,7 @@ import Data.List.NonEmpty (NonEmpty(..))
import Data.Time ( getCurrentTime )
import GHC.Iface.Recomp
import GHC.Types.Unique.DSet
+import GHC.Unit.Module.ModDetails (ModDetails(..))
-- Simpler type synonym for actions in the pipeline monad
type P m = TPipelineClass TPhase m
@@ -248,8 +249,10 @@ 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)
- return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' })
+ let md_bytecode =
+ ensureHomeModuleByteCode hsc_env iface (ms_location summary) details
+ (homeMod_bytecode linkable)
+ return $! HomeModInfo iface details {md_bytecode} linkable
where lcl_dflags = ms_hspp_opts summary
location = ms_location 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")
+ -- TODO 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
+ -- TODO 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/Iface/Tidy.hs
=====================================
@@ -193,6 +193,7 @@ mkBootModDetailsTc logger
, md_anns = []
, md_exports = exports
, md_complete_matches = complete_matches
+ , md_bytecode = Nothing
})
where
-- Find the LocalIds in the type env that are exported
@@ -492,6 +493,7 @@ tidyProgram opts (ModGuts { mg_module = mod
, md_exports = exports
, md_anns = anns -- are already tidy
, md_complete_matches = complete_matches
+ , md_bytecode = Nothing
}
)
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -254,6 +254,7 @@ typecheckIface iface
, md_anns = anns
, md_exports = exports
, md_complete_matches = complete_matches
+ , md_bytecode = Nothing
}
}
@@ -470,6 +471,7 @@ typecheckIfacesForMerging mod ifaces tc_env_vars =
, md_anns = anns
, md_exports = exports
, md_complete_matches = complete_matches
+ , md_bytecode = Nothing
}
return (global_type_env, details)
@@ -512,6 +514,7 @@ typecheckIfaceForInstantiate nsubst iface
, md_anns = anns
, md_exports = exports
, md_complete_matches = complete_matches
+ , md_bytecode = Nothing
}
-- Note [Resolving never-exported Names]
=====================================
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
@@ -266,54 +259,40 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
-- See Note [Using Byte Code rather than Object Code for Template Haskell]
- homeModLinkable :: HomeModInfo -> Maybe Linkable
+ homeModLinkable :: HomeModInfo -> Maybe (IO Linkable)
homeModLinkable hmi =
- if ldUseByteCode opts
- then homeModInfoByteCode hmi <|> homeModInfoObject hmi
- else homeModInfoObject hmi <|> homeModInfoByteCode hmi
+ let obj = pure <$> homeModInfoObject hmi
+ bc = evalHomeModByteCode hmi
+ in if ldUseByteCode opts
+ then bc <|> obj
+ else obj <|> bc
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))
+ = do
+ lnk <- expectJust "getLinkDeps" (homeModLinkable mod_info)
+ adjust_linkable lnk
| 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)
+ 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 +317,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
=====================================
@@ -113,6 +113,7 @@ import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Directory
import System.Process
+import GHC.Unit.Module.ModDetails (ModDetails(..))
{- Note [Remote GHCi]
~~~~~~~~~~~~~~~~~~
@@ -684,10 +685,13 @@ fromEvalResult (EvalSuccess a) = return a
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
- | Just linkable <- homeModInfoByteCode hmi,
+ | 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)
+ | ModDetails {md_bytecode = Just _} <- hm_details hmi
+ -- TODO
+ = emptyModBreaks
| otherwise
= emptyModBreaks -- probably object code
=====================================
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
@@ -44,6 +50,7 @@ import GHC.Utils.Outputable
import Data.List (sortOn)
import Data.Ord
import GHC.Utils.Panic
+import GHC.Unit.Module.WholeCoreBindings (WholeCoreBindings)
-- | Information about modules in the package being compiled
data HomeModInfo = HomeModInfo
@@ -73,37 +80,67 @@ 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
+ HomeModByteCode l -> Just l
+
+-- |
+evalHomeModByteCode :: HomeModInfo -> Maybe (IO Linkable)
+evalHomeModByteCode HomeModInfo {hm_details, hm_linkable}
+ | HomeModByteCode bc <- homeMod_bytecode hm_linkable
+ = Just (pure bc)
+ | otherwise
+ = md_bytecode hm_details
+
+data HomeModByteCode =
+ NoHomeModByteCode
+ |
+ HomeModIfaceCore WholeCoreBindings
+ |
+ HomeModByteCode Linkable
+
+instance Outputable HomeModByteCode where
+ ppr = \case
+ NoHomeModByteCode -> text "no bytecode"
+ HomeModIfaceCore _ -> text "dehydrated Core"
+ HomeModByteCode linkable -> ppr linkable
{-
Note [Home module build products]
=====================================
compiler/GHC/Unit/Module/ModDetails.hs
=====================================
@@ -14,6 +14,9 @@ import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv )
import GHC.Types.TypeEnv
import GHC.Types.Annotations ( Annotation )
+import GHC.Linker.Types (Linkable)
+import GHC.Prelude
+
-- | The 'ModDetails' is essentially a cache for information in the 'ModIface'
-- for home modules only. Information relating to packages will be loaded into
-- global environments in 'ExternalPackageState'.
@@ -40,6 +43,8 @@ data ModDetails = ModDetails
, md_complete_matches :: CompleteMatches
-- ^ Complete match pragmas for this module
+
+ , md_bytecode :: !(Maybe (IO Linkable))
}
-- | Constructs an empty ModDetails
@@ -53,4 +58,5 @@ emptyModDetails = ModDetails
, md_fam_insts = []
, md_anns = []
, md_complete_matches = []
+ , md_bytecode = Nothing
}
=====================================
compiler/GHC/Unit/Module/WholeCoreBindings.hs
=====================================
@@ -27,6 +27,8 @@ import Data.Maybe (fromMaybe)
import System.FilePath (takeExtension)
{-
+TODO update
+
Note [Interface Files with Core Definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -87,7 +89,12 @@ data WholeCoreBindings = WholeCoreBindings
, wcb_foreign :: IfaceForeign
}
+instance Outputable WholeCoreBindings where
+ ppr WholeCoreBindings {wcb_module} = text "iface Core for " <+> ppr wcb_module
+
{-
+TODO update
+
Note [Foreign stubs and TH bytecode linking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
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/-/commit/4de4d0f59c2ab1757d13c6be99f7a90d1909651e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4de4d0f59c2ab1757d13c6be99f7a90d1909651e
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/20240902/e5ed8422/attachment-0001.html>
More information about the ghc-commits
mailing list