Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b08c08ae by soulomoon at 2025-05-28T01:57:23+08:00 Refactor handling of imported COMPLETE pragmas from the HPT Previously, we imported COMPLETE pragmas from all modules in the Home Package Table (HPT) during type checking. However, since !13675, there may be non-below modules in the HPT from the dependency tree that we do not want to import COMPLETE pragmas from. This refactor changes the way we handle COMPLETE pragmas from the HPT to only import them from modules that are "below" the current module in the HPT. - Add hugCompleteSigsBelow to filter COMPLETE pragmas from "below" modules in the HPT, mirroring hugRulesBelow. - Move responsibility for calling hugCompleteSigsBelow to tcRnImports, storing the result in the new tcg_complete_match_env field of TcGblEnv. - Update getCompleteMatchesTcM to use tcg_complete_match_env. This refactor only affects how COMPLETE pragmas are imported from the HPT, imports from external packages are unchanged. - - - - - 7 changed files: - compiler/GHC/Driver/Env.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs Changes: ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -33,6 +33,7 @@ module GHC.Driver.Env , hugRulesBelow , hugInstancesBelow , hugAnnsBelow + , hugCompleteSigsBelow -- * Legacy API , hscUpdateHPT @@ -79,6 +80,7 @@ import GHC.Utils.Logger import GHC.Core.Rules import GHC.Types.Annotations +import GHC.Types.CompleteMatch import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Builtin.Names @@ -228,6 +230,12 @@ hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv hugAnnsBelow hsc uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> hugSomeThingsBelowUs (md_anns . hm_details) False hsc uid mn +-- | Find all COMPLETE pragmas in modules that are in the transitive closure of the +-- given module. +hugCompleteSigsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO CompleteMatches +hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> + hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn + -- | Find instances visible from the given set of imports hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst]) hugInstancesBelow hsc_env uid mnwib = do ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -266,9 +266,12 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env ptc = initPromotionTickContext (hsc_dflags hsc_env) -- re-use existing next_wrapper_num to ensure uniqueness next_wrapper_num_var = tcg_next_wrapper_num tcg_env + tcg_comp_env = tcg_complete_match_env tcg_env ; ds_complete_matches <- liftIO $ unsafeInterleaveIO $ + -- Note [Lazily loading COMPLETE pragmas] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- This call to 'unsafeInterleaveIO' ensures we only do this work -- when we need to look at the COMPLETE pragmas, avoiding doing work -- when we don't need them. @@ -276,7 +279,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env -- Relevant test case: MultiLayerModulesTH_Make, which regresses -- in allocations by ~5% if we don't do this. traverse (lookupCompleteMatch type_env hsc_env) =<< - localAndImportedCompleteMatches (tcg_complete_matches tcg_env) (hsc_unit_env hsc_env) eps + localAndImportedCompleteMatches tcg_comp_env eps ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num_var ds_complete_matches } @@ -334,7 +337,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds bindsToIds (Rec binds) = map fst binds ids = concatMap bindsToIds binds ; ds_complete_matches <- traverse (lookupCompleteMatch type_env hsc_env) =<< - localAndImportedCompleteMatches local_complete_matches (hsc_unit_env hsc_env) eps + localAndImportedCompleteMatches local_complete_matches eps ; let envs = mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var ===================================== compiler/GHC/Rename/Bind.hs ===================================== @@ -338,7 +338,8 @@ rnValBindsRHS ctxt (ValBinds _ mbinds sigs) -- Update the TcGblEnv with renamed COMPLETE pragmas from the current -- module, for pattern irrefutability checking in do notation. ; let localCompletePrags = localCompletePragmas sigs' - ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags}) $ + ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags + , tcg_complete_match_env = tcg_complete_match_env gblEnv ++ localCompletePrags }) $ do { binds_w_dus <- mapM (rnLBind (mkScopedTvFn sigs')) mbinds ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus @@ -956,7 +957,8 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs -- Update the TcGblEnv with renamed COMPLETE pragmas from the current -- module, for pattern irrefutability checking in do notation. - ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags}) $ + ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags + , tcg_complete_match_env = tcg_complete_match_env gblEnv ++ localCompletePrags}) $ do { -- Rename the bindings RHSs. Again there's an issue about whether the -- type variables from the class/instance head are in scope. ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -222,7 +222,8 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, last_tcg_env0 <- getGblEnv ; let { last_tcg_env = last_tcg_env0 - { tcg_complete_matches = tcg_complete_matches last_tcg_env0 ++ localCompletePragmas sigs' } + { tcg_complete_matches = tcg_complete_matches last_tcg_env0 ++ localCompletePragmas sigs' + , tcg_complete_match_env = tcg_complete_match_env last_tcg_env0 ++ localCompletePragmas sigs'} } ; -- (I) Compute the results and return let {rn_group = HsGroup { hs_ext = noExtField, ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -51,6 +51,7 @@ import GHC.Driver.Env import GHC.Driver.Plugins import GHC.Driver.DynFlags import GHC.Driver.Config.Diagnostic +import GHC.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR (..) ) import GHC.Tc.Errors.Types @@ -483,6 +484,12 @@ tcRnImports hsc_env import_decls ; (home_insts, home_fam_insts) <- liftIO $ hugInstancesBelow hsc_env unitId mnwib + -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations + -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad + -- and see https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14274#note_620545 + ; completeSigsBelow <- liftIO $ unsafeInterleaveIO $ + hugCompleteSigsBelow hsc_env unitId mnwib + -- Record boot-file info in the EPS, so that it's -- visible to loadHiBootInterface in tcRnSrcDecls, -- and any other incrementally-performed imports @@ -495,6 +502,8 @@ tcRnImports hsc_env import_decls gbl { tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_complete_match_env = tcg_complete_match_env gbl ++ + completeSigsBelow, tcg_import_decls = imp_user_spec, tcg_rn_imports = rn_imports, tcg_default = foldMap subsume tc_defaults, ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -507,6 +507,9 @@ data TcGblEnv tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances -- NB. BangPattern is to fix a leak, see #15111 tcg_ann_env :: AnnEnv, -- ^ And for annotations + tcg_complete_match_env :: CompleteMatches, + -- ^ The complete matches for all /home-package/ modules; + -- Includes the complete matches in tcg_complete_matches -- Now a bunch of things about this module that are simply -- accumulated, but never consulted until the end. @@ -689,9 +692,10 @@ data TcGblEnv -- ^ Wanted constraints of static forms. -- See Note [Constraints in static forms]. tcg_complete_matches :: !CompleteMatches, + -- ^ Complete matches defined in this module. - -- ^ Tracking indices for cost centre annotations tcg_cc_st :: TcRef CostCentreState, + -- ^ Tracking indices for cost centre annotations tcg_next_wrapper_num :: TcRef (ModuleEnv Int) -- ^ See Note [Generating fresh names for FFI wrappers] ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -328,6 +328,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, tcg_ann_env = emptyAnnEnv, + tcg_complete_match_env = [], tcg_th_used = th_var, tcg_th_needed_deps = th_needed_deps_var, tcg_exports = [], @@ -2425,15 +2426,14 @@ liftZonkM (ZonkM f) = getCompleteMatchesTcM :: TcM CompleteMatches getCompleteMatchesTcM = do { hsc_env <- getTopEnv - ; tcg_env <- getGblEnv ; eps <- liftIO $ hscEPS hsc_env - ; liftIO $ localAndImportedCompleteMatches (tcg_complete_matches tcg_env) (hsc_unit_env hsc_env) eps + ; tcg_env <- getGblEnv + ; let tcg_comps = tcg_complete_match_env tcg_env + ; liftIO $ localAndImportedCompleteMatches tcg_comps eps } -localAndImportedCompleteMatches :: CompleteMatches -> UnitEnv -> ExternalPackageState -> IO CompleteMatches -localAndImportedCompleteMatches tcg_comps unit_env eps = do - hugCSigs <- hugCompleteSigs unit_env +localAndImportedCompleteMatches :: CompleteMatches -> ExternalPackageState -> IO CompleteMatches +localAndImportedCompleteMatches tcg_comps eps = do return $ - tcg_comps -- from the current module - ++ hugCSigs -- from the home package - ++ eps_complete_matches eps -- from imports + tcg_comps -- from the current modulea and from the home package + ++ eps_complete_matches eps -- from external packages View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b08c08ae6a5b9252c5d350646e2b361a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b08c08ae6a5b9252c5d350646e2b361a... You're receiving this email because of your account on gitlab.haskell.org.