summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simon.peytonjones@gmail.com>2022-01-22 01:12:30 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-01-27 08:22:30 -0500
commit18df4013f6eaee0e1de8ebd533f7e96c4ee0ff04 (patch)
tree084c538d397dacef00592ca56f55a9217df74a3f
parentf0adea14316ef476607cb7d99f74875875e52b20 (diff)
downloadhaskell-18df4013f6eaee0e1de8ebd533f7e96c4ee0ff04.tar.gz
Define and use restoreLclEnv
This fixes #20981. See Note [restoreLclEnv vs setLclEnv] in GHC.Tc.Utils.Monad. I also use updLclEnv rather than get/set when I can, because it's then much clearer that it's an update rather than an entirely new TcLclEnv coming from who-knows-where.
-rw-r--r--compiler/GHC/Iface/Env.hs20
-rw-r--r--compiler/GHC/Rename/Module.hs6
-rw-r--r--compiler/GHC/Rename/Names.hs2
-rw-r--r--compiler/GHC/Rename/Utils.hs17
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs7
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs9
-rw-r--r--compiler/GHC/Tc/Module.hs81
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs37
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs96
9 files changed, 152 insertions, 123 deletions
diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs
index 05c5f6e192..9edc0edd32 100644
--- a/compiler/GHC/Iface/Env.hs
+++ b/compiler/GHC/Iface/Env.hs
@@ -203,11 +203,11 @@ tcIfaceLclId occ
}
extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
-extendIfaceIdEnv ids thing_inside
- = do { env <- getLclEnv
- ; let { id_env' = extendFsEnvList (if_id_env env) pairs
- ; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
- ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
+extendIfaceIdEnv ids
+ = updLclEnv $ \env ->
+ let { id_env' = extendFsEnvList (if_id_env env) pairs
+ ; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
+ in env { if_id_env = id_env' }
tcIfaceTyVar :: FastString -> IfL TyVar
@@ -232,11 +232,11 @@ lookupIfaceVar (IfaceTvBndr (occ, _))
; return (lookupFsEnv (if_tv_env lcl) occ) }
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
-extendIfaceTyVarEnv tyvars thing_inside
- = do { env <- getLclEnv
- ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs
- ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
- ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
+extendIfaceTyVarEnv tyvars
+ = updLclEnv $ \env ->
+ let { tv_env' = extendFsEnvList (if_tv_env env) pairs
+ ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
+ in env { if_tv_env = tv_env' }
extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
extendIfaceEnvs tcvs thing_inside
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 5884747609..85f7467565 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -126,7 +126,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
(tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
- setEnvs tc_envs $ do {
+ restoreEnvs tc_envs $ do {
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
@@ -154,7 +154,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- They are already in scope
traceRn "rnSrcDecls" (ppr id_bndrs) ;
tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
- setEnvs tc_envs $ do {
+ restoreEnvs tc_envs $ do {
-- Now everything is in scope, as the remaining renaming assumes.
@@ -2440,7 +2440,7 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do {
; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
final_gbl_env = gbl_env { tcg_field_env = field_env' }
- ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
+ ; restoreEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
where
new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index c0d704728a..dbf1f88cba 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -891,7 +891,7 @@ getLocalNonValBinders fixity_env
(tyClGroupTyClDecls tycl_decls)
; traceRn "getLocalNonValBinders 1" (ppr tc_avails)
; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
- ; setEnvs envs $ do {
+ ; restoreEnvs envs $ do {
-- Bring these things into scope first
-- See Note [Looking up family names in family instances]
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 0c2d426450..6497a51c02 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -93,15 +93,14 @@ newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name]
newLocalBndrsRn = mapM newLocalBndrRn
bindLocalNames :: [Name] -> RnM a -> RnM a
-bindLocalNames names enclosed_scope
- = do { lcl_env <- getLclEnv
- ; let th_level = thLevel (tcl_th_ctxt lcl_env)
- th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
- [ (n, (NotTopLevel, th_level)) | n <- names ]
- rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names
- ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'
- , tcl_rdr = rdr_env' })
- enclosed_scope }
+bindLocalNames names
+ = updLclEnv $ \ lcl_env ->
+ let th_level = thLevel (tcl_th_ctxt lcl_env)
+ th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
+ [ (n, (NotTopLevel, th_level)) | n <- names ]
+ rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names
+ in lcl_env { tcl_th_bndrs = th_bndrs'
+ , tcl_rdr = rdr_env' }
bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV names enclosed_scope
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 052a2ed2fa..0d2ba18503 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -179,13 +179,10 @@ tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-- The TcLclEnv has an extended type envt for the new bindings
tcTopBinds binds sigs
= do { -- Pattern synonym bindings populate the global environment
- (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
- do { gbl <- getGblEnv
- ; lcl <- getLclEnv
- ; return (gbl, lcl) }
+ (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs getEnvs
; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
- ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs
+ ; complete_matches <- restoreEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs
; traceTc "complete_matches" (ppr binds $$ ppr sigs)
; traceTc "complete_matches" (ppr complete_matches)
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index a38d6d436f..006da15def 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -618,7 +618,6 @@ tcSpliceExpr splice _
{- Note [Collecting modFinalizers in typed splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local
environment (see Note [Delaying modFinalizers in untyped splices] in
GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the
@@ -679,12 +678,8 @@ tcTopSplice expr res_ty
-- See Note [Running typed splices in the zonker]
runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)
- = do
- errs_var <- getErrsVar
- setLclEnv lcl_env $ setErrsVar errs_var $ do {
- -- Set the errs_var to the errs_var from the current context,
- -- otherwise error messages can go missing in GHCi (#19470)
- zonked_ty <- zonkTcType res_ty
+ = restoreLclEnv lcl_env $
+ do { zonked_ty <- zonkTcType res_ty
; zonked_q_expr <- zonkTopLExpr q_expr
-- See Note [Collecting modFinalizers in typed splices].
; modfinalizers_ref <- newTcRef []
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 66f7406745..1d77f1b593 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -465,7 +465,7 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls
-- * the local env exposes the local Ids to simplifyTop,
-- so that we get better error messages (monomorphism restriction)
; new_ev_binds <- {-# SCC "simplifyTop" #-}
- setEnvs (tcg_env, tcl_env) $
+ restoreEnvs (tcg_env, tcl_env) $
do { lie_main <- checkMainType tcg_env
; simplifyTop (lie `andWC` lie_main) }
@@ -474,6 +474,9 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls
mkTypeableBinds
; traceTc "Tc9" empty
+ ; failIfErrsM -- Stop now if if there have been errors
+ -- Continuing is a waste of time; and we may get debug
+ -- warnings when zonking about strangely-typed TyCons!
-- Zonk the final code. This must be done last.
-- Even simplifyTop may do some unification.
@@ -506,19 +509,23 @@ tcRnSrcDecls explicit_mod_hdr export_ies decls
--------- Deal with the exports ----------
-- Can't be done earlier, because the export list must "see"
-- the declarations created by the finalizers
- ; tcg_env <- setEnvs (tcg_env, tcl_env) $
+ ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $
rnExports explicit_mod_hdr export_ies
--------- Emit the ':Main.main = runMainIO main' declaration ----------
-- Do this /after/ rnExports, so that it can consult
-- the tcg_exports created by rnExports
; (tcg_env, main_ev_binds)
- <- setEnvs (tcg_env, tcl_env) $
+ <- restoreEnvs (tcg_env, tcl_env) $
do { (tcg_env, lie) <- captureTopConstraints $
checkMain explicit_mod_hdr export_ies
; ev_binds <- simplifyTop lie
; return (tcg_env, ev_binds) }
+ ; failIfErrsM -- Stop now if if there have been errors
+ -- Continuing is a waste of time; and we may get debug
+ -- warnings when zonking about strangely-typed TyCons!
+
---------- Final zonking ---------------
-- Zonk the new bindings arising from running the finalisers,
-- and main. This won't give rise to any more finalisers as you
@@ -553,10 +560,7 @@ zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds = binds
= {-# SCC "zonkTopDecls" #-}
setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering
-- error messages during zonking (notably levity errors)
- do { failIfErrsM -- Don't zonk if there have been errors
- -- It's a waste of time; and we may get debug warnings
- -- about strangely-typed TyCons!
- ; let all_ev_binds = cur_ev_binds `unionBags` ev_binds
+ do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds
; zonkTopDecls all_ev_binds binds rules imp_specs fords }
-- | Runs TH finalizers and renames and typechecks the top-level declarations
@@ -570,7 +574,7 @@ run_th_modfinalizers = do
else do
writeTcRef th_modfinalizers_var []
let run_finalizer (lcl_env, f) =
- setLclEnv lcl_env (runRemoteModFinalizers f)
+ restoreLclEnv lcl_env (runRemoteModFinalizers f)
(_, lie_th) <- captureTopConstraints $
mapM_ run_finalizer th_modfinalizers
@@ -579,7 +583,7 @@ run_th_modfinalizers = do
-- we have to run tc_rn_src_decls to get them
(tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []
- setEnvs (tcg_env, tcl_env) $ do
+ restoreEnvs (tcg_env, tcl_env) $ do
-- Subsequent rounds of finalizers run after any new constraints are
-- simplified, or some types might not be complete when using reify
-- (see #12777).
@@ -646,7 +650,7 @@ tc_rn_src_decls ds
tcTopSrcDecls rn_decls
-- If there is no splice, we're nearly done
- ; setEnvs (tcg_env, tcl_env) $
+ ; restoreEnvs (tcg_env, tcl_env) $
case group_tail of
{ Nothing -> return (tcg_env, tcl_env, lie1)
@@ -1498,14 +1502,14 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- the bindings produced in a Data instance.)
traceTc "Tc5" empty ;
tc_envs <- tcTopBinds val_binds val_sigs;
- setEnvs tc_envs $ do {
+ restoreEnvs tc_envs $ do {
-- Now GHC-generated derived bindings, generics, and selectors
-- Do not generate warnings from compiler-generated code;
-- hence the use of discardWarnings
tc_envs@(tcg_env, tcl_env)
<- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;
- setEnvs tc_envs $ do { -- Environment doesn't change now
+ restoreEnvs tc_envs $ do { -- Environment doesn't change now
-- Second pass over class and instance declarations,
-- now using the kind-checked decls
@@ -2058,34 +2062,31 @@ runTcInteractive hsc_env thing_inside
IIDecl i -> getOrphans (unLoc (ideclName i))
(renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
- ; let imports = emptyImportAvails {
- imp_orphs = orphs
- }
-
- ; (gbl_env, lcl_env) <- getEnvs
- ; let gbl_env' = gbl_env {
- tcg_rdr_env = icReaderEnv icxt
- , tcg_type_env = type_env
- , tcg_inst_env = extendInstEnvList
- (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)
- home_insts
- , tcg_fam_inst_env = extendFamInstEnvList
- (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
- ic_finsts)
- home_fam_insts
- , tcg_field_env = mkNameEnv con_fields
- -- setting tcg_field_env is necessary
- -- to make RecordWildCards work (test: ghci049)
- , tcg_fix_env = ic_fix_env icxt
- , tcg_default = ic_default icxt
- -- must calculate imp_orphs of the ImportAvails
- -- so that instance visibility is done correctly
- , tcg_imports = imports
- }
-
- lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids
-
- ; setEnvs (gbl_env', lcl_env') thing_inside }
+ ; let imports = emptyImportAvails { imp_orphs = orphs }
+
+ upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env')
+ where
+ gbl_env' = gbl_env { tcg_rdr_env = icReaderEnv icxt
+ , tcg_type_env = type_env
+ , tcg_inst_env = extendInstEnvList
+ (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)
+ home_insts
+ , tcg_fam_inst_env = extendFamInstEnvList
+ (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
+ ic_finsts)
+ home_fam_insts
+ , tcg_field_env = mkNameEnv con_fields
+ -- setting tcg_field_env is necessary
+ -- to make RecordWildCards work (test: ghci049)
+ , tcg_fix_env = ic_fix_env icxt
+ , tcg_default = ic_default icxt
+ -- must calculate imp_orphs of the ImportAvails
+ -- so that instance visibility is done correctly
+ , tcg_imports = imports }
+
+ lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids
+
+ ; updEnvs upd_envs thing_inside }
where
(home_insts, home_fam_insts) = hptAllInstances hsc_env
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index be4facc922..90c8b9b529 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -638,29 +638,28 @@ tc_extend_local_env top_lvl extra_env thing_inside
-- that are bound together with extra_env and should not be regarded
-- as free in the types of extra_env.
= do { traceTc "tc_extend_local_env" (ppr extra_env)
- ; stage <- getStage
- ; env0@(TcLclEnv { tcl_rdr = rdr_env
- , tcl_th_bndrs = th_bndrs
- , tcl_env = lcl_type_env }) <- getLclEnv
-
- ; let thlvl = (top_lvl, thLevel stage)
-
- env1 = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env
- [ n | (n, _) <- extra_env, isInternalName n ]
- -- The LocalRdrEnv contains only non-top-level names
- -- (GlobalRdrEnv handles the top level)
-
- , tcl_th_bndrs = extendNameEnvList th_bndrs
- [(n, thlvl) | (n, ATcId {}) <- extra_env]
- -- We only track Ids in tcl_th_bndrs
-
- , tcl_env = extendNameEnvList lcl_type_env extra_env }
-
+ ; updLclEnv upd_lcl_env thing_inside }
+ where
+ upd_lcl_env env0@(TcLclEnv { tcl_th_ctxt = stage
+ , tcl_rdr = rdr_env
+ , tcl_th_bndrs = th_bndrs
+ , tcl_env = lcl_type_env })
+ = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env
+ [ n | (n, _) <- extra_env, isInternalName n ]
+ -- The LocalRdrEnv contains only non-top-level names
+ -- (GlobalRdrEnv handles the top level)
+
+ , tcl_th_bndrs = extendNameEnvList th_bndrs
+ [(n, thlvl) | (n, ATcId {}) <- extra_env]
+ -- We only track Ids in tcl_th_bndrs
+
+ , tcl_env = extendNameEnvList lcl_type_env extra_env }
-- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and
-- Template Haskell staging env simultaneously. Reason for extending
-- LocalRdrEnv: after running a TH splice we need to do renaming.
+ where
+ thlvl = (top_lvl, thLevel stage)
- ; setLclEnv env1 thing_inside }
tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv
tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 5cf866072e..ea3b50fa3c 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -20,9 +20,9 @@ module GHC.Tc.Utils.Monad(
-- * Simple accessors
discardResult,
getTopEnv, updTopEnv, getGblEnv, updGblEnv,
- setGblEnv, getLclEnv, updLclEnv, setLclEnv,
+ setGblEnv, getLclEnv, updLclEnv, setLclEnv, restoreLclEnv,
updTopFlags,
- getEnvs, setEnvs,
+ getEnvs, setEnvs, updEnvs, restoreEnvs,
xoptM, doptM, goptM, woptM,
setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
whenDOptM, whenGOptM, whenWOptM,
@@ -109,7 +109,7 @@ module GHC.Tc.Utils.Monad(
emitHole, emitHoles,
discardConstraints, captureConstraints, tryCaptureConstraints,
pushLevelAndCaptureConstraints,
- pushTcLevelM_, pushTcLevelM, pushTcLevelsM,
+ pushTcLevelM_, pushTcLevelM,
getTcLevel, setTcLevel, isTouchableTcM,
getLclTypeEnv, setLclTypeEnv,
traceTcConstraints,
@@ -189,7 +189,6 @@ import GHC.Utils.Outputable as Outputable
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
-import GHC.Utils.Misc
import GHC.Utils.Logger
import qualified GHC.Data.Strict as Strict
@@ -483,7 +482,7 @@ updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
env { env_gbl = upd gbl })
-setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+setGblEnv :: gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
getLclEnv :: TcRnIf gbl lcl lcl
@@ -493,14 +492,65 @@ updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
env { env_lcl = upd lcl })
+
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
+restoreLclEnv :: TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
+-- See Note [restoreLclEnv vs setLclEnv]
+restoreLclEnv new_lcl_env = updLclEnv upd
+ where
+ upd old_lcl_env = new_lcl_env { tcl_errs = tcl_errs old_lcl_env
+ , tcl_lie = tcl_lie old_lcl_env
+ , tcl_usage = tcl_usage old_lcl_env }
+
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
-setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
+setEnvs (gbl_env, lcl_env) = setGblEnv gbl_env . setLclEnv lcl_env
+
+updEnvs :: ((gbl,lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updEnvs upd_envs = updEnv upd
+ where
+ upd env@(Env { env_gbl = gbl, env_lcl = lcl })
+ = env { env_gbl = gbl', env_lcl = lcl' }
+ where
+ !(gbl', lcl') = upd_envs (gbl, lcl)
+
+restoreEnvs :: (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
+-- See Note [restoreLclEnv vs setLclEnv]
+restoreEnvs (gbl, lcl) = setGblEnv gbl . restoreLclEnv lcl
+
+{- Note [restoreLclEnv vs setLclEnv]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the typechecker we use this idiom quite a lot
+ do { (gbl_env, lcl_env) <- tcRnSrcDecls ...
+ ; setGblEnv gbl_env $ setLclEnv lcl_env $
+ more_stuff }
+
+The `tcRnSrcDecls` extends the environments in `gbl_env` and `lcl_env`
+which we then want to be in scope in `more stuff`.
+
+The problem is that `lcl_env :: TcLclEnv` has an IORef for error
+messages `tcl_errs`, and another for constraints (`tcl_lie`),a and
+another for Linear Haskell usage information (`tcl_usage`). Now
+suppose we change it a tiny bit
+ do { (gbl_env, lcl_env) <- checkNoErrs $
+ tcRnSrcDecls ...
+ ; setGblEnv gbl_env $ setLclEnv lcl_env $
+ more_stuff }
+
+That should be innocuous. But *alas*, `checkNoErrs` gathers errors in
+a fresh IORef *which is then captured in the returned `lcl_env`. When
+we do the `setLclEnv` we'll make that captured IORef into the place
+where we gather error messages -- but no one is going to look at that!!!
+This led to #19470 and #20981.
+
+Solution: instead of setLclEnv use restoreLclEnv, which preserves from
+the /parent/ context these mutable collection IORefs:
+ tcl_errs, tcl_lie, tcl_usage
+-}
-- Command-line flags
@@ -1033,9 +1083,9 @@ checkErr ok msg = unless ok (addErr msg)
addMessages :: Messages TcRnMessage -> TcRn ()
addMessages msgs1
- = do { errs_var <- getErrsVar ;
- msgs0 <- readTcRef errs_var ;
- writeTcRef errs_var (unionMessages msgs0 msgs1) }
+ = do { errs_var <- getErrsVar
+ ; msgs0 <- readTcRef errs_var
+ ; writeTcRef errs_var (msgs0 `unionMessages` msgs1) }
discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
@@ -1343,10 +1393,8 @@ captureConstraints thing_inside
-- returned usage information into the larger context appropriately.
tcCollectingUsage :: TcM a -> TcM (UsageEnv,a)
tcCollectingUsage thing_inside
- = do { env0 <- getLclEnv
- ; local_usage_ref <- newTcRef zeroUE
- ; let env1 = env0 { tcl_usage = local_usage_ref }
- ; result <- setLclEnv env1 thing_inside
+ = do { local_usage_ref <- newTcRef zeroUE
+ ; result <- updLclEnv (\env -> env { tcl_usage = local_usage_ref }) thing_inside
; local_usage <- readTcRef local_usage_ref
; return (local_usage,result) }
@@ -1789,10 +1837,10 @@ discardConstraints thing_inside = fst <$> captureConstraints thing_inside
-- | The name says it all. The returned TcLevel is the *inner* TcLevel.
pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints thing_inside
- = do { env <- getLclEnv
- ; let tclvl' = pushTcLevel (tcl_tclvl env)
+ = do { tclvl <- getTcLevel
+ ; let tclvl' = pushTcLevel tclvl
; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')
- ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+ ; (res, lie) <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) $
captureConstraints thing_inside
; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')
; return (tclvl', lie, res) }
@@ -1803,21 +1851,11 @@ pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl e
pushTcLevelM :: TcM a -> TcM (TcLevel, a)
-- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType
pushTcLevelM thing_inside
- = do { env <- getLclEnv
- ; let tclvl' = pushTcLevel (tcl_tclvl env)
- ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
- thing_inside
+ = do { tclvl <- getTcLevel
+ ; let tclvl' = pushTcLevel tclvl
+ ; res <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) thing_inside
; return (tclvl', res) }
--- Returns pushed TcLevel
-pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
-pushTcLevelsM num_levels thing_inside
- = do { env <- getLclEnv
- ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)
- ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $
- thing_inside
- ; return (res, tclvl') }
-
getTcLevel :: TcM TcLevel
getTcLevel = do { env <- getLclEnv
; return (tcl_tclvl env) }