[Git][ghc/ghc][wip/T24634-oneshot-bytecode] Link bytecode from interface-stored core bindings in oneshot mode
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Tue Aug 20 21:29:54 UTC 2024
Torsten Schmits pushed to branch wip/T24634-oneshot-bytecode at Glasgow Haskell Compiler / GHC
Commits:
8a5cc05f by Cheng Shao at 2024-08-20T23:29:36+02:00
Link bytecode from interface-stored core bindings in oneshot mode
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
- - - - -
19 changed files:
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Main.hs
- + compiler/GHC/Driver/Main.hs-boot
- compiler/GHC/Iface/Load.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Unit/External.hs
- + testsuite/tests/bytecode/T24634/T24634.stdout
- + 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
+ , initWholeCoreBindingsEps
, hscMaybeWriteIface
, hscCompileCmmFile
@@ -106,6 +107,7 @@ module GHC.Driver.Main
, showModuleIndex
, hscAddSptEntries
, writeInterfaceOnlyMode
+ , loadByteCode
) where
import GHC.Prelude
@@ -275,7 +277,8 @@ import GHC.SysTools (initSysTools)
import GHC.SysTools.BaseDir (findTopDir)
import Data.Data hiding (Fixity, TyCon)
-import Data.List ( nub, isPrefixOf, partition )
+import Data.Foldable (fold)
+import Data.List ( nub, isPrefixOf, partition )
import qualified Data.List.NonEmpty as NE
import Control.Monad
import Data.IORef
@@ -975,44 +978,54 @@ loadByteCode iface mod_sum = do
-- 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
--- Hydrate any WholeCoreBindings linkables into BCOs
-initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
-initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) =
+-- | Hydrate any WholeCoreBindings linkables into BCOs, using the supplied
+-- action to initialize the appropriate environment for type checking.
+initWcbWithTcEnv ::
+ HscEnv ->
+ HscEnv ->
+ TypeEnv ->
+ Linkable ->
+ IO Linkable
+initWcbWithTcEnv tc_hsc_env hsc_env type_env (LM utc_time this_mod uls) = do
LM utc_time this_mod <$> mapM go uls
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 }
+ types_var <- newIORef type_env
+ let
+ tc_hsc_env_with_kv = tc_hsc_env {
+ hsc_type_env_vars =
+ knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
+ }
-- The bytecode generation itself is lazy because otherwise even when
-- doing recompilation checking the bytecode will be generated (which
-- slows things down a lot) the laziness is OK because generateByteCode
-- just depends on things already loaded in the interface file.
~(bcos, fos) <- unsafeInterleaveIO $ do
- core_binds <- initIfaceCheck (text "l") hsc_env' $
+ 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 (md_types details)) stubs foreign_files
+ (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
@@ -1021,6 +1034,21 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) =
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
=====================================
@@ -0,0 +1,8 @@
+module GHC.Driver.Main where
+
+import GHC.Driver.Env
+import GHC.Linker.Types
+import GHC.Prelude
+import GHC.Unit.Module.ModIface
+
+initWholeCoreBindingsEps :: HscEnv -> ModIface -> Linkable -> IO Linkable
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -536,6 +536,8 @@ 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_rule_base = extendRuleBaseList (eps_rule_base eps)
new_eps_rules,
eps_complete_matches
@@ -569,7 +571,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.
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -893,11 +893,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,6 +56,11 @@ 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
@@ -70,6 +75,7 @@ data LinkDepsOpts = LinkDepsOpts
, ldWays :: !Ways -- ^ Enabled ways
, ldLoadIface :: SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface)
-- ^ Interface loader function
+ , ldHscEnv :: !HscEnv
}
data LinkDeps = LinkDeps
@@ -283,13 +289,31 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
Found loc mod -> found loc mod
_ -> no_obj (moduleName mod)
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
- }}
+ 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 = LM t mod [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
adjust_linkable lnk
| Just new_osuf <- maybe_normal_osuf = do
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -647,6 +647,7 @@ initLinkDepsOpts hsc_env = opts
, ldUseByteCode = gopt Opt_UseBytecodeRatherThanObjects dflags
, ldMsgOpts = initIfaceMessageOpts dflags
, ldWays = ways dflags
+ , ldHscEnv = hsc_env
}
dflags = hsc_dflags hsc_env
load_iface msg mod = initIfaceCheck (text "loader") hsc_env
=====================================
compiler/GHC/Unit/External.hs
=====================================
@@ -45,6 +45,8 @@ 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
@@ -68,6 +70,7 @@ initExternalPackageState = EPS
, eps_PIT = emptyPackageIfaceTable
, eps_free_holes = emptyInstalledModuleEnv
, eps_PTE = emptyTypeEnv
+ , eps_PTT = emptyModuleEnv
, eps_inst_env = emptyInstEnv
, eps_fam_inst_env = emptyFamInstEnv
, eps_rule_base = mkRuleBase builtinRules
@@ -139,6 +142,8 @@ data ExternalPackageState
-- interface files we have sucked in. The domain of
-- the mapping is external-package modules
+ eps_PTT :: !PackageTypeTable,
+
eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated
-- from all the external-package modules
eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated
=====================================
testsuite/tests/bytecode/T24634/T24634.stdout
=====================================
@@ -0,0 +1,3 @@
+[2 of 3] Compiling Main ( Main.hs, Main.o, interpreted )
+[3 of 3] Linking Main
+42
=====================================
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/-/commit/8a5cc05f6fab63e5181be5968b313e60626b46e6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8a5cc05f6fab63e5181be5968b313e60626b46e6
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/20240820/05851556/attachment-0001.html>
More information about the ghc-commits
mailing list