New statistics flags -ddump-core-stats

[ghc-hetmet.git] / compiler / types / Type.lhs

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index fa5f46a..5f348ef 100644 (file)
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -74,7 +74,8 @@ module Type (
 
        -- * Type free variables
        tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
-       expandTypeSynonyms,
+       expandTypeSynonyms, 
+       typeSize,
 
        -- * Type comparison
        coreEqType, coreEqType2,
@@ -105,7 +106,7 @@ module Type (
        getTvSubstEnv, setTvSubstEnv, zapTvSubstEnv, getTvInScope, 
         extendTvInScope, extendTvInScopeList,
        extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
-        isEmptyTvSubst,
+        isEmptyTvSubst, unionTvSubst,
 
        -- ** Performing substitution on types
        substTy, substTys, substTyWith, substTysWith, substTheta, 
@@ -857,6 +858,28 @@ tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
 
 %************************************************************************
 %*                                                                     *
+                   Size                                                                        
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+typeSize :: Type -> Int
+typeSize (TyVarTy _)     = 1
+typeSize (AppTy t1 t2)   = typeSize t1 + typeSize t2
+typeSize (FunTy t1 t2)   = typeSize t1 + typeSize t2
+typeSize (PredTy p)      = predSize p
+typeSize (ForAllTy _ t)  = 1 + typeSize t
+typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts)
+
+predSize :: PredType -> Int
+predSize (IParam _ t)   = 1 + typeSize t
+predSize (ClassP _ ts)  = 1 + sum (map typeSize ts)
+predSize (EqPred t1 t2) = typeSize t1 + typeSize t2
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
 \subsection{Type families}
 %*                                                                     *
 %************************************************************************
@@ -1320,6 +1343,13 @@ extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst
 extendTvSubstList (TvSubst in_scope env) tvs tys 
   = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys))
 
+unionTvSubst :: TvSubst -> TvSubst -> TvSubst
+-- Works when the ranges are disjoint
+unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2)
+  = ASSERT( not (env1 `intersectsVarEnv` env2) )
+    TvSubst (in_scope1 `unionInScope` in_scope2)
+            (env1      `plusVarEnv`   env2)
+
 -- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from
 -- the types given; but it's just a thunk so with a bit of luck
 -- it'll never be evaluated