[Git][ghc/ghc][wip/T24634-oneshot-bytecode] 2 commits: Link bytecode from interface-stored core bindings in oneshot mode
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Tue Jul 30 20:51:01 UTC 2024
Torsten Schmits pushed to branch wip/T24634-oneshot-bytecode at Glasgow Haskell Compiler / GHC
Commits:
1478aa2e by Cheng Shao at 2024-07-30T22:50:47+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`).
- - - - -
96ec9368 by Torsten Schmits at 2024-07-30T22:50:47+02:00
add test
- - - - -
20 changed files:
- 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
- testsuite/tests/bytecode/T24634/Hello.hs
- testsuite/tests/bytecode/T24634/Makefile
- testsuite/tests/bytecode/T24634/T24634.stdout
- testsuite/tests/bytecode/T24634/all.T
- testsuite/tests/bytecode/T24634/hello.c → testsuite/tests/bytecode/T24634/hello_c.c
- testsuite/tests/bytecode/T24634/hello.h → testsuite/tests/bytecode/T24634/hello_c.h
- + 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.stdout
- + testsuite/tests/bytecode/T25090/all.T
Changes:
=====================================
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
@@ -976,24 +978,34 @@ 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) = do
+-- | Hydrate any WholeCoreBindings linkables into BCOs, using the supplied
+-- action to initialize the appropriate environment for type checking.
+initWcbWithTcEnv ::
+ (HscEnv, TypeEnv) ->
+ HscEnv ->
+ ModIface ->
+ ModDetails ->
+ Linkable ->
+ IO Linkable
+initWcbWithTcEnv tc_env hsc_env mod_iface details (LM utc_time this_mod uls) = do
-- If a module is compiled with -fbyte-code-and-object-code and it
-- makes use of foreign stubs, then the interface file will also
-- contain serialized stub dynamic objects, and we can simply write
@@ -1006,23 +1018,41 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = do
bytecode_uls <- for uls go
pure $ LM utc_time this_mod $ stub_uls ++ bytecode_uls
where
- go (CoreBindings fi) = do
- let act hpt = addToHpt hpt (moduleName $ mi_module mod_iface)
- (HomeModInfo mod_iface details emptyHomeModInfoLinkable)
- types_var <- newIORef (md_types details)
- let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
- let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
- -- 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.
- LoadedBCOs <$> (unsafeInterleaveIO $ do
- core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
- let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
- trace_if (hsc_logger hsc_env) (text "Generating ByteCode for" <+> (ppr this_mod))
- generateByteCode hsc_env cgi_guts (wcb_mod_location fi))
+ go (CoreBindings fi) =
+ -- 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.
+ LoadedBCOs <$> (unsafeInterleaveIO $ do
+ let (tc_hsc_env, iface_types) = tc_env
+ type_env <- newIORef iface_types
+ let
+ tc_hsc_env_with_kv = tc_hsc_env {
+ hsc_type_env_vars =
+ knotVarsFromModuleEnv (mkModuleEnv [(this_mod, type_env)])
+ }
+ core_binds <- initIfaceCheck (text "l") tc_hsc_env_with_kv $
+ typecheckWholeCoreBindings type_env fi
+ let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
+ trace_if (hsc_logger hsc_env) (text "Generating ByteCode for" <+> ppr this_mod)
+ generateByteCode hsc_env cgi_guts (wcb_mod_location fi))
go ul = return ul
+-- | 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 tc_env hsc_env iface details
+ where
+ tc_env = (add_iface_to_hpt iface details hsc_env, md_types details)
+
+-- | Hydrate core bindings for a module in the external package state.
+initWholeCoreBindingsEps :: HscEnv -> ModIface -> Linkable -> IO Linkable
+initWholeCoreBindingsEps hsc_env iface lnk = do
+ details <- genModDetails hsc_env iface
+ initWcbWithTcEnv (hsc_env, md_types details) hsc_env iface details 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
=====================================
@@ -513,11 +513,6 @@ loadInterface doc_str mod from
; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
; let final_iface = iface
- & set_mi_decls (panic "No mi_decls in PIT")
- & set_mi_insts (panic "No mi_insts in PIT")
- & 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")
; let bad_boot = mi_boot iface == IsBoot
&& isJust (lookupKnotVars (if_rec_types gbl_env) mod)
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -897,7 +897,7 @@ tcTopIfaceBindings ty_var 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
=====================================
@@ -55,6 +55,11 @@ import qualified Data.Map as M
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
@@ -69,6 +74,7 @@ data LinkDepsOpts = LinkDepsOpts
, ldWays :: !Ways -- ^ Enabled ways
, ldLoadIface :: SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface)
-- ^ Interface loader function
+ , ldHscEnv :: !HscEnv
}
data LinkDeps = LinkDeps
@@ -282,13 +288,27 @@ 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
+ initWholeCoreBindingsEps hsc_env iface $ LM t mod [CoreBindings $ WholeCoreBindings extra_decls mod undefined]
+ _ -> 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
=====================================
@@ -648,6 +648,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
=====================================
testsuite/tests/bytecode/T24634/Hello.hs
=====================================
@@ -7,7 +7,7 @@ module Hello where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
-foreign import capi "hello.h say_hello" say_hello :: IO Int
+foreign import capi "hello_c.h say_hello" say_hello :: IO Int
mkHello :: DecsQ
mkHello = do
=====================================
testsuite/tests/bytecode/T24634/Makefile
=====================================
@@ -3,7 +3,7 @@ include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
T24634:
- $(TEST_HC) -c -dynamic hello.c -o hello.o
+ $(TEST_HC) -c -dynamic hello_c.c -o hello_c.o
$(TEST_HC) -c -fbyte-code-and-object-code Hello.hs
- $(TEST_HC) -fprefer-byte-code hello.o Main.hs
+ $(TEST_HC) -fbyte-code-and-object-code -fprefer-byte-code hello_c.o Main.hs
./Main
=====================================
testsuite/tests/bytecode/T24634/T24634.stdout
=====================================
@@ -1,3 +1,3 @@
-[2 of 3] Compiling Main ( Main.hs, Main.o )
+[2 of 3] Compiling Main ( Main.hs, Main.o, interpreted )
[3 of 3] Linking Main
42
=====================================
testsuite/tests/bytecode/T24634/all.T
=====================================
@@ -1,8 +1,17 @@
+# Skipping this on debug compilers because of a pipeline failure in `x86_64-linux-deb12-numa-slow-validate`:
+#
+# WARNING:
+# CorePrep: silly extra arguments:
+# say_hello
+# Call stack:
+# CallStack (from HasCallStack):
+# warnPprTrace, called at compiler/GHC/CoreToStg/Prep.hs:<line>:<column> in <package-id>:GHC.CoreToStg.Prep
+
test('T24634',
- [extra_files(['hello.h', 'hello.c', 'Hello.hs', 'Main.hs']),
+ [extra_files(['hello_c.h', 'hello_c.c', 'Hello.hs', 'Main.hs']),
req_c,
req_th,
- ignore_stderr
+ when(compiler_debugged(), skip),
],
makefile_test,
[])
=====================================
testsuite/tests/bytecode/T24634/hello.c → testsuite/tests/bytecode/T24634/hello_c.c
=====================================
@@ -1,4 +1,4 @@
-#include "hello.h"
+#include "hello_c.h"
int say_hello() {
return 42;
=====================================
testsuite/tests/bytecode/T24634/hello.h → testsuite/tests/bytecode/T24634/hello_c.h
=====================================
=====================================
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 -dynamic C.hs-boot
+ $(TEST_HC) -c -fbyte-code-and-object-code -dynamic B.hs
+ $(TEST_HC) -c -fbyte-code-and-object-code -dynamic C.hs
+ $(TEST_HC) -c -fbyte-code-and-object-code -dynamic D.hs
+ $(TEST_HC) -c -fbyte-code-and-object-code -fprefer-byte-code -dynamic A.hs
+ $(TEST_HC) -fbyte-code-and-object-code -fprefer-byte-code D.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.stdout
=====================================
@@ -0,0 +1 @@
+2024
=====================================
testsuite/tests/bytecode/T25090/all.T
=====================================
@@ -0,0 +1,15 @@
+test('T25090a',
+ [extra_files(['A.hs', 'B.hs', 'C.hs-boot', 'C.hs', 'D.hs']),
+ req_th,
+ use_specs({'stdout': 'T25090.stdout'}),
+ ],
+ makefile_test,
+ [])
+
+test('T25090b',
+ [extra_files(['A.hs', 'B.hs', 'C.hs-boot', 'C.hs', 'D.hs']),
+ req_th,
+ use_specs({'stdout': 'T25090.stdout'}),
+ ],
+ makefile_test,
+ [])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e7fdd33f6b7359e149509e0b16fb076800c5fecd...96ec9368ad7852ed1b190c0bde91fcc1d2fc6dbb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e7fdd33f6b7359e149509e0b16fb076800c5fecd...96ec9368ad7852ed1b190c0bde91fcc1d2fc6dbb
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/20240730/751ffc15/attachment-0001.html>
More information about the ghc-commits
mailing list