[Git][ghc/ghc][wip/int-index/term-capture] 2 commits: Undo tcAddTermVarPlaceholders
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Thu Nov 23 19:17:24 UTC 2023
Vladislav Zavialov pushed to branch wip/int-index/term-capture at Glasgow Haskell Compiler / GHC
Commits:
a7e45e8c by Vladislav Zavialov at 2023-11-23T21:51:23+03:00
Undo tcAddTermVarPlaceholders
- - - - -
f5dac93e by Vladislav Zavialov at 2023-11-23T22:16:56+03:00
Alternative fix to the GHC panic
- - - - -
10 changed files:
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/Env.hs
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
Changes:
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -300,7 +300,6 @@ keepRenamedSource _ gbl_env group =
update_exports Nothing = Just []
update_exports m = m
- update :: Maybe (HsGroup GhcRn) -> Maybe (HsGroup GhcRn)
update Nothing = Just emptyRnGroup
update m = m
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -132,7 +132,6 @@ import GHC.Data.Bag
import GHC.Data.Maybe
import Data.Data (Data)
import Data.Foldable (toList)
-import qualified Data.Semigroup as S
{-
************************************************************************
@@ -194,21 +193,15 @@ partitionBindsAndSigs = go
instance Outputable (DocDecl name) where
ppr _ = text "<document comment>"
-type instance XCHsGroup GhcPs = ()
-type instance XCHsGroup GhcRn = NameSet
- -- Names bound in the HsGroup. Term variables from this set are used
- -- in tcTopSrcDecls as an argument to tcAddTermVarPlaceholders.
- -- See Note [Demotion of unqualified variables] (W1) in GHC.Rename.Env
-type instance XCHsGroup GhcTc = NameSet
-
+type instance XCHsGroup (GhcPass _) = NoExtField
type instance XXHsGroup (GhcPass _) = DataConCantHappen
-emptyGroup, emptyRdrGroup, emptyRnGroup :: Monoid (XCHsGroup (GhcPass p)) => HsGroup (GhcPass p)
+emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
-emptyGroup = HsGroup { hs_ext = mempty,
+emptyGroup = HsGroup { hs_ext = noExtField,
hs_tyclds = [],
hs_derivds = [],
hs_fixds = [], hs_defds = [], hs_annds = [],
@@ -229,12 +222,10 @@ hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =
, L loc (FixSig _ sig) <- sigs
]
-appendGroups :: Semigroup (XCHsGroup (GhcPass p))
- => HsGroup (GhcPass p) -> HsGroup (GhcPass p)
+appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)
-> HsGroup (GhcPass p)
appendGroups
HsGroup {
- hs_ext = ext1,
hs_valds = val_groups1,
hs_splcds = spliceds1,
hs_tyclds = tyclds1,
@@ -247,7 +238,6 @@ appendGroups
hs_ruleds = rulds1,
hs_docs = docs1 }
HsGroup {
- hs_ext = ext2,
hs_valds = val_groups2,
hs_splcds = spliceds2,
hs_tyclds = tyclds2,
@@ -261,7 +251,7 @@ appendGroups
hs_docs = docs2 }
=
HsGroup {
- hs_ext = ext1 S.<> ext2,
+ hs_ext = noExtField,
hs_valds = val_groups1 `plusHsValBinds` val_groups2,
hs_splcds = spliceds1 ++ spliceds2,
hs_tyclds = tyclds1 ++ tyclds2,
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -1174,11 +1174,13 @@ that up instead. If that succeeds, use it.
in the environment just yet, because type declarations and signatures are
type-checked /before/ term-level bindings.
- To report a proper user-facing error message instead of a GHC panic,
- we proactively populate the environment with the `TermVariablePE` promotion
- error, one for each term variable in the current HsGroup (at the top level)
- or in the current HsValBinds (at the level of local let/where bindings).
- This is done with tactically placed calls to `tcAddTermVarPlaceholders`.
+ This means that the type checker will not find the variable in the environment
+ at all. If the namespace of the variable is `varName`, the only explanation
+ is that the user tried to use a term variable in a type context (either that or
+ a bug in GHC), so we report `TermVariablePE` instead of a GHC panic.
+ See the following clause in `notFound`:
+ _ | isTermVarOrFieldNameSpace (nameNameSpace name) ->
+ failWithTc $ TcRnUnpromotableThing name TermVariablePE
(W2) Wrinkle 2
Only unqualified variable names are demoted, e.g. `f` but not `M.f`.
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -211,7 +211,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
last_tcg_env <- getGblEnv ;
-- (I) Compute the results and return
- let {rn_group = HsGroup { hs_ext = all_bndrs,
+ let {rn_group = HsGroup { hs_ext = noExtField,
hs_valds = rn_val_decls,
hs_splcds = rn_splice_decls,
hs_tyclds = rn_tycl_decls,
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -189,14 +189,13 @@ Then we get
fm
-}
-tcTopBinds :: NameSet -- Term variables that need placeholders
- -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
+tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM (TcGblEnv, TcLclEnv)
-- The TcGblEnv contains the new tcg_binds and tcg_spects
-- The TcLclEnv has an extended type envt for the new bindings
-tcTopBinds tm_vars binds sigs
+tcTopBinds binds sigs
= do { -- Pattern synonym bindings populate the global environment
- (binds', (tcg_env, tcl_env)) <- tcValBinds tm_vars TopLevel binds sigs getEnvs
+ (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs getEnvs
; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids
; complete_matches <- restoreEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs
@@ -258,9 +257,8 @@ tcLocalBinds (EmptyLocalBinds x) thing_inside
= do { thing <- thing_inside
; return (EmptyLocalBinds x, thing) }
-tcLocalBinds local_binds@(HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
- = do { let tm_vars = mkNameSet (collectLocalBinders CollNoDictBinders local_binds)
- ; (binds', thing) <- tcValBinds tm_vars NotTopLevel binds sigs thing_inside
+tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
+ = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
@@ -299,19 +297,17 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
toDict ipClass x ty = mkHsWrap $ mkWpCastR $
wrapIP $ mkClassPred ipClass [x,ty]
-tcValBinds :: NameSet -- Term variables that need placeholders
- -> TopLevelFlag
+tcValBinds :: TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
-tcValBinds tmvars top_lvl binds sigs thing_inside
+tcValBinds top_lvl binds sigs thing_inside
= do { -- Typecheck the signatures
-- It's easier to do so now, once for all the SCCs together
-- because a single signature f,g :: <type>
-- might relate to more than one SCC
- (poly_ids, sig_fn) <- tcAddTermVarPlaceholders tmvars $
- tcAddPatSynPlaceholders patsyns $
+ (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
tcTySigs sigs
-- Extend the envt right away with all the Ids
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -1599,8 +1599,7 @@ rnTopSrcDecls group
}
tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls (HsGroup { hs_ext = all_bndrs,
- hs_tyclds = tycl_decls,
+tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
@@ -1612,28 +1611,19 @@ tcTopSrcDecls (HsGroup { hs_ext = all_bndrs,
-- The latter come in via tycl_decls
traceTc "Tc2 (src)" empty ;
- -- Term variables bound in the current group. Used as an argument to
- -- tcAddTermVarPlaceholders until we type-check the actual bindings.
- -- See Note [Demotion of unqualified variables] (W1) in GHC.Rename.Env
- let { tm_vars :: NameSet
- ; tm_vars = filterNameSet (isVarName <||> isFieldName) all_bndrs } ;
-
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc "Tc3" empty ;
(tcg_env, inst_infos, th_bndrs,
XValBindsLR (NValBinds deriv_binds deriv_sigs))
- <- tcAddTermVarPlaceholders tm_vars $
- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
+ <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $
setGblEnv tcg_env $ do {
-- Foreign import declarations next.
traceTc "Tc4" empty ;
- (fi_ids, fi_decls, fi_gres)
- <- tcAddTermVarPlaceholders tm_vars $
- tcForeignImports foreign_decls ;
+ (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $ do {
-- Default declarations
@@ -1647,14 +1637,14 @@ tcTopSrcDecls (HsGroup { hs_ext = all_bndrs,
-- may be defined in terms of the former. (For instance,
-- the bindings produced in a Data instance.)
traceTc "Tc5" empty ;
- tc_envs <- tcTopBinds tm_vars val_binds val_sigs;
+ tc_envs <- tcTopBinds val_binds val_sigs;
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 tm_vars deriv_binds deriv_sigs) ;
+ <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;
restoreEnvs tc_envs $ do { -- Environment doesn't change now
-- Second pass over class and instance declarations,
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -72,7 +72,6 @@ import GHC.Types.SourceText
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Reader ( mkRdrUnqual )
-import GHC.Types.Name.Set ( emptyNameSet )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Var.Env
@@ -847,7 +846,7 @@ tcRecSelBinds sel_bind_prs
do { (rec_sel_binds, tcg_env) <- discardWarnings $
-- See Note [Impredicative record selectors]
setXOptM LangExt.ImpredicativeTypes $
- tcValBinds emptyNameSet TopLevel binds sigs getGblEnv
+ tcValBinds TopLevel binds sigs getGblEnv
; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }
where
sigs = [ L (noAnnSrcSpan loc) (XSig $ IdSig sel_id)
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -44,7 +44,6 @@ module GHC.Tc.Utils.Env(
wrongThingErr, pprBinders,
tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, tcAddKindSigPlaceholders,
- tcAddTermVarPlaceholders,
getTypeSigNames,
tcExtendRecEnv, -- For knot-tying
@@ -125,7 +124,7 @@ import GHC.Types.Id
import GHC.Types.Id.Info ( RecSelParent(..) )
import GHC.Types.Name.Reader
import GHC.Types.TyThing
-import GHC.Types.Unique.Set ( nonDetEltsUniqSet, getUniqSet )
+import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
import qualified GHC.LanguageExtensions as LangExt
import Data.IORef
@@ -711,11 +710,6 @@ tcAddKindSigPlaceholders kind_sig thing_inside
| name <- hsScopedKvs kind_sig ]
thing_inside
-tcAddTermVarPlaceholders :: NameSet -> TcM a -> TcM a
-tcAddTermVarPlaceholders term_names thing_inside
- = tcExtendKindEnv (APromotionErr TermVariablePE <$ getUniqSet term_names)
- thing_inside
-
getTypeSigNames :: [LSig GhcRn] -> NameSet
-- Get the names that have a user type sig
getTypeSigNames sigs
@@ -1081,7 +1075,14 @@ notFound name
| isUnboundName name -> failM -- If the name really isn't in scope
-- don't report it again (#11941)
| otherwise -> failWithTc (TcRnStageRestriction (StageCheckSplice name))
- _ -> failWithTc $
+
+ -- This has to be a promotion error, i.e. an attempt to use a term-level
+ -- variable at the type level (either that or a bug in GHC).
+ -- See Note [Demotion of unqualified variables] (W1) in GHC.Rename.Env
+ _ | isTermVarOrFieldNameSpace (nameNameSpace name) ->
+ failWithTc $ TcRnUnpromotableThing name TermVariablePE
+
+ | otherwise -> failWithTc $
mkTcRnNotInScope (getRdrName name) (NotInScopeTc (getLclEnvTypeEnv lcl_env))
-- Take care: printing the whole gbl env can
-- cause an infinite loop, in the case where we
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -4,19 +4,7 @@
(Just
((,,,)
(HsGroup
- {NameSet:
- [{Name: DumpRenamedAst.C}
- ,{Name: DumpRenamedAst.F}
- ,{Name: DumpRenamedAst.F1}
- ,{Name: DumpRenamedAst.Length}
- ,{Name: DumpRenamedAst.MkT}
- ,{Name: DumpRenamedAst.Nat}
- ,{Name: DumpRenamedAst.Nat}
- ,{Name: DumpRenamedAst.Peano}
- ,{Name: DumpRenamedAst.Succ}
- ,{Name: DumpRenamedAst.T}
- ,{Name: DumpRenamedAst.Zero}
- ,{Name: DumpRenamedAst.main}]}
+ (NoExtField)
(XValBindsLR
(NValBinds
[((,)
=====================================
testsuite/tests/parser/should_compile/T14189.stderr
=====================================
@@ -4,12 +4,7 @@
(Just
((,,,)
(HsGroup
- {NameSet:
- [{Name: T14189.F}
- ,{Name: T14189.MT}
- ,{Name: T14189.MyType}
- ,{Name: T14189.NT}
- ,{Name: T14189.f}]}
+ (NoExtField)
(XValBindsLR
(NValBinds
[]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/31a4bc49f1d27bc34af613256838ffc8e3f7e20b...f5dac93ea6511c73b595eeeb6cf3b762b5f64a54
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/31a4bc49f1d27bc34af613256838ffc8e3f7e20b...f5dac93ea6511c73b595eeeb6cf3b762b5f64a54
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/20231123/8fdefe53/attachment-0001.html>
More information about the ghc-commits
mailing list