Commit f5ca07d6 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.)
	
parent c5b03909
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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') }}
......
......@@ -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
......
......@@ -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) }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment