[Git][ghc/ghc][wip/T24634-oneshot-bytecode] use the EPS type env when typechecking core bindings in oneshot mode

[Torsten Schmits (@torsten.schmits)]

Torsten Schmits pushed to branch wip/T24634-oneshot-bytecode at Glasgow Haskell Compiler / GHC


Commits:
c91ba485 by Torsten Schmits at 2024-07-25T21:00:57+02:00
use the EPS type env when typechecking core bindings in oneshot mode

- - - - -


3 changed files:

- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Main.hs-boot
- compiler/GHC/Linker/Deps.hs


Changes:

=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -50,6 +50,7 @@ module GHC.Driver.Main
     , HscBackendAction (..), HscRecompStatus (..)
     , initModDetails
     , initWholeCoreBindings
+    , initWholeCoreBindingsEps
     , hscMaybeWriteIface
     , hscCompileCmmFile
 
@@ -992,9 +993,15 @@ initModDetails hsc_env iface =
     -- 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.
+initWholeCoreBindingsWith ::
+  IO (HscEnv, TypeEnv) ->
+  HscEnv ->
+  ModIface ->
+  Linkable ->
+  IO Linkable
+initWholeCoreBindingsWith mk_tc_env hsc_env mod_iface (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
@@ -1008,22 +1015,48 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = do
   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 []
+                  (tc_hsc_env, initial_types) <- mk_tc_env
+                  types_var <- newIORef initial_types
+                  core_binds <- initIfaceCheck (text "l") tc_hsc_env $
+                                typecheckWholeCoreBindings types_var fi
+                  let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons initial_types) NoStubs Nothing []
                   trace_if (hsc_logger hsc_env) (text "Generating ByteCode for" <+> (ppr this_mod))
+                  -- TODO why are we not using tc_hsc_env here?
                   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 mod_iface details linkable at LM {linkableModule} =
+  initWholeCoreBindingsWith mk_tc_env hsc_env mod_iface linkable
+  where
+    mk_tc_env = do
+      types_var <- newIORef initial_types
+      let
+        kv = knotVarsFromModuleEnv (mkModuleEnv [(linkableModule, types_var)])
+        hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
+      pure (hsc_env', initial_types)
+      where
+        initial_types = md_types details
+        act hpt = addToHpt hpt (moduleName $ mi_module mod_iface)
+                  (HomeModInfo mod_iface details emptyHomeModInfoLinkable)
+
+-- | Hydrate core bindings for a module in the external package state.
+initWholeCoreBindingsEps :: HscEnv -> ModIface -> Linkable -> IO Linkable
+initWholeCoreBindingsEps hsc_env =
+  initWholeCoreBindingsWith mk_tc_env hsc_env
+  where
+    mk_tc_env = do
+      initial_types <- eps_PTE <$> hscEPS hsc_env
+      pure (hsc_env, initial_types)
+
+
 {-
 Note [ModDetails and --make mode]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
compiler/GHC/Driver/Main.hs-boot
=====================================
@@ -3,9 +3,6 @@ module GHC.Driver.Main where
 import GHC.Driver.Env
 import GHC.Linker.Types
 import GHC.Prelude
-import GHC.Unit.Module.ModDetails
 import GHC.Unit.Module.ModIface
 
-initModDetails :: HscEnv -> ModIface -> IO ModDetails
-
-initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
+initWholeCoreBindingsEps :: HscEnv -> ModIface -> Linkable -> IO Linkable


=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -293,9 +293,8 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
                   Succeeded iface <- ldLoadIface opts (text "makima") mod
                   case mi_extra_decls iface of
                     Just extra_decls -> do
-                      details <- initModDetails hsc_env iface
                       t <- getCurrentTime
-                      initWholeCoreBindings hsc_env iface details $ LM t mod [CoreBindings $ WholeCoreBindings extra_decls mod undefined]
+                      initWholeCoreBindingsEps hsc_env iface $ LM t mod [CoreBindings $ WholeCoreBindings extra_decls mod undefined]
                     _ -> fallback_no_bytecode loc mod
               | otherwise = fallback_no_bytecode loc mod
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c91ba485abf87cfadeaa0ad75172395625baba2c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c91ba485abf87cfadeaa0ad75172395625baba2c
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/20240725/a479b4dd/attachment-0001.html>