X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=480357e80b0054ed93bab6b30c62b568c3c8abb0;hp=f4681e40f16c18c60f277a1ebf59eae6483bbec6;hb=121da25a0d638bbe6c7f90525ff50b3a20949bbc;hpb=b70c8066194c34f7368f5f915f94970ea1decb71

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index f4681e4..480357e 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -48,7 +48,7 @@ module Type (
 	splitTyConApp_maybe, splitTyConApp, 
         splitNewTyConApp_maybe, splitNewTyConApp,
 
-	repType, typePrimRep, coreView, tcView, kindView,
+	repType, repType', typePrimRep, coreView, tcView, kindView,
 
 	mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
 	applyTy, applyTys, isForAllTy, dropForAlls,
@@ -94,7 +94,7 @@ module Type (
 	substPred, substTyVar, substTyVarBndr, deShadowTy, lookupTyVar,
 
 	-- Pretty-printing
-	pprType, pprParendType, pprTyThingCategory,
+	pprType, pprParendType, pprTyThingCategory, pprForAll,
 	pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind
     ) where
 
@@ -457,6 +457,16 @@ repType (TyConApp tc tys)
 			   repType (new_type_rep tc tys)
 repType ty = ty
 
+-- repType' aims to be a more thorough version of repType
+-- For now it simply looks through the TyConApp args too
+repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined
+            | otherwise = go1 ty 
+ where 
+        go1 = go . repType
+        go (TyConApp tc tys) = mkTyConApp tc (map repType' tys)
+        go ty = ty
+
+
 -- new_type_rep doesn't ask any questions: 
 -- it just expands newtype, whether recursive or not
 new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon )
@@ -1015,10 +1025,12 @@ cmpTypesX env ty        []        = GT
 -------------
 cmpPredX :: RnEnv2 -> PredType -> PredType -> Ordering
 cmpPredX env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` cmpTypeX env ty1 ty2
-	-- Compare types as well as names for implicit parameters
-	-- This comparison is used exclusively (I think) for the
-	-- finite map built in TcSimplify
-cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` cmpTypesX env tys1 tys2
+	-- Compare names only for implicit parameters
+	-- This comparison is used exclusively (I believe) 
+	-- for the Avails finite map built in TcSimplify
+	-- If the types differ we keep them distinct so that we see 
+	-- a distinct pair to run improvement on 
+cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTypesX env tys1 tys2)
 cmpPredX env (EqPred ty1 ty2) (EqPred ty1' ty2') = (cmpTypeX env ty1 ty1') `thenCmp` (cmpTypeX env ty2 ty2')
 
 -- Constructor order: IParam < ClassP < EqPred
@@ -1047,11 +1059,13 @@ instance Ord PredType where { compare = tcCmpPred }
 data TvSubst 		
   = TvSubst InScopeSet 	-- The in-scope type variables
 	    TvSubstEnv	-- The substitution itself
-			-- See Note [Apply Once]
+	-- See Note [Apply Once]
+	-- and Note [Extending the TvSubstEnv]
 
 {- ----------------------------------------------------------
-	 	Note [Apply Once]
 
+Note [Apply Once]
+~~~~~~~~~~~~~~~~~
 We use TvSubsts to instantiate things, and we might instantiate
 	forall a b. ty
 \with the types
@@ -1068,6 +1082,38 @@ variations happen to; for example [a -> (a, b)].
 
 A TvSubst is not idempotent, but, unlike the non-idempotent substitution
 we use during unifications, it must not be repeatedly applied.
+
+Note [Extending the TvSubst]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The following invariant should hold of a TvSubst
+
+	The in-scope set is needed *only* to
+	guide the generation of fresh uniques
+
+	In particular, the *kind* of the type variables in 
+	the in-scope set is not relevant
+
+This invariant allows a short-cut when the TvSubstEnv is empty:
+if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds ---
+then (substTy subst ty) does nothing.
+
+For example, consider:
+	(/\a. /\b:(a~Int). ...b..) Int
+We substitute Int for 'a'.  The Unique of 'b' does not change, but
+nevertheless we add 'b' to the TvSubstEnv, because b's type does change
+
+This invariant has several crucial consequences:
+
+* In substTyVarBndr, we need extend the TvSubstEnv 
+	- if the unique has changed
+	- or if the kind has changed
+
+* In substTyVar, we do not need to consult the in-scope set;
+  the TvSubstEnv is enough
+
+* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty
+  
+
 -------------------------------------------------------------- -}
 
 
@@ -1096,6 +1142,7 @@ composeTvSubst in_scope env1 env2
 emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
 
 isEmptyTvSubst :: TvSubst -> Bool
+	 -- See Note [Extending the TvSubstEnv]
 isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env
 
 mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst
@@ -1254,17 +1301,19 @@ subst_ty subst ty
 substTyVar :: TvSubst -> TyVar  -> Type
 substTyVar subst@(TvSubst in_scope env) tv
   = case lookupTyVar subst tv of {
-	Nothing  -> TyVarTy tv;
+	Nothing -> TyVarTy tv;
        	Just ty -> ty	-- See Note [Apply Once]
     } 
 
 lookupTyVar :: TvSubst -> TyVar  -> Maybe Type
+	-- See Note [Extending the TvSubst]
 lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv
 
 substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)	
 substTyVarBndr subst@(TvSubst in_scope env) old_var
   = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var)
   where
+    is_co_var = isCoVar old_var
 
     new_env | no_change = delVarEnv env old_var
 	    | otherwise = extendVarEnv env old_var (TyVarTy new_var)
@@ -1272,6 +1321,7 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var
     no_change = new_var == old_var && not is_co_var
 	-- no_change means that the new_var is identical in
 	-- all respects to the old_var (same unique, same kind)
+	-- See Note [Extending the TvSubst]
 	--
 	-- In that case we don't need to extend the substitution
 	-- to map old to new.  But instead we must zap any 
@@ -1283,12 +1333,10 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var
 	-- The uniqAway part makes sure the new variable is not already in scope
 
     subst_old_var -- subst_old_var is old_var with the substitution applied to its kind
-		 -- It's only worth doing the substitution for coercions,
-		 -- becuase only they can have free type variables
-	| is_co_var = setTyVarKind old_var (substTy subst kind)
+		  -- It's only worth doing the substitution for coercions,
+		  -- becuase only they can have free type variables
+	| is_co_var = setTyVarKind old_var (substTy subst (tyVarKind old_var))
 	| otherwise = old_var
-    kind = tyVarKind old_var
-    is_co_var = isCoVar old_var
 \end{code}
 
 ----------------------------------------------------