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.)

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index be323be..dda8290 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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) }