Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
-
b08c08ae
by soulomoon at 2025-05-28T01:57:23+08:00
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:
| ... | ... | @@ -33,6 +33,7 @@ module GHC.Driver.Env |
| 33 | 33 | , hugRulesBelow
|
| 34 | 34 | , hugInstancesBelow
|
| 35 | 35 | , hugAnnsBelow
|
| 36 | + , hugCompleteSigsBelow
|
|
| 36 | 37 | |
| 37 | 38 | -- * Legacy API
|
| 38 | 39 | , hscUpdateHPT
|
| ... | ... | @@ -79,6 +80,7 @@ import GHC.Utils.Logger |
| 79 | 80 | |
| 80 | 81 | import GHC.Core.Rules
|
| 81 | 82 | import GHC.Types.Annotations
|
| 83 | +import GHC.Types.CompleteMatch
|
|
| 82 | 84 | import GHC.Core.InstEnv
|
| 83 | 85 | import GHC.Core.FamInstEnv
|
| 84 | 86 | import GHC.Builtin.Names
|
| ... | ... | @@ -228,6 +230,12 @@ hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv |
| 228 | 230 | hugAnnsBelow hsc uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$>
|
| 229 | 231 | hugSomeThingsBelowUs (md_anns . hm_details) False hsc uid mn
|
| 230 | 232 | |
| 233 | +-- | Find all COMPLETE pragmas in modules that are in the transitive closure of the
|
|
| 234 | +-- given module.
|
|
| 235 | +hugCompleteSigsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO CompleteMatches
|
|
| 236 | +hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$>
|
|
| 237 | + hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn
|
|
| 238 | + |
|
| 231 | 239 | -- | Find instances visible from the given set of imports
|
| 232 | 240 | hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst])
|
| 233 | 241 | hugInstancesBelow hsc_env uid mnwib = do
|
| ... | ... | @@ -266,9 +266,12 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env |
| 266 | 266 | ptc = initPromotionTickContext (hsc_dflags hsc_env)
|
| 267 | 267 | -- re-use existing next_wrapper_num to ensure uniqueness
|
| 268 | 268 | next_wrapper_num_var = tcg_next_wrapper_num tcg_env
|
| 269 | + tcg_comp_env = tcg_complete_match_env tcg_env
|
|
| 269 | 270 | |
| 270 | 271 | ; ds_complete_matches <-
|
| 271 | 272 | liftIO $ unsafeInterleaveIO $
|
| 273 | + -- Note [Lazily loading COMPLETE pragmas]
|
|
| 274 | + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 272 | 275 | -- This call to 'unsafeInterleaveIO' ensures we only do this work
|
| 273 | 276 | -- when we need to look at the COMPLETE pragmas, avoiding doing work
|
| 274 | 277 | -- when we don't need them.
|
| ... | ... | @@ -276,7 +279,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env |
| 276 | 279 | -- Relevant test case: MultiLayerModulesTH_Make, which regresses
|
| 277 | 280 | -- in allocations by ~5% if we don't do this.
|
| 278 | 281 | traverse (lookupCompleteMatch type_env hsc_env) =<<
|
| 279 | - localAndImportedCompleteMatches (tcg_complete_matches tcg_env) (hsc_unit_env hsc_env) eps
|
|
| 282 | + localAndImportedCompleteMatches tcg_comp_env eps
|
|
| 280 | 283 | ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
|
| 281 | 284 | msg_var cc_st_var next_wrapper_num_var ds_complete_matches
|
| 282 | 285 | }
|
| ... | ... | @@ -334,7 +337,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds |
| 334 | 337 | bindsToIds (Rec binds) = map fst binds
|
| 335 | 338 | ids = concatMap bindsToIds binds
|
| 336 | 339 | ; ds_complete_matches <- traverse (lookupCompleteMatch type_env hsc_env) =<<
|
| 337 | - localAndImportedCompleteMatches local_complete_matches (hsc_unit_env hsc_env) eps
|
|
| 340 | + localAndImportedCompleteMatches local_complete_matches eps
|
|
| 338 | 341 | ; let
|
| 339 | 342 | envs = mkDsEnvs unit_env this_mod rdr_env type_env
|
| 340 | 343 | fam_inst_env ptc msg_var cc_st_var
|
| ... | ... | @@ -338,7 +338,8 @@ rnValBindsRHS ctxt (ValBinds _ mbinds sigs) |
| 338 | 338 | -- Update the TcGblEnv with renamed COMPLETE pragmas from the current
|
| 339 | 339 | -- module, for pattern irrefutability checking in do notation.
|
| 340 | 340 | ; let localCompletePrags = localCompletePragmas sigs'
|
| 341 | - ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags}) $
|
|
| 341 | + ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags
|
|
| 342 | + , tcg_complete_match_env = tcg_complete_match_env gblEnv ++ localCompletePrags }) $
|
|
| 342 | 343 | do { binds_w_dus <- mapM (rnLBind (mkScopedTvFn sigs')) mbinds
|
| 343 | 344 | ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus
|
| 344 | 345 | |
| ... | ... | @@ -956,7 +957,8 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs |
| 956 | 957 | |
| 957 | 958 | -- Update the TcGblEnv with renamed COMPLETE pragmas from the current
|
| 958 | 959 | -- module, for pattern irrefutability checking in do notation.
|
| 959 | - ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags}) $
|
|
| 960 | + ; updGblEnv (\gblEnv -> gblEnv { tcg_complete_matches = tcg_complete_matches gblEnv ++ localCompletePrags
|
|
| 961 | + , tcg_complete_match_env = tcg_complete_match_env gblEnv ++ localCompletePrags}) $
|
|
| 960 | 962 | do {
|
| 961 | 963 | -- Rename the bindings RHSs. Again there's an issue about whether the
|
| 962 | 964 | -- type variables from the class/instance head are in scope.
|
| ... | ... | @@ -222,7 +222,8 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, |
| 222 | 222 | last_tcg_env0 <- getGblEnv ;
|
| 223 | 223 | let { last_tcg_env =
|
| 224 | 224 | last_tcg_env0
|
| 225 | - { tcg_complete_matches = tcg_complete_matches last_tcg_env0 ++ localCompletePragmas sigs' }
|
|
| 225 | + { tcg_complete_matches = tcg_complete_matches last_tcg_env0 ++ localCompletePragmas sigs'
|
|
| 226 | + , tcg_complete_match_env = tcg_complete_match_env last_tcg_env0 ++ localCompletePragmas sigs'}
|
|
| 226 | 227 | } ;
|
| 227 | 228 | -- (I) Compute the results and return
|
| 228 | 229 | let {rn_group = HsGroup { hs_ext = noExtField,
|
| ... | ... | @@ -51,6 +51,7 @@ import GHC.Driver.Env |
| 51 | 51 | import GHC.Driver.Plugins
|
| 52 | 52 | import GHC.Driver.DynFlags
|
| 53 | 53 | import GHC.Driver.Config.Diagnostic
|
| 54 | +import GHC.IO.Unsafe ( unsafeInterleaveIO )
|
|
| 54 | 55 | |
| 55 | 56 | import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR (..) )
|
| 56 | 57 | import GHC.Tc.Errors.Types
|
| ... | ... | @@ -483,6 +484,12 @@ tcRnImports hsc_env import_decls |
| 483 | 484 | ; (home_insts, home_fam_insts) <- liftIO $
|
| 484 | 485 | hugInstancesBelow hsc_env unitId mnwib
|
| 485 | 486 | |
| 487 | + -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations
|
|
| 488 | + -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad
|
|
| 489 | + -- and see https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14274#note_620545
|
|
| 490 | + ; completeSigsBelow <- liftIO $ unsafeInterleaveIO $
|
|
| 491 | + hugCompleteSigsBelow hsc_env unitId mnwib
|
|
| 492 | + |
|
| 486 | 493 | -- Record boot-file info in the EPS, so that it's
|
| 487 | 494 | -- visible to loadHiBootInterface in tcRnSrcDecls,
|
| 488 | 495 | -- and any other incrementally-performed imports
|
| ... | ... | @@ -495,6 +502,8 @@ tcRnImports hsc_env import_decls |
| 495 | 502 | gbl {
|
| 496 | 503 | tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
|
| 497 | 504 | tcg_imports = tcg_imports gbl `plusImportAvails` imports,
|
| 505 | + tcg_complete_match_env = tcg_complete_match_env gbl ++
|
|
| 506 | + completeSigsBelow,
|
|
| 498 | 507 | tcg_import_decls = imp_user_spec,
|
| 499 | 508 | tcg_rn_imports = rn_imports,
|
| 500 | 509 | tcg_default = foldMap subsume tc_defaults,
|
| ... | ... | @@ -507,6 +507,9 @@ data TcGblEnv |
| 507 | 507 | tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances
|
| 508 | 508 | -- NB. BangPattern is to fix a leak, see #15111
|
| 509 | 509 | tcg_ann_env :: AnnEnv, -- ^ And for annotations
|
| 510 | + tcg_complete_match_env :: CompleteMatches,
|
|
| 511 | + -- ^ The complete matches for all /home-package/ modules;
|
|
| 512 | + -- Includes the complete matches in tcg_complete_matches
|
|
| 510 | 513 | |
| 511 | 514 | -- Now a bunch of things about this module that are simply
|
| 512 | 515 | -- accumulated, but never consulted until the end.
|
| ... | ... | @@ -689,9 +692,10 @@ data TcGblEnv |
| 689 | 692 | -- ^ Wanted constraints of static forms.
|
| 690 | 693 | -- See Note [Constraints in static forms].
|
| 691 | 694 | tcg_complete_matches :: !CompleteMatches,
|
| 695 | + -- ^ Complete matches defined in this module.
|
|
| 692 | 696 | |
| 693 | - -- ^ Tracking indices for cost centre annotations
|
|
| 694 | 697 | tcg_cc_st :: TcRef CostCentreState,
|
| 698 | + -- ^ Tracking indices for cost centre annotations
|
|
| 695 | 699 | |
| 696 | 700 | tcg_next_wrapper_num :: TcRef (ModuleEnv Int)
|
| 697 | 701 | -- ^ See Note [Generating fresh names for FFI wrappers]
|
| ... | ... | @@ -328,6 +328,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this |
| 328 | 328 | tcg_inst_env = emptyInstEnv,
|
| 329 | 329 | tcg_fam_inst_env = emptyFamInstEnv,
|
| 330 | 330 | tcg_ann_env = emptyAnnEnv,
|
| 331 | + tcg_complete_match_env = [],
|
|
| 331 | 332 | tcg_th_used = th_var,
|
| 332 | 333 | tcg_th_needed_deps = th_needed_deps_var,
|
| 333 | 334 | tcg_exports = [],
|
| ... | ... | @@ -2425,15 +2426,14 @@ liftZonkM (ZonkM f) = |
| 2425 | 2426 | getCompleteMatchesTcM :: TcM CompleteMatches
|
| 2426 | 2427 | getCompleteMatchesTcM
|
| 2427 | 2428 | = do { hsc_env <- getTopEnv
|
| 2428 | - ; tcg_env <- getGblEnv
|
|
| 2429 | 2429 | ; eps <- liftIO $ hscEPS hsc_env
|
| 2430 | - ; liftIO $ localAndImportedCompleteMatches (tcg_complete_matches tcg_env) (hsc_unit_env hsc_env) eps
|
|
| 2430 | + ; tcg_env <- getGblEnv
|
|
| 2431 | + ; let tcg_comps = tcg_complete_match_env tcg_env
|
|
| 2432 | + ; liftIO $ localAndImportedCompleteMatches tcg_comps eps
|
|
| 2431 | 2433 | }
|
| 2432 | 2434 | |
| 2433 | -localAndImportedCompleteMatches :: CompleteMatches -> UnitEnv -> ExternalPackageState -> IO CompleteMatches
|
|
| 2434 | -localAndImportedCompleteMatches tcg_comps unit_env eps = do
|
|
| 2435 | - hugCSigs <- hugCompleteSigs unit_env
|
|
| 2435 | +localAndImportedCompleteMatches :: CompleteMatches -> ExternalPackageState -> IO CompleteMatches
|
|
| 2436 | +localAndImportedCompleteMatches tcg_comps eps = do
|
|
| 2436 | 2437 | return $
|
| 2437 | - tcg_comps -- from the current module
|
|
| 2438 | - ++ hugCSigs -- from the home package
|
|
| 2439 | - ++ eps_complete_matches eps -- from imports |
|
| 2438 | + tcg_comps -- from the current modulea and from the home package
|
|
| 2439 | + ++ eps_complete_matches eps -- from external packages |