From c3cf681e8f65430d4e0dcef08c8f7b75332a034e Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 16 Jul 1999 09:36:08 +0000
Subject: [PATCH] [project @ 1999-07-16 09:36:07 by simonpj] * Fix
long-standing bug in TcIfaceSig which meant it occasionally complained
about a lint error in an unfolding, with a locally-defined name not being
in scope. This only happened when hi-boot loops were being tied, so an
unfolding might mention a locally-defined name.
---
ghc/compiler/typecheck/TcEnv.lhs | 4 ++++
ghc/compiler/typecheck/TcIfaceSig.lhs | 32 +++++++++++++--------------
ghc/compiler/typecheck/TcMonoType.lhs | 5 ++---
3 files changed, 22 insertions(+), 19 deletions(-)
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 586c5a5960fe..49da0db77b87 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -22,6 +22,7 @@ module TcEnv(
tcLookupValue, tcLookupValueMaybe,
tcLookupValueByKey, tcLookupValueByKeyMaybe,
explicitLookupValueByKey, explicitLookupValue,
+ valueEnvIds,
newLocalId, newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars,
@@ -152,6 +153,9 @@ type UsageEnv = NameEnv UVar
type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing)
type ValueEnv = NameEnv Id
+valueEnvIds :: ValueEnv -> [Id]
+valueEnvIds ve = eltsUFM ve
+
data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable
-- if the kind is mutable, the tyvar must be so that
-- zonking works
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 4aba2a126664..bb63100b1640 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -19,7 +19,7 @@ import TcMonoType ( tcHsType, tcHsTypeKind,
import TcEnv ( ValueEnv, tcExtendTyVarEnv,
tcExtendGlobalValEnv, tcSetValueEnv,
tcLookupTyConByKey, tcLookupValueMaybe,
- explicitLookupValue, badCon, badPrimOp
+ explicitLookupValue, badCon, badPrimOp, valueEnvIds
)
import TcType ( TcKind, kindToTcKind )
@@ -42,7 +42,7 @@ import DataCon ( dataConSig, dataConArgTys )
import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, unUsgTy )
import Var ( IdOrTyVar, mkTyVar, tyVarKind )
import VarEnv
-import Name ( Name, NamedThing(..) )
+import Name ( Name, NamedThing(..), isLocallyDefined )
import Unique ( rationalTyConKey )
import TysWiredIn ( integerTy, stringTy )
import Demand ( wwLazy )
@@ -65,23 +65,23 @@ tcInterfaceSigs :: ValueEnv -- Envt to use when checking unfoldings
-> TcM s [Id]
-tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
- = tcAddSrcLoc src_loc (
- tcAddErrCtxt (ifaceSigCtxt name) (
- tcHsType ty `thenTc` \ sigma_ty ->
- tcIdInfo unf_env name sigma_ty vanillaIdInfo id_infos `thenTc` \ id_info ->
+tcInterfaceSigs unf_env decls
+ = listTc [ do_one name ty id_infos src_loc
+ | SigD (IfaceSig name ty id_infos src_loc) <- decls]
+ where
+ in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
+
+ do_one name ty id_infos src_loc
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (ifaceSigCtxt name) $
+ tcHsType ty `thenTc` \ sigma_ty ->
+ tcIdInfo unf_env in_scope_vars name
+ sigma_ty vanillaIdInfo id_infos `thenTc` \ id_info ->
returnTc (mkId name sigma_ty id_info)
- )) `thenTc` \ sig_id ->
- tcInterfaceSigs unf_env rest `thenTc` \ sig_ids ->
- returnTc (sig_id : sig_ids)
-
-tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
-
-tcInterfaceSigs unf_env [] = returnTc []
\end{code}
\begin{code}
-tcIdInfo unf_env name ty info info_ins
+tcIdInfo unf_env in_scope_vars name ty info info_ins
= foldlTc tcPrag vanillaIdInfo info_ins
where
tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
@@ -91,7 +91,7 @@ tcIdInfo unf_env name ty info info_ins
tcPrag info (HsUnfold inline_prag maybe_expr)
= (case maybe_expr of
- Just expr -> tcPragExpr unf_env name [] expr
+ Just expr -> tcPragExpr unf_env name in_scope_vars expr
Nothing -> returnNF_Tc Nothing
) `thenNF_Tc` \ maybe_expr' ->
let
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 6569592e3ec0..86963d37e003 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -21,7 +21,7 @@ import TcHsSyn ( TcId )
import TcMonad
import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars,
tcExtendUVarEnv, tcLookupUVar,
- tcGetGlobalTyVars, TcTyThing(..)
+ tcGetGlobalTyVars, valueEnvIds, TcTyThing(..)
)
import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
typeToTcType, kindToTcKind,
@@ -51,7 +51,6 @@ import Name ( Name, OccName, isLocallyDefined )
import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy )
import SrcLoc ( SrcLoc )
import Unique ( Unique, Uniquable(..) )
-import UniqFM ( eltsUFM )
import Util ( zipWithEqual, zipLazy, mapAccumL )
import Outputable
\end{code}
@@ -562,7 +561,7 @@ checkSigTyVars sig_tyvars
if tv `elemVarSet` globals -- Error (c)! Type variable escapes
-- The least comprehensible, so put it last
then tcGetValueEnv `thenNF_Tc` \ ve ->
- find_globals tv env (eltsUFM ve) `thenNF_Tc` \ (env1, globs) ->
+ find_globals tv env (valueEnvIds ve) `thenNF_Tc` \ (env1, globs) ->
returnNF_Tc (env1, acc, escape_msg sig_tyvar tv globs : msgs)
else -- All OK
--
GitLab