[Git][ghc/ghc][wip/T24634-oneshot-bytecode] 3 commits: Link bytecode from interface-stored core bindings in oneshot mode
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Fri Aug 30 15:54:40 UTC 2024
Torsten Schmits pushed to branch wip/T24634-oneshot-bytecode at Glasgow Haskell Compiler / GHC
Commits:
99e6e09d by Cheng Shao at 2024-08-26T15:04:16+02:00
Link bytecode from interface-stored core bindings in oneshot mode
!13042
Part of #T25090
If the flag `-fprefer-byte-code` is given when compiling a module
containing TH, GHC will use core bindings stored in interfaces to
compile and link bytecode for splices.
This was only implemented for `--make` mode initially, so this commit
adds the same mechanism to oneshot mode (`-c`).
Metric Decrease:
MultiLayerModules
T13701
- - - - -
81b1e91c by Torsten Schmits at 2024-08-30T17:53:33+02:00
store IO actions in the EPS
- - - - -
c7d94222 by Torsten Schmits at 2024-08-30T17:53:33+02:00
store IO action in ModDetails
- - - - -
27 changed files:
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/CodeOutput.hs
- 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/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
- + testsuite/tests/bytecode/T25090/A.hs
- + testsuite/tests/bytecode/T25090/B.hs
- + testsuite/tests/bytecode/T25090/C.hs
- + testsuite/tests/bytecode/T25090/C.hs-boot
- + testsuite/tests/bytecode/T25090/D.hs
- + testsuite/tests/bytecode/T25090/Makefile
- + testsuite/tests/bytecode/T25090/T25090-debug.stderr
- + testsuite/tests/bytecode/T25090/T25090.stdout
- + testsuite/tests/bytecode/T25090/all.T
Changes:
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -602,7 +602,7 @@ toIfaceTopBind b =
in (top_bndr, rhs')
-- The sharing behaviour is currently disabled due to #22807, and relies on
- -- finished #220056 to be re-enabled.
+ -- finished #20056 to be re-enabled.
disabledDueTo22807 = True
already_has_unfolding b = not disabledDueTo22807
@@ -774,8 +774,8 @@ outside of the hs-boot loop.
Note [Interface File with Core: Sharing RHSs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-IMPORTANT: This optimisation is currently disabled due to #22027, it can be
- re-enabled once #220056 is implemented.
+IMPORTANT: This optimisation is currently disabled due to #22807, it can be
+ re-enabled once #22056 is implemented.
In order to avoid duplicating definitions for bindings which already have unfoldings
we do some minor headstands to avoid serialising the RHS of a definition if it has
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -260,7 +260,6 @@ outputForeignStubs
Maybe FilePath) -- C file created
outputForeignStubs logger tmpfs dflags unit_state mod location stubs
= do
- let stub_h = unsafeDecodeUtf $ mkStubPaths (initFinderOpts dflags) (moduleName mod) location
stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
case stubs of
@@ -276,8 +275,6 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
stub_h_output_d = pprCode h_code
stub_h_output_w = showSDoc dflags stub_h_output_d
- createDirectoryIfMissing True (takeDirectory stub_h)
-
putDumpFileMaybe logger Opt_D_dump_foreign
"Foreign export header file"
FormatC
@@ -299,9 +296,20 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
| platformMisc_libFFI $ platformMisc dflags = "#include \"rts/ghc_ffi.h\"\n"
| otherwise = ""
- stub_h_file_exists
- <- outputForeignStubs_help stub_h stub_h_output_w
- ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr
+ stub_h_file_exists <-
+ if null stub_h_output_w
+ then pure False
+ else do
+ -- The header path is computed from the module source path, which
+ -- does not exist when loading interface core bindings for Template
+ -- Haskell.
+ -- The header is only generated for foreign exports.
+ -- Since those aren't supported for TH with bytecode, we can skip
+ -- this here for now.
+ let stub_h = unsafeDecodeUtf $ mkStubPaths (initFinderOpts dflags) (moduleName mod) location
+ createDirectoryIfMissing True (takeDirectory stub_h)
+ outputForeignStubs_help stub_h stub_h_output_w
+ ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr
putDumpFileMaybe logger Opt_D_dump_foreign
"Foreign export stubs" FormatC stub_c_output_d
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -50,6 +50,7 @@ module GHC.Driver.Main
, HscBackendAction (..), HscRecompStatus (..)
, initModDetails
, initWholeCoreBindings
+ , ensureHomeModuleByteCode
, hscMaybeWriteIface
, hscCompileCmmFile
@@ -106,6 +107,7 @@ module GHC.Driver.Main
, showModuleIndex
, hscAddSptEntries
, writeInterfaceOnlyMode
+ , loadByteCode
) where
import GHC.Prelude
@@ -275,7 +277,7 @@ import GHC.SysTools (initSysTools)
import GHC.SysTools.BaseDir (findTopDir)
import Data.Data hiding (Fixity, TyCon)
-import Data.List ( nub, isPrefixOf, partition )
+import Data.List ( nub, isPrefixOf, partition )
import qualified Data.List.NonEmpty as NE
import Control.Monad
import Data.IORef
@@ -293,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)
@@ -952,46 +953,67 @@ 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
--------------------------------------------------------------
+add_iface_to_hpt :: ModIface -> ModDetails -> HscEnv -> HscEnv
+add_iface_to_hpt iface details =
+ hscUpdateHPT $ \ hpt ->
+ addToHpt hpt (moduleName (mi_module iface))
+ (HomeModInfo iface details emptyHomeModInfoLinkable)
-- Knot tying! See Note [Knot-tying typecheckIface]
-- See Note [ModDetails and --make mode]
initModDetails :: HscEnv -> ModIface -> IO ModDetails
initModDetails hsc_env iface =
fixIO $ \details' -> do
- let act hpt = addToHpt hpt (moduleName $ mi_module iface)
- (HomeModInfo iface details' emptyHomeModInfoLinkable)
- let !hsc_env' = hscUpdateHPT act hsc_env
+ let !hsc_env' = add_iface_to_hpt iface details' hsc_env
-- NB: This result is actually not that useful
-- in one-shot mode, since we're not going to do
-- any further typechecking. It's much more useful
-- in make mode, since this HMI will go into the HPT.
genModDetails hsc_env' iface
+ensureHomeModuleByteCode ::
+ HscEnv ->
+ ModIface ->
+ ModLocation ->
+ ModDetails ->
+ Maybe (Either WholeCoreBindings Linkable) ->
+ Maybe (IO Linkable)
+ensureHomeModuleByteCode hsc_env iface location details = \case
+ Nothing ->
+ loadHomeModuleByteCode hsc_env iface location details
+ Just (Left wcb) -> do
+ let hsc_env' = add_iface_to_hpt iface details hsc_env
+ Just (initWholeCoreBindings hsc_env' wcb (md_types details))
+ Just (Right bc) ->
+ Just (pure bc)
+
-- | 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.
+-- 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
@@ -1005,29 +1027,60 @@ initModDetails hsc_env iface =
--
-- This is sound because generateByteCode just depends on things already loaded
-- in the interface file.
-initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
-initWholeCoreBindings hsc_env mod_iface details (Linkable utc_time this_mod uls) =
- Linkable utc_time this_mod <$> mapM go uls
+
+-- | Hydrate core bindings for a module in the home package table, for which we
+-- can obtain a 'ModDetails'.
+loadHomeModuleByteCode ::
+ HscEnv ->
+ ModIface ->
+ ModLocation ->
+ ModDetails ->
+ Maybe (IO Linkable)
+loadHomeModuleByteCode hsc_env iface wcb_mod_location details = do
+ create <$> mi_extra_decls
+ where
+ create wcb_bindings = do
+ let
+ wcb = WholeCoreBindings {
+ wcb_bindings,
+ wcb_module = mi_module,
+ wcb_mod_location,
+ wcb_foreign = mi_foreign
+ }
+ hsc_env' = add_iface_to_hpt iface details hsc_env
+ initWholeCoreBindings hsc_env' wcb (md_types details)
+
+ ModIface {mi_module, mi_foreign, mi_extra_decls} = iface
+
+-- | Hydrate core bindings for a module in the external package state.
+-- This is used for home modules as well when compiling in oneshot mode.
+--
+-- TODO Should the Linkable time be obtained when the iface is read rather than
+-- when this @IO@ is evaluated?
+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
- go (CoreBindings wcb at WholeCoreBindings {wcb_foreign, wcb_mod_location}) = do
- types_var <- newIORef (md_types details)
- let act hpt = addToHpt hpt (moduleName $ mi_module mod_iface)
- (HomeModInfo mod_iface details emptyHomeModInfoLinkable)
- kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
- hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
- ~(bcos, fos) <- unsafeInterleaveIO $ do
- core_binds <- initIfaceCheck (text "l") hsc_env' $
- 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 (md_types details)) 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
+ WholeCoreBindings {wcb_module, wcb_mod_location, wcb_foreign} = wcb
logger = hsc_logger hsc_env
=====================================
compiler/GHC/Driver/Main.hs-boot
=====================================
@@ -0,0 +1,9 @@
+module GHC.Driver.Main where
+
+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)
+
+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,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)
- return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' })
+ let bc = ensureHomeModuleByteCode hsc_env iface (ms_location summary) details (homeMod_bytecode linkable)
+ return $! HomeModInfo iface details {md_bytecode = bc} 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 (initWholeCoreBindingsEps)
+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 = initWholeCoreBindingsEps 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,6 +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_iface_bytecode = new_bytecode,
eps_rule_base = extendRuleBaseList (eps_rule_base eps)
new_eps_rules,
eps_complete_matches
@@ -569,7 +597,7 @@ loadInterface doc_str mod from
{- Note [Loading your own hi-boot file]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Generally speaking, when compiling module M, we should not
-load M.hi boot into the EPS. After all, we are very shortly
+load M.hi-boot into the EPS. After all, we are very shortly
going to have full information about M. Moreover, see
Note [Do not update EPS with your own hi-boot] in GHC.Iface.Recomp.
@@ -698,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
@@ -845,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
@@ -875,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
@@ -900,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
=====================================
@@ -905,11 +905,11 @@ tcTopIfaceBindings :: IORef TypeEnv -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndr
-> IfL [CoreBind]
tcTopIfaceBindings ty_var ver_decls
= do
- int <- mapM tcTopBinders ver_decls
+ int <- mapM tcTopBinders ver_decls
let all_ids :: [Id] = concatMap toList int
liftIO $ modifyIORef ty_var (flip extendTypeEnvList (map AnId all_ids))
- extendIfaceIdEnv all_ids $ mapM (tc_iface_bindings) int
+ extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int
tcTopBinders :: IfaceBindingX a IfaceTopBndrInfo -> IfL (IfaceBindingX a Id)
tcTopBinders = traverse mk_top_id
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -56,20 +56,21 @@ import Data.List (isSuffixOf)
import System.FilePath
import System.Directory
+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
+ , ldFinderCache :: !FinderCache
+ , ldFinderOpts :: !FinderOpts
+ , ldLoadIface :: !(SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface))
+ , ldLoadByteCode :: !(Module -> IO (Maybe Linkable))
}
data LinkDeps = LinkDeps
@@ -260,36 +261,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 = do {
- -- ...and then find the linkable for it
- mb_lnk <- findObjectLinkableMaybe mod loc ;
- case mb_lnk of {
- Nothing -> no_obj mod ;
- Just lnk -> adjust_linkable lnk
- }}
+
+ 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
=====================================
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,18 +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
+ , 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/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
@@ -68,6 +70,7 @@ initExternalPackageState = EPS
, eps_PIT = emptyPackageIfaceTable
, eps_free_holes = emptyInstalledModuleEnv
, eps_PTE = emptyTypeEnv
+ , eps_iface_bytecode = emptyModuleEnv
, eps_inst_env = emptyInstEnv
, eps_fam_inst_env = emptyFamInstEnv
, eps_rule_base = mkRuleBase builtinRules
@@ -139,6 +142,12 @@ data ExternalPackageState
-- interface files we have sucked in. The domain of
-- the mapping is external-package modules
+ -- | 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
eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated
=====================================
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
=====================================
testsuite/tests/bytecode/T25090/A.hs
=====================================
@@ -0,0 +1,7 @@
+{-# language TemplateHaskell #-}
+module Main where
+
+import D
+
+main :: IO ()
+main = putStrLn (show ($splc :: Int))
=====================================
testsuite/tests/bytecode/T25090/B.hs
=====================================
@@ -0,0 +1,5 @@
+module B where
+
+import {-# source #-} C (C)
+
+data B = B C
=====================================
testsuite/tests/bytecode/T25090/C.hs
=====================================
@@ -0,0 +1,8 @@
+module C where
+
+import B
+
+data C = C Int
+
+b :: B
+b = B (C 2024)
=====================================
testsuite/tests/bytecode/T25090/C.hs-boot
=====================================
@@ -0,0 +1,3 @@
+module C where
+
+data C
=====================================
testsuite/tests/bytecode/T25090/D.hs
=====================================
@@ -0,0 +1,12 @@
+module D where
+
+import Language.Haskell.TH (ExpQ)
+import Language.Haskell.TH.Syntax (lift)
+import B
+import C
+
+splc :: ExpQ
+splc =
+ lift @_ @Int num
+ where
+ B (C num) = b
=====================================
testsuite/tests/bytecode/T25090/Makefile
=====================================
@@ -0,0 +1,16 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T25090a:
+ $(TEST_HC) -c -fbyte-code-and-object-code C.hs-boot
+ $(TEST_HC) -c -fbyte-code-and-object-code B.hs
+ $(TEST_HC) -c -fbyte-code-and-object-code C.hs
+ $(TEST_HC) -c -fbyte-code-and-object-code D.hs
+ $(TEST_HC) -c -fbyte-code-and-object-code -fprefer-byte-code A.hs
+ $(TEST_HC) -fbyte-code-and-object-code -fprefer-byte-code D.o C.o B.o A.o -o exe
+ ./exe
+
+T25090b:
+ $(TEST_HC) -fbyte-code-and-object-code -fprefer-byte-code A -o exe -v0
+ ./exe
=====================================
testsuite/tests/bytecode/T25090/T25090-debug.stderr
=====================================
@@ -0,0 +1,6 @@
+WARNING:
+ loadInterface
+ C
+ Call stack:
+ CallStack (from HasCallStack):
+ warnPprTrace, called at compiler/GHC/Iface/Load.hs:<line>:<column> in <package-id>:GHC.Iface.Load
=====================================
testsuite/tests/bytecode/T25090/T25090.stdout
=====================================
@@ -0,0 +1 @@
+2024
=====================================
testsuite/tests/bytecode/T25090/all.T
=====================================
@@ -0,0 +1,19 @@
+# This test compiles the boot file separately from its source file, which causes
+# a debug assertion warning.
+# Since this appears to be intentional according to the Note [Loading your own hi-boot file],
+# the warning is added to the expected stderr for debugged builds.
+def test_T25090(name):
+ assert_warn_spec = {'stderr': 'T25090-debug.stderr'}
+ extra_specs = assert_warn_spec if name == 'T25090a' and compiler_debugged() else {}
+ return test(name,
+ [extra_files(['A.hs', 'B.hs', 'C.hs-boot', 'C.hs', 'D.hs']),
+ req_th,
+ js_skip,
+ use_specs(dict(stdout = 'T25090.stdout', **extra_specs)),
+ ],
+ makefile_test,
+ [])
+
+test_T25090('T25090a')
+
+test_T25090('T25090b')
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e5bbbc18ebd955c111bf0fa4c033a00a72438b67...c7d94222a8d06d2b5b09cbf5b77e2e278cfdc952
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e5bbbc18ebd955c111bf0fa4c033a00a72438b67...c7d94222a8d06d2b5b09cbf5b77e2e278cfdc952
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/181ddb1e/attachment-0001.html>
More information about the ghc-commits
mailing list