Commit 0710d446 authored by simonm's avatar simonm

[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.
parent bacf674b
......@@ -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
......
......@@ -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}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment