[Git][ghc/ghc][wip/T24634-oneshot-bytecode] store IO actions in the EPS
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Fri Aug 30 17:46:21 UTC 2024
Torsten Schmits pushed to branch wip/T24634-oneshot-bytecode at Glasgow Haskell Compiler / GHC
Commits:
e51b3592 by Torsten Schmits at 2024-08-30T19:46:05+02:00
store IO actions in the EPS
- - - - -
17 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/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
=====================================
@@ -50,7 +50,7 @@ module GHC.Driver.Main
, HscBackendAction (..), HscRecompStatus (..)
, initModDetails
, initWholeCoreBindings
- , initWholeCoreBindingsEps
+ , ensureHomeModuleByteCode
, hscMaybeWriteIface
, hscCompileCmmFile
@@ -277,7 +277,6 @@ import GHC.SysTools (initSysTools)
import GHC.SysTools.BaseDir (findTopDir)
import Data.Data hiding (Fixity, TyCon)
-import Data.Foldable (fold)
import Data.List ( nub, isPrefixOf, partition )
import qualified Data.List.NonEmpty as NE
import Control.Monad
@@ -296,7 +295,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)
@@ -955,25 +953,26 @@ 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 ::
+ ModIface ->
+ ModSummary ->
+ Maybe (Either WholeCoreBindings Linkable) ->
+ IO (MaybeValidated (Either WholeCoreBindings 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
+ Just old_linkable -> return (UpToDateItem old_linkable)
+ Nothing -> fmap Left <$> loadByteCode iface mod_sum
-loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)
+loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated WholeCoreBindings)
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))))
+ let this_mod = ms_mod mod_sum
+ wcb = WholeCoreBindings extra_decls this_mod (ms_location mod_sum)
+ (mi_foreign iface)
+ return (UpToDateItem wcb)
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
+
--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------
@@ -996,68 +995,80 @@ 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 ::
+ensureHomeModuleByteCode ::
HscEnv ->
+ ModIface ->
+ ModLocation ->
+ ModDetails ->
+ Maybe (Either WholeCoreBindings Linkable) ->
+ Maybe (IO Linkable)
+ensureHomeModuleByteCode hsc_env iface location details = \case
+ Nothing ->
+ loadHomeModuleIfaceByteCode hsc_env iface location details
+ Just (Left wcb) ->
+ Just (loadHomeModuleByteCode hsc_env iface details wcb)
+ Just (Right bc) ->
+ Just (pure bc)
+
+loadHomeModuleIfaceByteCode ::
HscEnv ->
- 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
+ ModIface ->
+ ModLocation ->
+ ModDetails ->
+ Maybe (IO Linkable)
+loadHomeModuleIfaceByteCode hsc_env iface wcb_mod_location details =
+ loadHomeModuleByteCode hsc_env iface details . wcb <$> mi_extra_decls
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
+ wcb wcb_bindings =
+ WholeCoreBindings {
+ wcb_bindings,
+ wcb_module = mi_module,
+ wcb_mod_location,
+ wcb_foreign = mi_foreign
+ }
- logger = hsc_logger hsc_env
+ ModIface {mi_module, mi_foreign, mi_extra_decls} = iface
-- | 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
+loadHomeModuleByteCode ::
+ HscEnv ->
+ ModIface ->
+ ModDetails ->
+ WholeCoreBindings ->
+ IO Linkable
+loadHomeModuleByteCode hsc_env iface details wcb =
+ initWholeCoreBindings hsc_env' wcb (md_types details)
+ where
+ hsc_env' = add_iface_to_hpt iface details hsc_env
+-- | Typecheck interface Core bindings and compile them to bytecode.
+initWholeCoreBindings :: HscEnv -> WholeCoreBindings -> TypeEnv -> IO Linkable
+initWholeCoreBindings hsc_env wcb type_env = do
+ types_var <- newIORef type_env
+ let
+ hsc_env_with_kv = hsc_env {
+ hsc_type_env_vars =
+ knotVarsFromModuleEnv (mkModuleEnv [(wcb_module, types_var)])
+ }
+ core_binds <- initIfaceCheck (text "l") 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 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
+ if_time <- modificationTimeIfExists (ml_hi_file wcb_mod_location)
+ time <- maybe getCurrentTime pure if_time
+ let parts = BCOs bcos :| [DotO fo ForeignObject | fo <- fos]
+ return $! Linkable time wcb_module parts
+ where
+ WholeCoreBindings {wcb_module, wcb_mod_location, wcb_foreign} = wcb
+
+ logger = hsc_logger hsc_env
{-
Note [ModDetails and --make mode]
=====================================
compiler/GHC/Driver/Main.hs-boot
=====================================
@@ -1,8 +1,9 @@
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 (IO)
+import GHC.Types.TypeEnv (TypeEnv)
+import GHC.Unit.Module.WholeCoreBindings (WholeCoreBindings)
-initWholeCoreBindingsEps :: HscEnv -> ModIface -> Linkable -> IO Linkable
+initWholeCoreBindings :: HscEnv -> WholeCoreBindings -> TypeEnv -> 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 -> Maybe (Either wcb Linkable) -> IO ()
addSptEntries hsc_env mlinkable =
hscAddSptEntries hsc_env
[ spt
- | linkable <- maybeToList mlinkable
+ -- TODO
+ | Right linkable <- maybeToList 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 = Just (Right 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 = Just (Right bc) } , panic "interpreter")
runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -117,6 +117,8 @@ import System.Directory
import GHC.Driver.Env.KnotVars
import GHC.Iface.Errors.Types
import Data.Function ((&))
+import {-# source #-} GHC.Driver.Main (initWholeCoreBindings)
+import GHC.Unit.Module.WholeCoreBindings (WholeCoreBindings(..))
{-
************************************************************************
@@ -474,7 +476,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 +507,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 +521,37 @@ 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]
+ old_bytecode = eps_iface_bytecode eps
+ new_bytecode = case mi_extra_decls iface of
+ Just wcb_bindings | prefer_bytecode ->
+ let type_env = mkNameEnv new_eps_decls
+ wcb = WholeCoreBindings {
+ wcb_module = mod,
+ wcb_bindings,
+ wcb_mod_location = loc,
+ wcb_foreign = mi_foreign iface
+ }
+ action = initWholeCoreBindings hsc_env wcb type_env
+ in extendModuleEnv old_bytecode mod action
+ -- Don't add an entry if the iface doesn't have @extra_decls@
+ -- so @getLinkDeps@ knows that it should load object code.
+ _ -> old_bytecode
+
; warnPprTrace bad_boot "loadInterface" (ppr mod) $
updateEps_ $ \ eps ->
if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface
@@ -536,8 +563,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 = new_bytecode,
eps_rule_base = extendRuleBaseList (eps_rule_base eps)
new_eps_rules,
eps_complete_matches
@@ -700,7 +726,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 +873,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 +903,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 +928,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,21 @@ 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
+import GHC.Unit.Module.ModDetails (ModDetails(..))
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 +260,39 @@ 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 hmi =
- if ldUseByteCode opts
- then homeModInfoByteCode hmi <|> homeModInfoObject hmi
- else homeModInfoObject hmi <|> homeModInfoByteCode hmi
+ homeModLinkable :: HomeModInfo -> Maybe (IO Linkable)
+ homeModLinkable hmi at HomeModInfo {hm_details = ModDetails {md_bytecode}} =
+ let obj = pure <$> homeModInfoObject hmi
+ in if ldUseByteCode opts
+ then md_bytecode <|> obj
+ else obj <|> md_bytecode
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/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,
+ | Just (Right 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
=====================================
@@ -44,6 +44,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,7 +74,7 @@ data HomeModInfo = HomeModInfo
-- 'ModIface' (only).
}
-homeModInfoByteCode :: HomeModInfo -> Maybe Linkable
+homeModInfoByteCode :: HomeModInfo -> Maybe (Either WholeCoreBindings Linkable)
homeModInfoByteCode = homeMod_bytecode . hm_linkable
homeModInfoObject :: HomeModInfo -> Maybe Linkable
@@ -83,25 +84,24 @@ emptyHomeModInfoLinkable :: HomeModLinkable
emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing
-- See Note [Home module build products]
-data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable)
+data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe (Either WholeCoreBindings Linkable))
, homeMod_object :: !(Maybe Linkable) }
instance Outputable HomeModLinkable where
ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2
-justBytecode :: Linkable -> HomeModLinkable
+justBytecode :: Either WholeCoreBindings Linkable -> HomeModLinkable
justBytecode lm =
- assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
- $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm }
+ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm }
justObjects :: Linkable -> HomeModLinkable
justObjects lm =
assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)
$ emptyHomeModInfoLinkable { homeMod_object = Just lm }
-bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable
+bytecodeAndObjects :: Either WholeCoreBindings Linkable -> Linkable -> HomeModLinkable
bytecodeAndObjects bc o =
- assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
+ assertPpr (linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
(HomeModLinkable (Just bc) (Just o))
=====================================
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,9 @@ getLeakIndicators hsc_env =
where
mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)]
mkWeakLinkables (HomeModLinkable mbc mo) =
- mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo]
+ -- TODO
+ undefined
+ -- mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [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/e51b3592024fd711c68347c2fd331417a5be9067
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e51b3592024fd711c68347c2fd331417a5be9067
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/20240830/6fc5463c/attachment-0001.html>
More information about the ghc-commits
mailing list