From f5ca07d670fd2fcd196aa670890257117a015728 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 8 Feb 2006 15:44:12 +0000 Subject: [PATCH] Do type refinement in TcIface This commit fixes a bug in 6.4.1 and the HEAD. Consider this code, recorded **in an interface file** \(x::a) -> case y of MkT -> case x of { True -> ... } (where MkT forces a=Bool) In the "case x" we need to know x's type, because we use that to find which module to look for "True" in. x's type comes from the envt, so we must refine the envt. The alternative would be to record more info with an IfaceCase, but that would change the interface file format. (This stuff will go away when we have proper coercions.) --- ghc/compiler/coreSyn/CoreLint.lhs | 2 +- ghc/compiler/coreSyn/CoreTidy.lhs | 8 +++----- ghc/compiler/iface/IfaceEnv.lhs | 16 +++++++++++++--- ghc/compiler/iface/TcIface.lhs | 11 ++++++++++- ghc/compiler/simplCore/Simplify.lhs | 2 +- ghc/compiler/types/Unify.lhs | 9 ++++----- 6 files changed, 32 insertions(+), 16 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index be323be..dda8290 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -472,7 +472,7 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) ; subst <- getTvSubst ; let in_scope = getTvInScope subst subst_env = getTvSubstEnv subst - ; case coreRefineTys in_scope con tvs scrut_ty of { + ; case coreRefineTys con tvs scrut_ty of { Nothing -> return () ; -- Alternative is dead code Just (refine, _) -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $ do { addLoc (CasePat alt) $ do diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index ad01474..ba60466 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -18,7 +18,7 @@ import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique, import IdInfo ( setArityInfo, vanillaIdInfo, newStrictnessInfo, setAllStrictnessInfo, newDemandInfo, setNewDemandInfo ) -import Type ( Type, tidyType, tidyTyVarBndr, substTy, mkTvSubst ) +import Type ( Type, tidyType, tidyTyVarBndr, substTy, mkOpenTvSubst ) import Var ( Var, TyVar, varName ) import VarEnv import UniqFM ( lookupUFM ) @@ -96,7 +96,7 @@ tidyAlt case_bndr env (con, vs, rhs) refineTidyEnv :: TidyEnv -> DataCon -> [TyVar] -> Type -> TidyEnv -- Refine the TidyEnv in the light of the type refinement from coreRefineTys refineTidyEnv tidy_env@(occ_env, var_env) con tvs scrut_ty - = case coreRefineTys in_scope con tvs scrut_ty of + = case coreRefineTys con tvs scrut_ty of Nothing -> tidy_env Just (tv_subst, all_bound_here) | all_bound_here -- Local type refinement only @@ -106,13 +106,11 @@ refineTidyEnv tidy_env@(occ_env, var_env) con tvs scrut_ty -- And that means that exprType will work right everywhere -> (occ_env, mapVarEnv (refine subst) var_env) where - subst = mkTvSubst in_scope tv_subst + subst = mkOpenTvSubst tv_subst where refine subst var | isId var = setIdType var (substTy subst (idType var)) | otherwise = var - in_scope = mkInScopeSet var_env -- Seldom used - ------------ Notes -------------- tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2) tidyNote env note = note diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index f0570cc..40b7d31 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -6,7 +6,7 @@ module IfaceEnv ( lookupIfaceTop, lookupIfaceExt, lookupOrig, lookupIfaceTc, newIfaceName, newIfaceNames, - extendIfaceIdEnv, extendIfaceTyVarEnv, + extendIfaceIdEnv, extendIfaceTyVarEnv, refineIfaceIdEnv, tcIfaceLclId, tcIfaceTyVar, lookupAvail, ifaceExportNames, @@ -22,16 +22,18 @@ import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName ) import TysWiredIn ( tupleTyCon, tupleCon ) import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..), IfaceExport, OrigNameCache ) +import Type ( mkOpenTvSubst, substTy ) import TyCon ( TyCon, tyConName ) +import Unify ( TypeRefinement ) import DataCon ( dataConWorkId, dataConName ) -import Var ( TyVar, Id, varName ) +import Var ( TyVar, Id, varName, setIdType, idType ) import Name ( Name, nameUnique, nameModule, nameOccName, nameSrcLoc, getOccName, nameParent_maybe, isWiredInName, mkIPName, mkExternalName, mkInternalName ) import NameSet ( NameSet, emptyNameSet, addListToNameSet ) -import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, +import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv, lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList ) import PrelNames ( gHC_PRIM, pREL_TUP ) import Module ( Module, emptyModuleEnv, @@ -290,6 +292,14 @@ tcIfaceLclId occ `orElse` pprPanic "tcIfaceLclId" (ppr occ)) } +refineIfaceIdEnv :: TypeRefinement -> IfL a -> IfL a +refineIfaceIdEnv (tv_subst, _) thing_inside + = do { env <- getLclEnv + ; let { id_env' = mapOccEnv refine_id (if_id_env env) + ; refine_id id = setIdType id (substTy subst (idType id)) + ; subst = mkOpenTvSubst tv_subst } + ; setLclEnv (env { if_id_env = id_env' }) thing_inside } + extendIfaceIdEnv :: [Id] -> IfL a -> IfL a extendIfaceIdEnv ids thing_inside = do { env <- getLclEnv diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 6726adf..e2a71ce 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -17,7 +17,7 @@ import LoadIface ( loadInterface, loadWiredInHomeIface, loadDecls, findAndReadIface ) import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, + tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, refineIfaceIdEnv, newIfaceName, newIfaceNames, ifaceExportNames ) import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) @@ -31,6 +31,7 @@ import HscTypes ( ExternalPackageState(..), ModIface(..), ModDetails(..), HomeModInfo(..), emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds ) import InstEnv ( Instance(..), mkImportedInstance ) +import Unify ( coreRefineTys ) import CoreSyn import CoreUtils ( exprType ) import CoreUnfold @@ -676,8 +677,16 @@ tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs) ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys ) zipWith mkLocalId id_names arg_tys + Just refine = coreRefineTys con tyvars (mkTyConApp tycon inst_tys) + ; rhs' <- extendIfaceTyVarEnv tyvars $ extendIfaceIdEnv arg_ids $ + refineIfaceIdEnv refine $ + -- You might think that we don't need to refine the envt here, + -- but we do: \(x::a) -> case y of + -- MkT -> case x of { True -> ... } + -- In the "case x" we need to know x's type, because we use that + -- to find which module to look for "True" in. Sigh. tcIfaceExpr rhs ; return (DataAlt con, tyvars ++ arg_ids, rhs') }} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 17a7969..223d61a 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -1523,7 +1523,7 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont' (tvs,ids) = span isTyVar vs in simplBinders env tvs `thenSmpl` \ (env1, tvs') -> - case coreRefineTys (getInScope env1) con tvs' (idType case_bndr') of { + case coreRefineTys con tvs' (idType case_bndr') of { Nothing -- Inaccessible | opt_PprStyle_Debug -- Hack: if debugging is on, generate an error case -- so we can see it diff --git a/ghc/compiler/types/Unify.lhs b/ghc/compiler/types/Unify.lhs index 1443498..f60c7be 100644 --- a/ghc/compiler/types/Unify.lhs +++ b/ghc/compiler/types/Unify.lhs @@ -21,7 +21,7 @@ import VarSet import Kind ( isSubKind ) import Type ( typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, mkTyVarTys, TvSubstEnv, emptyTvSubstEnv, TvSubst(..), substTy, tcEqTypeX, - tcView ) + mkOpenTvSubst, tcView ) import TypeRep ( Type(..), PredType(..), funTyCon ) import DataCon ( DataCon, dataConInstResTy ) import Util ( snocView ) @@ -222,8 +222,7 @@ tcUnifyTys bind_fn tys1 tys2 tvs2 = tyVarsOfTypes tys2 ---------------------------- -coreRefineTys :: InScopeSet -- Superset of free vars of either type - -> DataCon -> [TyVar] -- Case pattern (con tv1 .. tvn ...) +coreRefineTys :: DataCon -> [TyVar] -- Case pattern (con tv1 .. tvn ...) -> Type -- Type of scrutinee -> Maybe TypeRefinement @@ -234,13 +233,13 @@ type TypeRefinement = (TvSubstEnv, Bool) -- for already-in-scope type variables -- Used by Core Lint and the simplifier. -coreRefineTys in_scope con tvs scrut_ty +coreRefineTys con tvs scrut_ty = maybeErrToMaybe $ initUM (tryToBind tv_set) $ do { -- Run the unifier, starting with an empty env ; subst_env <- unify emptyTvSubstEnv pat_res_ty scrut_ty -- Find the fixed point of the resulting non-idempotent substitution - ; let subst = TvSubst in_scope subst_env_fixpt + ; let subst = mkOpenTvSubst subst_env_fixpt subst_env_fixpt = mapVarEnv (substTy subst) subst_env ; return (subst_env_fixpt, all_bound_here subst_env) } -- 1.7.10.4