From 0710d446789cc7b3e29f12ab56d9d5315fd4b8af Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Thu, 4 Mar 1999 13:26:49 +0000
Subject: [PATCH] [project @ 1999-03-04 13:26:48 by simonm] Make type
 substitution strict.  This partially fixes the space leak,
 and seems to improve performance marginally.

---
 ghc/compiler/types/Type.lhs |   28 +++++++++++++++-------------
 ghc/compiler/utils/Util.lhs |   16 ++++++++++++++++
 2 files changed, 31 insertions(+), 13 deletions(-)

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index c0e20d2..e139cdd 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -91,7 +91,7 @@ import PrelMods		( pREL_GHC )
 import Maybes		( maybeToBool )
 import PrimRep		( PrimRep(..), isFollowableRep )
 import Unique		-- quite a few *Keys
-import Util		( thenCmp, mapAccumL )
+import Util		( thenCmp, mapAccumL, seqList, ($!) )
 import Outputable
 
 \end{code}
@@ -105,7 +105,7 @@ import Outputable
 A type is
 
 	*unboxed*	iff its representation is other than a pointer
-			Unboxed types cannot instantiate a type variable
+			Unboxed types cannot instantiate a type variable.
 			Unboxed types are always unlifted.
 
 	*lifted*	A type is lifted iff it has bottom as an element.
@@ -791,16 +791,17 @@ fullSubstTy tenv tset ty | isEmptyVarEnv tenv = ty
 subst_ty tenv tset ty
    = go ty
   where
-    go (TyConApp tc tys)	   = TyConApp tc (map go tys)
-    go (NoteTy (SynNote ty1) ty2)  = NoteTy (SynNote (go ty1)) (go ty2)
+    go (TyConApp tc tys)	   = let args = map go tys
+				     in  args `seqList` TyConApp tc args
+    go (NoteTy (SynNote ty1) ty2)  = NoteTy (SynNote $! (go ty1)) $! (go ty2)
     go (NoteTy (FTVNote _) ty2)    = go ty2		-- Discard the free tyvar note
-    go (FunTy arg res)   	   = FunTy (go arg) (go res)
-    go (AppTy fun arg)   	   = mkAppTy (go fun) (go arg)
+    go (FunTy arg res)   	   = (FunTy $! (go arg)) $! (go res)
+    go (AppTy fun arg)   	   = mkAppTy (go fun) $! (go arg)
     go ty@(TyVarTy tv)   	   = case (lookupVarEnv tenv tv) of
 	       			      Nothing  -> ty
        				      Just ty' -> ty'
     go (ForAllTy tv ty)		   = case substTyVar tenv tset tv of
-					(tenv', tset', tv') -> ForAllTy tv' (subst_ty tenv' tset' ty)
+					(tenv', tset', tv') -> ForAllTy tv' $! (subst_ty tenv' tset' ty)
 
 substTyVar ::  TyVarSubst -> TyVarSet -> TyVar
 	   -> (TyVarSubst,   TyVarSet,   TyVar)
@@ -863,15 +864,16 @@ tidyType env@(tidy_env, subst) ty
     go (TyVarTy tv)	    = case lookupVarEnv subst tv of
 				Nothing  -> TyVarTy tv
 				Just tv' -> TyVarTy tv'
-    go (TyConApp tycon tys) = TyConApp tycon (map go tys)
-    go (NoteTy note ty)     = NoteTy (go_note note) (go ty)
-    go (AppTy fun arg)	    = AppTy (go fun) (go arg)
-    go (FunTy fun arg)	    = FunTy (go fun) (go arg)
-    go (ForAllTy tv ty)	    = ForAllTy tv' (tidyType env' ty)
+    go (TyConApp tycon tys) = let args = map go tys
+			      in args `seqList` TyConApp tycon args
+    go (NoteTy note ty)     = (NoteTy $! (go_note note)) $! (go ty)
+    go (AppTy fun arg)	    = (AppTy $! (go fun)) $! (go arg)
+    go (FunTy fun arg)	    = (FunTy $! (go fun)) $! (go arg)
+    go (ForAllTy tv ty)	    = ForAllTy tv' $! (tidyType env' ty)
 			    where
 			      (env', tv') = tidyTyVar env tv
 
-    go_note (SynNote ty)        = SynNote (go ty)
+    go_note (SynNote ty)        = SynNote $! (go ty)
     go_note note@(FTVNote ftvs) = note	-- No need to tidy the free tyvars
 
 tidyTypes  env tys    = map (tidyType env) tys
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 040927e..149ca9d 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -40,6 +40,9 @@ module Util (
 	-- comparisons
 	thenCmp, cmpList,
 
+	-- strictness
+	seqList, ($!),
+
 	-- pairs
 	IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
 	IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
@@ -722,4 +725,17 @@ unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 \end{code}
 
+\begin{code}
+#if __HASKELL1__ > 4
+seqList :: [a] -> b -> b
+#else
+seqList :: (Eval a) => [a] -> b -> b
+#endif
+seqList [] b = b
+seqList (x:xs) b = x `seq` seqList xs b
 
+#if __HASKELL1__ <= 4
+($!)    :: (Eval a) => (a -> b) -> a -> b
+f $! x  = x `seq` f x
+#endif
+\end{code}
-- 
1.7.10.4