[Git][ghc/ghc][wip/eps-hpt] Always load home package modules into HPT
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Sat Feb 22 10:22:49 UTC 2025
Matthew Pickering pushed to branch wip/eps-hpt at Glasgow Haskell Compiler / GHC
Commits:
908b092c by Matthew Pickering at 2025-02-22T10:22:29+00:00
Always load home package modules into HPT
- - - - -
17 changed files:
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Main.hs-boot
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/IfaceToCore.hs-boot
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Home/PackageTable.hs
- compiler/GHC/Unit/Module/External/Graph.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Monad.hs
=====================================
@@ -43,7 +43,7 @@ import GHC.Prelude hiding ( read )
import GHC.Driver.DynFlags
import GHC.Driver.Env
-import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv )
+import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv, extendRuleBaseList )
import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount )
import GHC.Types.Annotations
@@ -72,6 +72,7 @@ import Data.Maybe (listToMaybe)
import Data.Word
import Control.Monad
import Control.Applicative ( Alternative(..) )
+import qualified GHC.Unit.Home.Graph as HUG
data FloatOutSwitches = FloatOutSwitches
{ floatOutLambdas :: Maybe Int -- ^ Just n <=> float lambdas to top level, if
@@ -255,7 +256,17 @@ initRuleEnv guts
; return (mkRuleEnv guts eps_rules hpt_rules) }
getExternalRuleBase :: CoreM RuleBase
-getExternalRuleBase = eps_rule_base <$> get_eps
+getExternalRuleBase = do
+ eps_rules <- eps_rule_base <$> get_eps
+ hug <- hsc_HUG <$> getHscEnv
+
+ dflags <- getDynFlags
+ hpt_rules <- liftIO $ if (isOneShot (ghcMode dflags)) then HUG.allRules hug else return []
+ let final = extendRuleBaseList eps_rules hpt_rules
+ return final
+
+
+
getNamePprCtx :: CoreM NamePprCtx
getNamePprCtx = read cr_name_ppr_ctx
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -321,7 +321,7 @@ lookupTypeInPTE hsc_env pte name = ty
then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))
else nameModule name
- ty = if isOneShot (ghcMode (hsc_dflags hsc_env))
+ ty = if False -- isOneShot (ghcMode (hsc_dflags hsc_env))
-- in one-shot, we don't use the HPT
then return $! lookupNameEnv pte name
else HUG.lookupHugByModule mod hpt >>= \case
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -45,8 +45,12 @@ module GHC.Driver.Main
, Messager, batchMsg, batchMultiMsg
, HscBackendAction (..), HscRecompStatus (..)
, initModDetails
+ , checkObjects
+ , checkByteCode
+ , LinkableTimes(..)
, initWholeCoreBindings
, loadIfaceByteCode
+ , loadIfaceByteCodeLazy
, hscMaybeWriteIface
, hscCompileCmmFile
@@ -863,13 +867,44 @@ hscRecompStatus
-> do
msg $ needsRecompileBecause THWithJS
return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface
-
+ -- In this branch, get the suitable linkables and check they are up to date
| otherwise -> do
+ recomp_linkable_result <- checkLinkables hsc_env old_linkable checked_iface lcl_dflags (ms_location mod_summary) (msToLinkableTimes mod_summary)
+ case recomp_linkable_result of
+ UpToDateItem linkable -> do
+ msg $ UpToDate
+ return $ HscUpToDate checked_iface $ linkable
+ OutOfDateItem reason _ -> do
+ msg $ NeedsRecompile reason
+ return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface
+
+
+-- NB these times exist when using --make mode but not oneshot mode.
+data LinkableTimes = LinkableTimes { o_time :: Maybe UTCTime
+ , dyn_o_time :: Maybe UTCTime
+ , bc_time :: Maybe UTCTime
+ , if_time :: Maybe UTCTime }
+
+msToLinkableTimes :: ModSummary -> LinkableTimes
+msToLinkableTimes ms = LinkableTimes { o_time = ms_obj_date ms
+ , dyn_o_time = ms_dyn_obj_date ms
+ , bc_time = ms_iface_date ms
+ , if_time = ms_iface_date ms
+ }
+
+-- Gather up the required linkables corresponding to an interface file
+-- and check that they are up to date.
+--
+-- The arguments are, the ModIface, the DynFlags the module is compiled under.
+-- The location of the .hs file and the time the linkable should be marked as being
+-- created.
+checkLinkables :: HscEnv -> HomeModLinkable -> ModIface -> DynFlags -> ModLocation -> LinkableTimes -> IO (MaybeValidated HomeModLinkable)
+checkLinkables hsc_env old_linkable iface dflags mod_loc times = do
-- Do need linkable
-- 1. Just check whether we have bytecode/object linkables and then
-- we will decide if we need them or not.
- bc_linkable <- checkByteCode checked_iface mod_summary (homeMod_bytecode old_linkable)
- obj_linkable <- liftIO $ checkObjects lcl_dflags (homeMod_object old_linkable) mod_summary
+ bc_linkable <- checkByteCode iface mod_loc (bc_time times) (homeMod_bytecode old_linkable)
+ obj_linkable <- liftIO $ checkObjects iface dflags mod_loc (homeMod_object old_linkable) times
trace_if (hsc_logger hsc_env) (vcat [text "BCO linkable", nest 2 (ppr bc_linkable), text "Object Linkable", ppr obj_linkable])
let just_bc = justBytecode <$> bc_linkable
@@ -895,7 +930,7 @@ hscRecompStatus
-- pprTraceM "recomp" (ppr just_bc <+> ppr just_o)
-- 2. Decide which of the products we will need
let recomp_linkable_result = case () of
- _ | backendCanReuseLoadedCode (backend lcl_dflags) ->
+ _ | backendCanReuseLoadedCode (backend dflags) ->
case bc_linkable of
-- If bytecode is available for Interactive then don't load object code
UpToDateItem _ -> just_bc
@@ -904,33 +939,27 @@ hscRecompStatus
UpToDateItem _ -> just_o
_ -> outOfDateItemBecause MissingBytecode Nothing
-- Need object files for making object files
- | backendWritesFiles (backend lcl_dflags) ->
- if gopt Opt_ByteCodeAndObjectCode lcl_dflags
+ | backendWritesFiles (backend dflags) ->
+ if gopt Opt_ByteCodeAndObjectCode dflags
-- We say we are going to write both, so recompile unless we have both
then definitely_both_os
-- Only load the object file unless we are saying we need to produce both.
-- Unless we do this then you can end up using byte-code for a module you specify -fobject-code for.
else just_o
- | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)
- case recomp_linkable_result of
- UpToDateItem linkable -> do
- msg $ UpToDate
- return $ HscUpToDate checked_iface $ linkable
- OutOfDateItem reason _ -> do
- msg $ NeedsRecompile reason
- return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface
+ | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend dflags)
+ return recomp_linkable_result
-- | Check that the .o files produced by compilation are already up-to-date
-- or not.
-checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)
-checkObjects dflags mb_old_linkable summary = do
+checkObjects :: ModIface -> DynFlags -> ModLocation -> Maybe Linkable -> LinkableTimes -> IO (MaybeValidated Linkable)
+checkObjects iface dflags loc mb_old_linkable times = do
let
dt_enabled = gopt Opt_BuildDynamicToo dflags
- this_mod = ms_mod summary
- mb_obj_date = ms_obj_date summary
- mb_dyn_obj_date = ms_dyn_obj_date summary
- mb_if_date = ms_iface_date summary
- obj_fn = ml_obj_file (ms_location summary)
+ this_mod = mi_module iface
+ mb_obj_date = o_time times
+ mb_dyn_obj_date = dyn_o_time times
+ mb_if_date = if_time times
+ obj_fn = ml_obj_file loc
-- dynamic-too *also* produces the dyn_o_file, so have to check
-- that's there, and if it's not, regenerate both .o and
-- .dyn_o
@@ -955,24 +984,23 @@ 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 iface mod_sum mb_old_linkable =
+checkByteCode :: ModIface -> ModLocation -> Maybe UTCTime -> Maybe Linkable -> IO (MaybeValidated Linkable)
+checkByteCode iface mod_loc if_date mb_old_linkable =
case mb_old_linkable of
Just old_linkable
| not (linkableIsNativeCodeOnly old_linkable)
-> return $ (UpToDateItem old_linkable)
- _ -> loadByteCode iface mod_sum
+ _ -> loadByteCode iface mod_loc if_date
-loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)
-loadByteCode iface mod_sum = do
+loadByteCode :: ModIface -> ModLocation -> Maybe UTCTime -> IO (MaybeValidated Linkable)
+loadByteCode iface mod_loc if_date = do
let
- this_mod = ms_mod mod_sum
- if_date = fromJust $ ms_iface_date mod_sum
+ this_mod = mi_module iface
case mi_extra_decls iface of
Just extra_decls -> do
- let fi = WholeCoreBindings extra_decls this_mod (ms_location mod_sum)
+ let fi = WholeCoreBindings extra_decls this_mod mod_loc
(mi_foreign iface)
- return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))
+ return (UpToDateItem (Linkable (fromJust if_date) this_mod (NE.singleton (CoreBindings fi))))
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
--------------------------------------------------------------
@@ -1059,6 +1087,24 @@ loadIfaceByteCode hsc_env iface location type_env =
time <- maybe getCurrentTime pure if_time
return $! Linkable time (mi_module iface) parts
+loadIfaceByteCodeLazy ::
+ HscEnv ->
+ ModIface ->
+ ModLocation ->
+ TypeEnv ->
+ Maybe (IO Linkable)
+loadIfaceByteCodeLazy hsc_env iface location type_env =
+ compile <$> iface_core_bindings iface location
+ where
+ compile decls = do
+ ~(bcos, fos) <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls
+ linkable $ NE.singleton (LazyBCOs bcos fos)
+
+ linkable parts = do
+ if_time <- modificationTimeIfExists (ml_hi_file location)
+ time <- maybe getCurrentTime pure if_time
+ return $! Linkable time (mi_module iface) parts
+
-- | 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,
-- using the supplied environment for type checking.
=====================================
compiler/GHC/Driver/Main.hs-boot
=====================================
@@ -6,6 +6,7 @@ import GHC.Prelude.Basic
import GHC.Types.TypeEnv (TypeEnv)
import GHC.Unit.Module.Location (ModLocation)
import GHC.Unit.Module.ModIface (ModIface)
+import GHC.Unit.Module.ModDetails (ModDetails)
loadIfaceByteCode ::
HscEnv ->
@@ -13,3 +14,13 @@ loadIfaceByteCode ::
ModLocation ->
TypeEnv ->
Maybe (IO Linkable)
+
+loadIfaceByteCodeLazy ::
+ HscEnv ->
+ ModIface ->
+ ModLocation ->
+ TypeEnv ->
+ Maybe (IO Linkable)
+
+initModDetails :: HscEnv -> ModIface -> IO ModDetails
+
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -388,7 +388,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
-- mode is the smushed together of all the interactive modules.
-- See Note [Why is KnotVars not a ModuleEnv]
, if_rec_types = KnotVars [mod] (\that_mod -> if that_mod == mod || isInteractiveModule mod
- then Just (return type_env)
+ then Just (return type_env, panic "mkDsEnvs:knotVars: attempting to write to type env variable")
else Nothing) }
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
NotBoot
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -10,11 +10,12 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE CPP #-}
-- | Loading interface files
module GHC.Iface.Load (
-- Importing one thing
- tcLookupImported_maybe, importDecl,
+ tcLookupImported_maybe, importDecl, lookupInKnotVars,
checkWiredInTyCon, ifCheckWiredInThing,
-- RnM/TcM functions
@@ -47,7 +48,7 @@ import GHC.Platform.Profile
import {-# SOURCE #-} GHC.IfaceToCore
( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst
- , tcIfaceAnnotations, tcIfaceCompleteMatches )
+ , tcIfaceAnnotations, tcIfaceCompleteMatches, typecheckIface )
import GHC.Driver.Config.Finder
import GHC.Driver.Env
@@ -95,7 +96,6 @@ import GHC.Types.Fixity.Env
import GHC.Types.SourceError
import GHC.Types.SourceFile
import GHC.Types.SafeHaskell
-import GHC.Types.TypeEnv
import GHC.Types.Unique.DSet
import GHC.Types.SrcLoc
import GHC.Types.TyThing
@@ -112,6 +112,7 @@ import GHC.Unit.Home.PackageTable
import GHC.Unit.Finder
import GHC.Unit.Env
import GHC.Unit.Module.External.Graph
+import GHC.Unit.Home.ModInfo
import GHC.Data.Maybe
@@ -120,12 +121,14 @@ import Data.Map ( toList )
import System.FilePath
import System.Directory
import GHC.Driver.Env.KnotVars
-import {-# source #-} GHC.Driver.Main (loadIfaceByteCode)
+import {-# source #-} GHC.Driver.Main (loadIfaceByteCode, loadIfaceByteCodeLazy)
import GHC.Iface.Errors.Types
import Data.Function ((&))
import qualified Data.Set as Set
import GHC.Unit.Module.Graph
+import GHC.Unit.Module.ModDetails
import qualified GHC.Unit.Home.Graph as HUG
+import GHC.Stack
{-
************************************************************************
@@ -162,7 +165,7 @@ tcLookupImported_maybe name
Just thing -> return (Succeeded thing)
Nothing -> tcImportDecl_maybe name }
-tcImportDecl_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing)
+tcImportDecl_maybe :: HasCallStack => Name -> TcM (MaybeErr IfaceMessage TyThing)
-- Entry point for *source-code* uses of importDecl
tcImportDecl_maybe name
| Just thing <- wiredInNameTyThing_maybe name
@@ -171,17 +174,36 @@ tcImportDecl_maybe name
-- See Note [Loading instances for wired-in things]
; return (Succeeded thing) }
| otherwise
- = initIfaceTcRn (importDecl name)
+ = do
+ initIfaceTcRn (importDecl name)
+
+lookupInKnotVars :: Name -> IfM lcl (Maybe TyThing)
+lookupInKnotVars name = do
+ { env <- getGblEnv
+ ; case lookupKnotVars (if_rec_types env) =<< (nameModule_maybe name) of -- Note [Tying the knot]
+ Just (get_type_env, _)
+ -> do -- It's defined in a module in the hs-boot loop
+ { type_env <- setLclEnv () get_type_env -- yuk
+ ; case lookupNameEnv type_env name of
+ Just thing -> return (Just thing)
+ -- See Note [Knot-tying fallback on boot]
+ Nothing -> return Nothing
+ }
-importDecl :: Name -> IfM lcl (MaybeErr IfaceMessage TyThing)
+ _ -> return Nothing }
+
+importDecl :: HasCallStack => Name -> IfM lcl (MaybeErr IfaceMessage TyThing)
-- Get the TyThing for this Name from an interface file
-- It's not a wired-in thing -- the caller caught that
importDecl name
= assert (not (isWiredInName name)) $
do { logger <- getLogger
- ; liftIO $ trace_if logger nd_doc
+ ; liftIO $ trace_if logger (nd_doc $$ callStackDoc)
- -- Load the interface, which should populate the PTE
+ -- Load the interface, which will end up in one of three places.
+ -- 1. KnotVar
+ -- 2. HPT
+ -- 3. PTE
; mb_iface <- assertPpr (isExternalName name) (ppr name) $
loadInterface nd_doc (nameModule name) ImportBySystem
; case mb_iface of
@@ -190,16 +212,21 @@ importDecl name
; Succeeded _ -> do
-- Now look it up again; this time we should find it
- { eps <- getEps
- ; case lookupTypeEnv (eps_PTE eps) name of
+ { hsc_env <- getTopEnv
+ ; res <- lookupInKnotVars name
+ ; case res of
Just thing -> return $ Succeeded thing
- Nothing -> return $ Failed $
- Can'tFindNameInInterface name
- (filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps)
- }}}
+ Nothing -> do
+ { res <- liftIO $ lookupType hsc_env name
+ ; case res of
+ Just thing -> return $ Succeeded thing
+ Nothing -> return $ Failed $
+ Can'tFindNameInInterface name
+ []--(filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps)
+ }}}}
where
nd_doc = text "Need decl for" <+> ppr name
- is_interesting thing = nameModule name == nameModule (getName thing)
+-- is_interesting thing = nameModule name == nameModule (getName thing)
{-
@@ -448,11 +475,12 @@ loadExternalGraphModule msg home_unit in_progress mod
loadExternalPackageBelow in_progress (moduleUnitId mod)
| otherwise = do
- let key = ExternalModuleKey $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod)
+ let mnk = ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod)
+ key = ExternalModuleKey mnk
graph <- eps_module_graph <$> getEps
if (not (isFullyLoadedModule key graph || Set.member key in_progress))
- then actuallyLoadExternalGraphModule msg home_unit in_progress key mod
+ then actuallyLoadExternalGraphModule msg home_unit in_progress mnk mod
else return in_progress
-- | Load the interface for a module, and all its transitive dependenices.
@@ -460,10 +488,10 @@ actuallyLoadExternalGraphModule
:: (Module -> SDoc)
-> HomeUnit
-> Set.Set ExternalKey
- -> ExternalKey
+ -> ModNodeKeyWithUid
-> Module
-> IOEnv (Env IfGblEnv lcl) (Set.Set ExternalKey)
-actuallyLoadExternalGraphModule msg home_unit in_progress key mod = do
+actuallyLoadExternalGraphModule msg home_unit in_progress mnk mod = do
dflags <- getDynFlags
let ctx = initSDocContext dflags defaultUserStyle
iface <- withIfaceErr ctx $
@@ -473,6 +501,8 @@ actuallyLoadExternalGraphModule msg home_unit in_progress key mod = do
mod_deps = dep_direct_mods deps
pkg_deps = dep_direct_pkgs deps
+ key = ExternalModuleKey mnk
+
-- Do not attempt to load the same key again when traversing
let in_progress' = Set.insert key in_progress
@@ -485,6 +515,7 @@ actuallyLoadExternalGraphModule msg home_unit in_progress key mod = do
cache_pkgs <- foldM loadExternalPackageBelow cache_mods (Set.toList pkg_deps)
registerFullyLoaded key
+ loadModuleIntoEPSGraph mnk (Set.toList cache_pkgs)
return cache_pkgs
registerFullyLoaded :: ExternalKey -> IfM lcl ()
@@ -520,6 +551,12 @@ loadPackageIntoEPSGraph uid dep_uids =
extendExternalModuleGraph (NodeExternalPackage uid
(Set.fromList dep_uids)) (eps_module_graph eps) }
+loadModuleIntoEPSGraph :: ModNodeKeyWithUid -> [ExternalKey] -> IfM lcl ()
+loadModuleIntoEPSGraph mnk ek = do
+ updateEps_ $ \eps ->
+ eps { eps_module_graph =
+ extendExternalModuleGraph (NodeHomePackage mnk ek) (eps_module_graph eps) }
+
------------------
loadInterface :: SDoc -> Module -> WhereFrom
-> IfM lcl (MaybeErr MissingInterfaceError ModIface)
@@ -588,13 +625,60 @@ loadInterface doc_str mod from
-- cause the system to load arbitrary interfaces (by supplying an appropriate
-- Template Haskell original-name).
Succeeded (iface, loc) ->
- let
- loc_doc = text (ml_hi_file loc)
- in
- initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $
+ if ( moduleUnitId mod `elem` hsc_all_home_unit_ids hsc_env
+ && mod /= gHC_PRIM )
+ then do
+ let bad_boot = mi_boot iface == IsBoot
+ && isJust (lookupKnotVars (if_rec_types gbl_env) mod)
+ if bad_boot
+ then
+ initIfaceLcl (mi_semantic_module iface) (text (ml_hi_file loc)) (mi_boot iface) $ do
+ loadHiBootSelf iface
+ else do
+ details <- liftIfG $ typecheckIface iface
+ mb_object <- liftIO $ findObjectLinkableMaybe (mi_module iface) loc
+ mb_bytecode <- liftIO $ case loadIfaceByteCodeLazy hsc_env iface loc (md_types details) of
+ Just l -> Just <$> l
+ Nothing -> return Nothing
+ let hm_linkable = HomeModLinkable mb_bytecode mb_object
+ liftIO $ trace_if logger (text "Loaded into HPT:" <+> ppr mod <+> text (show $ mi_boot iface) <+> ppr from <+> ppr (isJust mb_object) <+> ppr (isJust mb_bytecode))
+
+ liftIO $ hscInsertHPT (HomeModInfo iface details hm_linkable) hsc_env
+
+
+ return (Succeeded iface)
+ else addIfaceToEPS hsc_env doc_str loc mod iface
+ }}}}
+
+loadHiBootSelf :: ModIface -> IfL ()
+loadHiBootSelf iface
+ = do { env <- getGblEnv
+ ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas
+ ; new_eps_decls <- tcIfaceDecls ignore_prags (mi_decls iface)
+ ; case lookupKnotVars (if_rec_types env) (mi_module iface) of
+ Just (get_types, write_types) -> liftIfG $ do
+ ty_env <- get_types
+ write_types (addDeclsToPTE ty_env new_eps_decls)
+ Nothing -> pprPanic "Could not load self-boot" (ppr (mi_module iface))
+ }
- dontLeakTheHUG $ do
+liftIfG :: IfG a -> IfM lcl a
+liftIfG x = setLclEnv () x
+
+addIfaceToEPS :: HscEnv
+ -> SDoc
+ -> ModLocation
+ -> Module
+ -> ModIface
+ -> IfM lcl (MaybeErr err ModIface)
+addIfaceToEPS hsc_env doc_str loc mod iface = do
+ let loc_doc = text (ml_hi_file loc)
+ initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do
+ (_,hug) <- getEpsAndHug
+ gbl_env <- getGblEnv
+ dontLeakTheHUG $ do
+ let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)
-- Load the new ModIface into the External Package State
-- Even home-package interfaces loaded by loadInterface
-- (which only happens in OneShot mode; in Batch/Interactive
@@ -614,30 +698,29 @@ loadInterface doc_str mod from
-- Crucial assertion that checks if you are trying to load a HPT module into the EPS.
-- If you start loading HPT modules into the EPS then you get strange errors about
-- overlapping instances.
- ; massertPpr
- ((isOneShot (ghcMode (hsc_dflags hsc_env)))
- || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env
+ massertPpr
+ ( moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env
|| mod == gHC_PRIM)
(text "Attempting to load home package interface into the EPS" $$ ppr (HUG.allUnits hug) $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod))
- ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas
- ; 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)
- ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
- ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
- ; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
- ; purged_hsc_env <- getTopEnv
-
- ; let direct_deps = map (uncurry (flip ModNodeKeyWithUid)) $ (Set.toList (dep_direct_mods $ mi_deps iface))
- ; let direct_pkg_deps = Set.toList $ dep_direct_pkgs $ mi_deps iface
- ; let !module_graph_key =
+ ignore_prags <- goptM Opt_IgnoreInterfacePragmas
+ 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)
+ new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
+ new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
+ new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
+ purged_hsc_env <- getTopEnv
+
+ let direct_deps = map (uncurry (flip ModNodeKeyWithUid)) $ (Set.toList (dep_direct_mods $ mi_deps iface))
+ let direct_pkg_deps = Set.toList $ dep_direct_pkgs $ mi_deps iface
+ let !module_graph_key =
if moduleUnitId mod `elem` hsc_all_home_unit_ids hsc_env
--- ^ home unit mods in eps can only happen in oneshot mode
then Just $ NodeHomePackage (miKey iface) (map ExternalModuleKey direct_deps
++ map ExternalPackageKey direct_pkg_deps)
else Nothing
- ; let final_iface = 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")
@@ -645,7 +728,7 @@ loadInterface doc_str mod from
& set_mi_anns (panic "No mi_anns in PIT")
& set_mi_extra_decls (panic "No mi_extra_decls in PIT")
- 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)
@@ -655,7 +738,7 @@ loadInterface doc_str mod from
-- bindings.
--
-- See Note [Interface Files with Core Definitions]
- add_bytecode old
+ add_bytecode old
| Just action <- loadIfaceByteCode purged_hsc_env iface loc (mkNameEnv new_eps_decls)
= extendModuleEnv old mod action
-- Don't add an entry if the iface doesn't have 'extra_decls'
@@ -663,7 +746,7 @@ loadInterface doc_str mod from
| otherwise
= old
- ; warnPprTrace bad_boot "loadInterface" (ppr mod) $
+ warnPprTrace bad_boot "loadInterface" (ppr mod) $
updateEps_ $ \ eps ->
if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface
then eps
@@ -704,11 +787,10 @@ loadInterface doc_str mod from
(length new_eps_insts)
(length new_eps_rules) }
- ; -- invoke plugins with *full* interface, not final_iface, to ensure
- -- that plugins have access to declarations, etc.
- res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface
- ; return (Succeeded res)
- }}}}
+ -- invoke plugins with *full* interface, not final_iface, to ensure
+ -- that plugins have access to declarations, etc.
+ res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface
+ return (Succeeded res)
{- Note [Loading your own hi-boot file]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1957,7 +1957,7 @@ tcUnfoldingRhs is_compulsory toplvl name expr
get_in_scope
= do { (gbl_env, lcl_env) <- getEnvs
; let type_envs = knotVarElems (if_rec_types gbl_env)
- ; top_level_vars <- concat <$> mapM (fmap typeEnvIds . setLclEnv ()) type_envs
+ ; top_level_vars <- concat <$> mapM (fmap typeEnvIds . setLclEnv () . fst) type_envs
; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
bindingsVars (if_id_env lcl_env) `unionVarSet`
mkVarSet top_level_vars) }
@@ -1989,19 +1989,11 @@ tcIfaceGlobal name
= do { ifCheckWiredInThing thing; return thing }
| otherwise
- = do { env <- getGblEnv
- ; cur_mod <- if_mod <$> getLclEnv
- ; case lookupKnotVars (if_rec_types env) (fromMaybe cur_mod (nameModule_maybe name)) of -- Note [Tying the knot]
- Just get_type_env
- -> do -- It's defined in a module in the hs-boot loop
- { type_env <- setLclEnv () get_type_env -- yuk
- ; case lookupNameEnv type_env name of
- Just thing -> return thing
- -- See Note [Knot-tying fallback on boot]
- Nothing -> via_external
- }
-
- _ -> via_external }
+ = do { res <- setLclEnv () $ lookupInKnotVars name
+ ; case res of
+ Nothing -> via_external
+ Just res -> return res
+ }
where
via_external = do
{ hsc_env <- getTopEnv
=====================================
compiler/GHC/IfaceToCore.hs-boot
=====================================
@@ -16,6 +16,8 @@ import GHC.Unit.Types ( Module )
import GHC.Fingerprint.Type
import Data.List.NonEmpty ( NonEmpty )
+import GHC.Unit.Module.ModIface ( ModIface )
+import GHC.Unit.Module.ModDetails ( ModDetails )
tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
@@ -25,3 +27,4 @@ tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL CompleteMatches
tcIfaceDecls :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name,TyThing)]
+typecheckIface :: ModIface -> IfG ModDetails
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -632,6 +632,7 @@ get_reachable_nodes hsc_env mods
eps <- hscEPS hsc_env
let
emg = eps_module_graph eps
+ {-
get_mod_info_eps (ModNodeKeyWithUid gwib uid)
| uid == homeUnitId (ue_unsafeHomeUnit unit_env)
= case lookupModuleEnv (eps_PIT eps) (Module (RealUnit $ Definite uid) (gwib_mod gwib)) of
@@ -639,13 +640,14 @@ get_reachable_nodes hsc_env mods
Nothing -> moduleNotLoaded "(in EPS)" gwib uid
| otherwise
= return Nothing
+ -}
get_mod_key m
| moduleUnitId m == homeUnitId (ue_unsafeHomeUnit unit_env)
= ExternalModuleKey (mkModuleNk m)
| otherwise = ExternalPackageKey (moduleUnitId m)
- go get_mod_key emgNodeKey (emgReachableLoopMany emg) (map emgProject) get_mod_info_eps
+ go get_mod_key emgNodeKey (emgReachableLoopMany emg) (map emgProject) get_mod_info_hug
-- Reachability on 'ModuleGraph' (for --make mode)
| otherwise
=====================================
compiler/GHC/Tc/Instance/Family.hs
=====================================
@@ -34,7 +34,9 @@ import GHC.Tc.Utils.TcType
import GHC.Unit.External
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
+import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Deps
+import GHC.Unit.Home.ModInfo
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Name.Reader
@@ -405,9 +407,12 @@ getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
getFamInsts hpt_fam_insts mod
| Just env <- lookupModuleEnv hpt_fam_insts mod = return env
| otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
- ; eps <- getEps
- ; return (expectJust "checkFamInstConsistency" $
- lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
+ ; (eps, hug) <- getEpsAndHug
+ ; hug_res <- liftIO $ HUG.lookupHugByModule mod hug
+ ; case hug_res of
+ Just hmi -> return $ extendFamInstEnvList emptyFamInstEnv (md_fam_insts (hm_details hmi))
+ Nothing -> return (expectJust "checkFamInstConsistency" $
+ lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
where
doc = ppr mod <+> text "is a family-instance module"
@@ -541,8 +546,9 @@ tcExtendLocalFamInstEnv fam_insts thing_inside
-- Now add the instances one by one
; env <- getGblEnv
- ; (inst_env', fam_insts') <- foldlM addLocalFamInst
- (tcg_fam_inst_env env, tcg_fam_insts env)
+ ; (external_fie, home_fie) <- tcGetFamInstEnvs
+ ; (inst_env', fam_insts') <- foldlM (addLocalFamInst external_fie)
+ (home_fie, tcg_fam_insts env)
fam_insts
; let env' = env { tcg_fam_insts = fam_insts'
@@ -589,10 +595,11 @@ the current module.
-- and then add it to the home inst env
-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]
-- in GHC.Core.FamInstEnv
-addLocalFamInst :: (FamInstEnv,[FamInst])
+addLocalFamInst :: FamInstEnv
+ -> (FamInstEnv,[FamInst])
-> FamInst
-> TcM (FamInstEnv, [FamInst])
-addLocalFamInst (home_fie, my_fis) fam_inst
+addLocalFamInst external_fie (home_fie, my_fis) fam_inst
-- home_fie includes home package and this module
-- my_fies is just the ones from this module
= do { traceTc "addLocalFamInst" (ppr fam_inst)
@@ -609,8 +616,7 @@ addLocalFamInst (home_fie, my_fis) fam_inst
-- those instances which are transitively imported
-- by the current module, rather than every instance
-- we've ever seen. Fixing this is part of #13102.
- ; eps <- getEps
- ; let inst_envs = (eps_fam_inst_env eps, home_fie)
+ ; let inst_envs = (external_fie, home_fie)
home_fie' = extendFamInstEnv home_fie fam_inst
-- Check for conflicting instance decls and injectivity violations
@@ -949,5 +955,8 @@ tcGetFamInstEnvs :: TcM FamInstEnvs
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
tcGetFamInstEnvs
- = do { eps <- getEps; env <- getGblEnv
- ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
+ = do { (eps, hug) <- getEpsAndHug; env <- getGblEnv
+
+ ; dflags <- getDynFlags
+ ; (_, fam_inst) <- liftIO $ if (isOneShot (ghcMode dflags)) then HUG.allInstances hug else return (undefined, mempty)
+ ; return (eps_fam_inst_env eps `extendFamInstEnvList` fam_inst, tcg_fam_inst_env env) }
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -457,6 +457,12 @@ isTypeSubsequenceOf (t1:t1s) (t2:t2s)
************************************************************************
-}
+tcGetInstances :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> TcM (InstEnv, [FamInst])
+tcGetInstances hsc_env unitId mnwib = liftIO $ do
+ if isOneShot (ghcMode (hsc_dflags hsc_env))
+ then return (emptyInstEnv, mempty) --hugAllInstances (hsc_unit_env hsc_env)
+ else hugInstancesBelow hsc_env unitId mnwib
+
tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM ([NonEmpty ClassDefaults], TcGblEnv)
tcRnImports hsc_env import_decls
= do { (rn_imports, imp_user_spec, rdr_env, imports, defaults, hpc_info) <- rnImports import_decls ;
@@ -472,8 +478,8 @@ tcRnImports hsc_env import_decls
-- filtering also ensures that we don't see instances from
-- modules batch (@--make@) compiled before this one, but
-- which are not below this one.
- ; (home_insts, home_fam_insts) <- liftIO $
- hugInstancesBelow hsc_env unitId mnwib
+ ; (home_insts, home_fam_insts) <-
+ tcGetInstances hsc_env unitId mnwib
-- Record boot-file info in the EPS, so that it's
-- visible to loadHiBootInterface in tcRnSrcDecls,
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -352,7 +352,10 @@ data IfGblEnv
-- We need the module name so we can test when it's appropriate
-- to look in this env.
-- See Note [Tying the knot] in GHC.IfaceToCore
- if_rec_types :: (KnotVars (IfG TypeEnv))
+ if_rec_types :: (KnotVars (IfG TypeEnv, TypeEnv -> IfG ()))
+ -- The variable is mostly used for reading but
+ -- there is one case it is written to from loadIface.
+ -- Note [Loading own hi-boot file]
-- Allows a read effect, so it can be in a mutable
-- variable; c.f. handling the external package type env
-- Nothing => interactive stuff, no loops possible
@@ -491,6 +494,7 @@ data TcGblEnv
-- bound in this module when dealing with hi-boot recursions
-- Updated at intervals (e.g. after dealing with types and classes)
+ -- Should only contain things defined in module
tcg_inst_env :: !InstEnv,
-- ^ Instance envt for all /home-package/ modules;
-- Includes the dfuns in tcg_insts
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -102,6 +102,7 @@ import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Core.Coercion.Axiom
import GHC.Core.Class
+import GHC.Stack
import GHC.Unit.Module
@@ -143,6 +144,7 @@ import Control.Monad
import Data.IORef
import Data.List ( intercalate )
import qualified Data.List.NonEmpty as NE
+import qualified GHC.Unit.Home.Graph as HUG
{- *********************************************************************
* *
@@ -346,9 +348,11 @@ tcLookupInstance cls tys
tcGetInstEnvs :: TcM InstEnvs
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
-tcGetInstEnvs = do { eps <- getEps
+tcGetInstEnvs = do { (eps, hug) <- getEpsAndHug
+ ; dflags <- getDynFlags
+ ; (hpt', _) <- liftIO $ if (isOneShot (ghcMode dflags)) then HUG.allInstances hug else return (emptyInstEnv, mempty)
; env <- getGblEnv
- ; return (InstEnvs { ie_global = eps_inst_env eps
+ ; return (InstEnvs { ie_global = eps_inst_env eps `unionInstEnv` hpt'
, ie_local = tcg_inst_env env
, ie_visible = tcVisibleOrphanMods env }) }
@@ -400,7 +404,7 @@ failIllegalTyVal :: Name -> TcM a
************************************************************************
-}
-setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
+setGlobalTypeEnv :: HasCallStack => TcGblEnv -> TypeEnv -> TcM TcGblEnv
-- Use this to update the global type env
-- It updates both * the normal tcg_type_env field
-- * the tcg_type_env_var field seen by interface files
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -2187,7 +2187,7 @@ initIfaceTcRn thing_inside
if_rec_types =
if is_instantiate
then emptyKnotVars
- else readTcRef <$> knot_vars
+ else mkTypeEnvLens <$> knot_vars
}
}
; setEnvs (if_env, ()) thing_inside }
@@ -2209,7 +2209,7 @@ initIfaceLoadModule :: HscEnv -> Module -> IfG a -> IO a
initIfaceLoadModule hsc_env this_mod do_this
= do let gbl_env = IfGblEnv {
if_doc = text "initIfaceLoadModule",
- if_rec_types = readTcRef <$> knotVarsWithout this_mod (hsc_type_env_vars hsc_env)
+ if_rec_types = mkTypeEnvLens <$> knotVarsWithout this_mod (hsc_type_env_vars hsc_env)
}
initTcRnIf 'i' hsc_env gbl_env () do_this
@@ -2219,10 +2219,13 @@ initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck doc hsc_env do_this
= do let gbl_env = IfGblEnv {
if_doc = text "initIfaceCheck" <+> doc,
- if_rec_types = readTcRef <$> hsc_type_env_vars hsc_env
+ if_rec_types = mkTypeEnvLens <$> hsc_type_env_vars hsc_env
}
initTcRnIf 'i' hsc_env gbl_env () do_this
+mkTypeEnvLens :: IORef TypeEnv -> (IfG TypeEnv, TypeEnv -> IfG ())
+mkTypeEnvLens ref = (readTcRef ref, writeTcRef ref)
+
initIfaceLcl :: Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl mod loc_doc hi_boot_file thing_inside
= setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
=====================================
compiler/GHC/Unit/Home/Graph.hs
=====================================
@@ -40,6 +40,7 @@ module GHC.Unit.Home.Graph
-- * Very important queries
, allInstances
+ , allRules
, allFamInstances
, allAnns
, allCompleteSigs
@@ -88,6 +89,8 @@ import GHC.Types.Annotations
import GHC.Types.CompleteMatch
import GHC.Core.InstEnv
+import GHC.Core
+
-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across
-- all home units.
@@ -104,6 +107,15 @@ allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where
go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b'))
(hptAllInstances (homeUnitEnv_hpt hue))
+-- | Find all the instance declarations (of classes and families) from
+-- the Home Package Table filtered by the provided predicate function.
+-- Used in @tcRnImports@, to select the instances that are in the
+-- transitive closure of imports from the currently compiled module.
+allRules :: HomeUnitGraph -> IO [CoreRule]
+allRules hug = foldr go (pure []) hug where
+ go hue = liftA2 (\b b' -> (b ++ b'))
+ (hptAllRules (homeUnitEnv_hpt hue))
+
allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv)
allFamInstances hug = foldr go (pure emptyModuleEnv) hug where
go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue))
=====================================
compiler/GHC/Unit/Home/PackageTable.hs
=====================================
@@ -43,6 +43,7 @@ module GHC.Unit.Home.PackageTable
, hptAllInstances
, hptAllFamInstances
, hptAllAnnotations
+ , hptAllRules
-- ** More Traversal-based queries
, hptCollectDependencies
@@ -95,6 +96,7 @@ import GHC.Unit.Module.ModIface
import GHC.Utils.Outputable
import GHC.Types.Unique (getUnique, getKey)
import qualified GHC.Data.Word64Set as W64
+import GHC.Core
-- | Helps us find information about modules in the home package
newtype HomePackageTable = HPT {
@@ -220,6 +222,10 @@ hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiF
hptAllAnnotations :: HomePackageTable -> IO AnnEnv
hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details)
+-- | All annotations from the HPT
+hptAllRules :: HomePackageTable -> IO [CoreRule]
+hptAllRules = concatHpt (md_rules . hm_details)
+
--------------------------------------------------------------------------------
-- * Traversal-based queries
=====================================
compiler/GHC/Unit/Module/External/Graph.hs
=====================================
@@ -9,7 +9,7 @@ module GHC.Unit.Module.External.Graph
-- | A module graph for the EPS.
ExternalModuleGraph, ExternalGraphNode(..)
, ExternalKey(..), emptyExternalModuleGraph
- , emgNodeKey, emgNodeDeps, emgLookupKey
+ , emgNodeKey, emgNodeDeps
-- * Extending
--
@@ -123,10 +123,6 @@ emgNodeKey :: ExternalGraphNode -> ExternalKey
emgNodeKey (NodeHomePackage k _) = ExternalModuleKey k
emgNodeKey (NodeExternalPackage k _) = ExternalPackageKey k
--- | Lookup a key in the EMG.
-emgLookupKey :: ExternalKey -> ExternalModuleGraph -> Maybe ExternalGraphNode
-emgLookupKey k emg = node_payload <$> (snd (external_trans emg)) k
-
--------------------------------------------------------------------------------
-- * Extending
--------------------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/908b092ce5f309cbbff2c108224cfcc3047cb150
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/908b092ce5f309cbbff2c108224cfcc3047cb150
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/20250222/06ec9abb/attachment-0001.html>
More information about the ghc-commits
mailing list