X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreTidy.lhs;h=a2a56c66a61da8ce1c902b1f191cb344e12aae94;hb=a84285247bfb162fdefc3fcb8be88c34c1f5cd35;hp=bf8a2c592f6236f86bb0382d69fd20ea1feaba82;hpb=19108ede05d6528d0b66edb2bcf031e8da9522e2;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index bf8a2c5..a2a56c6 100644
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -9,8 +9,7 @@
 
 \begin{code}
 module CoreTidy (
-	tidyBind, tidyExpr, 
-	tidyBndr, tidyBndrs, tidyVarOcc,
+	tidyExpr, tidyVarOcc,
 	tidyIdRules, pprTidyIdRules
     ) where
 
@@ -18,14 +17,16 @@ module CoreTidy (
 
 import CoreSyn
 import CoreUtils	( exprArity )
+import Unify		( coreRefineTys )
 import PprCore		( pprIdRules )
+import DataCon		( DataCon, isVanillaDataCon )
 import Id		( Id, mkUserLocal, idInfo, setIdInfo, idUnique,
-			  idType, idCoreRules )
-import IdInfo		( setArityInfo, noCafIdInfo,
+			  idType, setIdType, idCoreRules )
+import IdInfo		( setArityInfo, vanillaIdInfo,
 			  newStrictnessInfo, setAllStrictnessInfo,
 			  newDemandInfo, setNewDemandInfo )
-import Type		( tidyType, tidyTyVarBndr )
-import Var		( Var )
+import Type		( Type, tidyType, tidyTyVarBndr, substTy, mkTvSubst )
+import Var		( Var, TyVar )
 import VarEnv
 import Name		( getOccName )
 import OccName		( tidyOccName )
@@ -72,19 +73,52 @@ tidyExpr env (Let b e)
   = tidyBind env b 	=: \ (env', b') ->
     Let b' (tidyExpr env' e)
 
-tidyExpr env (Case e b alts)
+tidyExpr env (Case e b ty alts)
   = tidyBndr env b 	=: \ (env', b) ->
-    Case (tidyExpr env e) b (map (tidyAlt env') alts)
+    Case (tidyExpr env e) b (tidyType env ty) 
+	 (map (tidyAlt b env') alts)
 
 tidyExpr env (Lam b e)
   = tidyBndr env b 	=: \ (env', b) ->
     Lam b (tidyExpr env' e)
 
 ------------  Case alternatives  --------------
-tidyAlt env (con, vs, rhs)
+tidyAlt case_bndr env (DataAlt con, vs, rhs)
+  | not (isVanillaDataCon con)	-- GADT case
+  = tidyBndrs env tvs	 	=: \ (env1, tvs') ->
+    let 
+	env2 = refineTidyEnv env con tvs' scrut_ty
+    in
+    tidyBndrs env2 ids 	=: \ (env3, ids') ->
+    (DataAlt con, tvs' ++ ids', tidyExpr env3 rhs)
+  where 
+    (tvs, ids) = span isTyVar vs
+    scrut_ty = idType case_bndr
+
+tidyAlt case_bndr env (con, vs, rhs)
   = tidyBndrs env vs 	=: \ (env', vs) ->
     (con, vs, tidyExpr env' 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
+	Nothing -> tidy_env
+	Just (tv_subst, all_bound_here)
+	    | all_bound_here 	-- Local type refinement only
+	    -> tidy_env
+	    | otherwise  	-- Apply the refining subst to the tidy env
+				-- This ensures that occurences have the most refined type
+				-- And that means that exprType will work right everywhere
+	    -> (occ_env, mapVarEnv (refine subst) var_env)
+	    where
+	      subst = mkTvSubst in_scope 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
@@ -93,10 +127,10 @@ tidyNote env note            = note
 ------------  Rules  --------------
 tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
 tidyIdRules env [] = []
-tidyIdRules env ((fn,rule) : rules)
+tidyIdRules env (IdCoreRule fn is_orph rule : rules)
   = tidyRule env rule  		=: \ rule ->
     tidyIdRules env rules 	=: \ rules ->
-     ((tidyVarOcc env fn, rule) : rules)
+    (IdCoreRule (tidyVarOcc env fn) is_orph rule : rules)
 
 tidyRule :: TidyEnv -> CoreRule -> CoreRule
 tidyRule env rule@(BuiltinRule _ _) = rule
@@ -149,11 +183,9 @@ tidyLetBndr env (id,rhs)
 	--
 	-- Similarly arity info for eta expansion in CorePrep
 	--
-	-- CafInfo is NoCafRefs, because this is not a top-level Id.
-	--
     final_id = new_id `setIdInfo` new_info
     idinfo   = idInfo id
-    new_info = noCafIdInfo -- NB. no CAF refs!
+    new_info = vanillaIdInfo
 		`setArityInfo`		exprArity rhs
 		`setAllStrictnessInfo`	newStrictnessInfo idinfo
 		`setNewDemandInfo`	newDemandInfo idinfo
@@ -173,12 +205,12 @@ tidyIdBndr env@(tidy_env, var_env) id
 	-- The SrcLoc isn't important now, 
 	-- though we could extract it from the Id
 	-- 
-	-- All nested Ids now have the same IdInfo, namely noCafIdInfo,
+	-- All nested Ids now have the same IdInfo, namely vanillaIdInfo,
 	-- which should save some space.
 	-- But note that tidyLetBndr puts some of it back.
         ty'          	  = tidyType env (idType id)
 	id'          	  = mkUserLocal occ' (idUnique id) ty' noSrcLoc
-				`setIdInfo` noCafIdInfo
+				`setIdInfo` vanillaIdInfo
 	var_env'	  = extendVarEnv var_env id id'
     in
      ((tidy_env', var_env'), id')