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

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index c0e20d2..e139cdd 100644 (file)
--- 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 (file)
--- 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}