[Git][ghc/ghc][wip/torsten.schmits/cross-package-objects] make type env available to hydrator
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Wed Jun 5 17:56:52 UTC 2024
Torsten Schmits pushed to branch wip/torsten.schmits/cross-package-objects at Glasgow Haskell Compiler / GHC
Commits:
b7451e99 by Torsten Schmits at 2024-06-05T19:56:36+02:00
make type env available to hydrator
- - - - -
5 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Loader.hs
- testsuite/tests/th/cross-package/CrossDep.hs
- testsuite/tests/th/cross-package/CrossLocal.hs
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -161,7 +161,7 @@ import GHC.StgToJS.Ids
import GHC.StgToJS.Types
import GHC.JS.Syntax
-import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings )
+import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings, tcIfaceDecls )
import GHC.Iface.Load ( ifaceStats, writeIface, flagsToIfCompression )
import GHC.Iface.Make
@@ -1004,6 +1004,20 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM
generateByteCode hsc_env cgi_guts (wcb_mod_location fi))
go ul = return ul
+hydrateOpaqueMinimal :: HscEnv -> ModIface -> Linkable -> IO Linkable
+hydrateOpaqueMinimal hsc_env mod_iface linkable = do
+ names_w_things <- initIfaceCheck (text "hydrate") hsc_env $
+ initIfaceLcl (mi_semantic_module mod_iface) (text "typecheckIface") (mi_boot mod_iface) $
+ tcIfaceDecls False (mi_decls mod_iface)
+ let type_env = mkNameEnv names_w_things
+ det = emptyModDetails {md_types = type_env}
+ initWholeCoreBindings hsc_env mod_iface det linkable
+
+hydrateOpaque :: HscEnv -> ModIface -> Linkable -> IO Linkable
+hydrateOpaque hsc_env mod_iface linkable = do
+ det <- initModDetails hsc_env mod_iface
+ initWholeCoreBindings hsc_env mod_iface det linkable
+
{-
Note [ModDetails and --make mode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2676,7 +2690,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
[] Nothing
{- load it -}
- (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env (initWholeCoreBindings hsc_env) srcspan bcos
+ (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env (hydrateOpaque hsc_env) srcspan bcos
{- Get the HValue for the root -}
return (expectJust "hscCompileCoreExpr'"
$ lookup (idName binding_id) fv_hvs, mods_needed, units_needed)
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -515,14 +515,7 @@ loadInterface doc_str mod from
; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
- ; let { final_iface = iface {
- mi_decls = panic "No mi_decls in PIT",
- mi_insts = panic "No mi_insts in PIT",
- mi_fam_insts = panic "No mi_fam_insts in PIT",
- mi_rules = panic "No mi_rules in PIT",
- mi_anns = panic "No mi_anns in PIT"
- }
- }
+ ; let final_iface = iface
; let bad_boot = mi_boot iface == IsBoot
&& isJust (lookupKnotVars (if_rec_types gbl_env) mod)
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -111,7 +111,7 @@ import System.Win32.Info (getSystemDirectory)
import GHC.Utils.Exception
import GHC.Unit.Module.ModIface (ModIface, ModIface_ (..))
-import GHC.Unit.Module.ModDetails (ModDetails (..), emptyModDetails)
+import GHC.Unit.Module.ModDetails (ModDetails (..))
import GHC.Unit.Finder (FindResult(..), findImportedModule)
import qualified GHC.Data.Maybe as ME
import GHC.Unit.Module.ModSummary (ModSummary(..))
@@ -229,7 +229,7 @@ loadDependencies
:: Interp
-> HscEnv
-> LoaderState
- -> (ModIface -> ModDetails -> Linkable -> IO Linkable)
+ -> (ModIface -> Linkable -> IO Linkable)
-> SrcSpan
-> [Module]
-> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required
@@ -728,32 +728,27 @@ loadByteCode loc iface mod_sum = do
loadIfaceByteCode ::
Interp ->
HscEnv ->
- (ModIface -> ModDetails -> Linkable -> IO Linkable) ->
+ (ModIface -> Linkable -> IO Linkable) ->
LoaderState ->
Module ->
IO ([Linkable], LoaderState)
loadIfaceByteCode interp hsc_env hydrate pls mod = do
- mb_iface <- run_ifg $ loadInterface (text "blarkh") mod (ImportByUser NotBoot)
+ iface <- run_ifg $ loadSysInterface (text "blarkh") mod
imp_mod <- findImportedModule hsc_env (moduleName mod) (OtherPkg (moduleUnitId mod))
- let pprI =
- case mb_iface of
- ME.Succeeded iface -> ppr (mi_module iface)
- ME.Failed _ -> text "missing"
dbg "loadIfaceByteCode" [
("mod", ppr mod),
- ("iface", ppr pprI)
+ ("iface", ppr (mi_module iface))
]
- case (imp_mod, mb_iface) of
- (Found loc _, ME.Succeeded iface) -> do
- let det = emptyModDetails
+ case imp_mod of
+ (Found loc _) -> do
summ <- mod_summary mod loc iface
l <- loadByteCode loc iface summ
- lh <- maybeToList <$> traverse (hydrate iface det) l
- dbg "loadIfaceByteCode found" [("loc", ppr loc), ("loaded", ppr lh)]
+ lh <- maybeToList <$> traverse (hydrate iface) l
+ dbg "loadIfaceByteCode found" [("hi", text (ml_hi_file loc)), ("loaded", ppr lh)]
pls1 <- dynLinkBCOs interp pls lh
pure (lh, pls1)
- (fr, _) -> do
- dbg "loadIfaceByteCode not found" [("result", pprI), ("impo", debugFr fr)]
+ fr -> do
+ dbg "loadIfaceByteCode not found" [("impo", debugFr fr)]
pure ([], pls)
where
run_ifg :: forall a . IfG a -> IO a
@@ -774,7 +769,7 @@ loadIfaceByteCode interp hsc_env hydrate pls mod = do
loadIfacesByteCode ::
Interp ->
HscEnv ->
- (ModIface -> ModDetails -> Linkable -> IO Linkable) ->
+ (ModIface -> Linkable -> IO Linkable) ->
LoaderState ->
[Linkable] ->
IO (LoaderState, [Linkable])
@@ -803,7 +798,7 @@ loadIfacesByteCode interp hsc_env hydrate pls lnks = do
loadDecls ::
Interp ->
HscEnv ->
- (ModIface -> ModDetails -> Linkable -> IO Linkable) ->
+ (ModIface -> Linkable -> IO Linkable) ->
SrcSpan ->
CompiledByteCode ->
IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
=====================================
testsuite/tests/th/cross-package/CrossDep.hs
=====================================
@@ -1,4 +1,6 @@
module CrossDep where
-dep :: Int
-dep = 9681
+data A = A Int
+
+dep :: A
+dep = A 9681
=====================================
testsuite/tests/th/cross-package/CrossLocal.hs
=====================================
@@ -5,8 +5,10 @@ module CrossLocal where
import Language.Haskell.TH (ExpQ)
import Language.Haskell.TH.Syntax (lift)
-- just to be sure that the file isn't accidentally picked up locally
-import "dep" CrossDep (dep)
+import "dep" CrossDep (dep, A (A))
import CrossNum (num)
splc :: ExpQ
-splc = lift @_ @Int (num + dep)
+splc = lift @_ @Int (num + d)
+ where
+ A d = dep
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b7451e99f56251adc8ab94fc30f5687ad56f4456
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b7451e99f56251adc8ab94fc30f5687ad56f4456
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/20240605/86d8477f/attachment-0001.html>
More information about the ghc-commits
mailing list