From 2269b0b4b06a110ad466b914037a763b4dca9190 Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Mon, 20 Oct 1997 10:21:28 +0000
Subject: [PATCH] [project @ 1997-10-20 10:21:11 by simonm] fix for
overloading-related space leak (typecheck/should_run/tcrun002)
---
ghc/compiler/basicTypes/Id.lhs | 18 +---
ghc/compiler/typecheck/Inst.lhs | 97 ++++++++++-----------
ghc/compiler/typecheck/TcBinds.lhs | 119 +++++++++++++++++++++-----
ghc/compiler/typecheck/TcExpr.lhs | 4 +-
ghc/compiler/typecheck/TcInstUtil.lhs | 4 +-
ghc/compiler/typecheck/TcMonad.lhs | 5 +-
ghc/compiler/typecheck/TcSimplify.lhs | 2 +-
ghc/compiler/typecheck/TcType.lhs | 8 +-
8 files changed, 162 insertions(+), 95 deletions(-)
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 1e72ae431980..3f4d8e170e76 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -20,7 +20,6 @@ module Id (
mkDictFunId,
mkIdWithNewUniq, mkIdWithNewName, mkIdWithNewType,
mkImported,
- mkInstId,
mkMethodSelId,
mkRecordSelId,
mkSameSpecCon,
@@ -295,10 +294,6 @@ data IdDetails
-- actually do comparisons that way, we kindly supply
-- a Unique for that purpose.
- | InstId -- An instance of a dictionary, class operation,
- -- or overloaded value (Local name)
- Bool -- as for LocalId
-
| SpecId -- A specialisation of another Id
Id -- Id of which this is a specialisation
[Maybe Type] -- Types at which it is specialised;
@@ -422,9 +417,6 @@ to a dictionary for C (T a b ..).
include dictionaries for the immediate superclasses of C at the type
(T a b ..).
-%----------------------------------------------------------------------
-\item[@InstId@:]
-
%----------------------------------------------------------------------
\item[@SpecId@:]
@@ -461,7 +453,7 @@ They are constants, so they are not free variables. (When the STG
machine makes a closure, it puts all the free variables in the
closure; the above are not required.)
\end{itemize}
-Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
+Note that @Locals@ and @SysLocals@ {\em may} have the above
properties, but they may not.
\end{enumerate}
@@ -515,7 +507,6 @@ toplevelishId (Id _ _ _ details _ _)
chk (DictFunId _ _) = True
chk (SpecId unspec _ _) = toplevelishId unspec
-- depends what the unspecialised thing is
- chk (InstId _) = False -- these are local
chk (LocalId _) = False
chk (SysLocalId _) = False
chk (SpecPragmaId _ _) = False
@@ -533,7 +524,6 @@ idHasNoFreeTyVars (Id _ _ _ details _ info)
chk (DefaultMethodId _) = True
chk (DictFunId _ _) = True
chk (SpecId _ _ no_free_tvs) = no_free_tvs
- chk (InstId no_free_tvs) = no_free_tvs
chk (LocalId no_free_tvs) = no_free_tvs
chk (SysLocalId no_free_tvs) = no_free_tvs
chk (SpecPragmaId _ no_free_tvs) = no_free_tvs
@@ -661,7 +651,7 @@ apply_to_Id ty_fn id@(Id u n ty details prag info)
new_maybes = map apply_to_maybe ty_maybes
in
SpecId new_unspec new_maybes (no_free_tvs ty)
- -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
+ -- ToDo: gratuitous recalc no_ftvs????
where
apply_to_maybe Nothing = Nothing
apply_to_maybe (Just ty) = Just (ty_fn ty)
@@ -722,9 +712,6 @@ mkWorkerId u unwrkr ty info
details = LocalId (no_free_tvs ty)
name = mkCompoundName name_fn u (getName unwrkr)
name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str
-
-mkInstId u ty name
- = Id u name ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
\end{code}
%************************************************************************
@@ -991,7 +978,6 @@ dataConFieldLabels x@(Id _ _ _ idt _ _) =
MethodSelId _ -> "m"
DefaultMethodId _ -> "d"
DictFunId _ _ -> "di"
- InstId _ -> "in"
SpecId _ _ _ -> "spec"))
#endif
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 67688c014590..ffd9ec0e00c0 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -17,7 +17,7 @@ module Inst (
newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit,
- instType, tyVarsOfInst, lookupInst, lookupSimpleInst,
+ tyVarsOfInst, lookupInst, lookupSimpleInst,
isDict, isTyVarDict,
@@ -42,17 +42,18 @@ import TcHsSyn ( SYN_IE(TcExpr),
import TcMonad
import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
-import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr),
+import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcThetaType), SYN_IE(TcTauType),
SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
- tcInstType, zonkTcType, tcSplitForAllTy, tcSplitRhoTy )
-
+ tcInstType, zonkTcType, zonkTcTheta,
+ tcSplitForAllTy, tcSplitRhoTy
+ )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList,
listToBag, consBag, Bag )
import Class ( classInstEnv,
SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv)
)
import ErrUtils ( addErrLoc, SYN_IE(Error) )
-import Id ( GenId, idType, mkInstId, SYN_IE(Id) )
+import Id ( GenId, idType, mkUserLocal, mkSysLocal, SYN_IE(Id) )
import PrelInfo ( isCcallishClass, isNoDictClass )
import MatchEnv ( lookupMEnv, insertMEnv )
import Name ( OccName(..), Name, mkLocalName,
@@ -145,15 +146,17 @@ data Inst s
-- should be instantiated.
-- These types must saturate the Id's foralls.
- (TcRhoType s) -- Cached: (type-of-id applied to inst_tys)
- -- If this type is (theta => tau) then the type of the Method
- -- is tau, and the method can be built by saying
- -- id inst_tys dicts
- -- where dicts are constructed from theta
+ (TcThetaType s) -- The (types of the) dictionaries to which the function
+ -- must be applied to get the method
+
+ (TcTauType s) -- The type of the method
(InstOrigin s)
SrcLoc
+ -- INVARIANT: in (Method u f tys theta tau loc)
+ -- type of (f tys dicts(from theta)) = tau
+
| LitInst
Unique
OverloadedLit
@@ -165,9 +168,9 @@ data OverloadedLit
= OverloadedIntegral Integer -- The number
| OverloadedFractional Rational -- The number
-getInstOrigin (Dict u clas ty origin loc) = origin
-getInstOrigin (Method u clas ty rho origin loc) = origin
-getInstOrigin (LitInst u lit ty origin loc) = origin
+getInstOrigin (Dict u clas ty origin loc) = origin
+getInstOrigin (Method u fn tys theta tau origin loc) = origin
+getInstOrigin (LitInst u lit ty origin loc) = origin
\end{code}
Construction
@@ -213,24 +216,29 @@ newMethod orig id tys
(case id of
RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
in
- (if length tyvars /= length tys then pprTrace "newMethod" (ppr PprDebug (idType id)) else \x->x) $
- tcInstType (zip{-Equal "newMethod"-} tyvars tys) rho
+ tcInstType (zipEqual "newMethod" tyvars tys) rho
+
TcId id -> tcSplitForAllTy (idType id) `thenNF_Tc` \ (tyvars, rho) ->
returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho)
) `thenNF_Tc` \ rho_ty ->
+ let
+ (theta, tau) = splitRhoTy rho_ty
+ in
-- Our friend does the rest
- newMethodWithGivenTy orig id tys rho_ty
+ newMethodWithGivenTy orig id tys theta tau
-newMethodWithGivenTy orig id tys rho_ty
+newMethodWithGivenTy orig id tys theta tau
= tcGetSrcLoc `thenNF_Tc` \ loc ->
tcGetUnique `thenNF_Tc` \ new_uniq ->
let
- meth_inst = Method new_uniq id tys rho_ty orig loc
+ meth_inst = Method new_uniq id tys theta tau orig loc
in
returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
-newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s)
+newMethodAtLoc :: InstOrigin s -> SrcLoc
+ -> Id -> [TcType s]
+ -> NF_TcM s (Inst s, TcIdOcc s)
newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
-- slightly different interface
= -- Get the Id type and instantiate it at the specified types
@@ -240,7 +248,8 @@ newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but
tcInstType (zipEqual "newMethodAtLoc" tyvars tys) rho `thenNF_Tc` \ rho_ty ->
tcGetUnique `thenNF_Tc` \ new_uniq ->
let
- meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc
+ (theta, tau) = splitRhoTy rho_ty
+ meth_inst = Method new_uniq (RealId real_id) tys theta tau orig loc
in
returnNF_Tc (meth_inst, instToId meth_inst)
@@ -273,27 +282,15 @@ newOverloadedLit orig lit ty -- The general case
\begin{code}
instToId :: Inst s -> TcIdOcc s
instToId (Dict u clas ty orig loc)
- = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str loc))
+ = TcId (mkUserLocal occ u (mkDictTy clas ty) loc)
where
- str = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
+ occ = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
-instToId (Method u id tys rho_ty orig loc)
- = TcId (mkInstId u tau_ty (mkLocalName u occ loc))
- where
- occ = getOccName id
- (_, tau_ty) = splitRhoTy rho_ty
- -- I hope we don't need tcSplitRhoTy...
- -- NB The method Id has just the tau type
+instToId (Method u id tys theta tau orig loc)
+ = TcId (mkUserLocal (getOccName id) u tau loc)
instToId (LitInst u list ty orig loc)
- = TcId (mkInstId u ty (mkSysLocalName u SLIT("lit") loc))
-\end{code}
-
-\begin{code}
-instType :: Inst s -> TcType s
-instType (Dict _ clas ty _ _) = mkDictTy clas ty
-instType (LitInst _ _ ty _ _) = ty
-instType (Method _ id tys ty _ _) = ty
+ = TcId (mkSysLocal SLIT("lit") u ty loc)
\end{code}
@@ -309,10 +306,11 @@ zonkInst (Dict u clas ty orig loc)
= zonkTcType ty `thenNF_Tc` \ new_ty ->
returnNF_Tc (Dict u clas new_ty orig loc)
-zonkInst (Method u id tys rho orig loc) -- Doesn't zonk the id!
+zonkInst (Method u id tys theta tau orig loc) -- Doesn't zonk the id!
= mapNF_Tc zonkTcType tys `thenNF_Tc` \ new_tys ->
- zonkTcType rho `thenNF_Tc` \ new_rho ->
- returnNF_Tc (Method u id new_tys new_rho orig loc)
+ zonkTcTheta theta `thenNF_Tc` \ new_theta ->
+ zonkTcType tau `thenNF_Tc` \ new_tau ->
+ returnNF_Tc (Method u id new_tys new_theta new_tau orig loc)
zonkInst (LitInst u lit ty orig loc)
= zonkTcType ty `thenNF_Tc` \ new_ty ->
@@ -322,8 +320,8 @@ zonkInst (LitInst u lit ty orig loc)
\begin{code}
tyVarsOfInst :: Inst s -> TcTyVarSet s
-tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty
-tyVarsOfInst (Method _ id tys rho _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
+tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty
+tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
-- The id might not be a RealId; in the case of
-- locally-overloaded class methods, for example
tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
@@ -338,7 +336,7 @@ matchesInst :: Inst s -> Inst s -> Bool
matchesInst (Dict _ clas1 ty1 _ _) (Dict _ clas2 ty2 _ _)
= clas1 == clas2 && ty1 `eqSimpleTy` ty2
-matchesInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
+matchesInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _)
= id1 == id2
&& and (zipWith eqSimpleTy tys1 tys2)
&& length tys1 == length tys2
@@ -402,7 +400,7 @@ pprInst sty (LitInst u lit ty orig loc)
pprInst sty (Dict u clas ty orig loc)
= hsep [ppr sty clas, pprParendGenType sty ty, show_uniq sty u]
-pprInst sty (Method u id tys rho orig loc)
+pprInst sty (Method u id tys _ _ orig loc)
= hsep [ppr sty id, ptext SLIT("at"),
interppSP sty tys,
show_uniq sty u]
@@ -478,9 +476,8 @@ lookupInst dict@(Dict _ clas ty orig loc)
-- Methods
-lookupInst inst@(Method _ id tys rho orig loc)
- = tcSplitRhoTy rho `thenNF_Tc` \ (theta, _) ->
- newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
+lookupInst inst@(Method _ id tys theta _ orig loc)
+ = newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
returnTc (dicts, VarMonoBind (instToId inst) (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
-- Literals
@@ -671,9 +668,9 @@ pprOrigin sty inst
= hsep [text "arising from", pp_orig orig, text "at", ppr sty locn]
where
(orig, locn) = case inst of
- Dict _ _ _ orig loc -> (orig,loc)
- Method _ _ _ _ orig loc -> (orig,loc)
- LitInst _ _ _ orig loc -> (orig,loc)
+ Dict _ _ _ orig loc -> (orig,loc)
+ Method _ _ _ _ _ orig loc -> (orig,loc)
+ LitInst _ _ _ orig loc -> (orig,loc)
pp_orig (OccurrenceOf id)
= hsep [ptext SLIT("use of"), ppr sty id]
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 7486de561537..30500ba58ed2 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -29,10 +29,10 @@ import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds),
)
import TcMonad
-import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..),
- newDicts, tyVarsOfInst, instToId
+import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, InstOrigin(..),
+ newDicts, tyVarsOfInst, instToId, newMethodWithGivenTy
)
-import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds,
+import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newLocalId,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import SpecEnv ( SpecEnv )
@@ -44,13 +44,13 @@ import TcSimplify ( bindInstsOfLocalFuns )
import TcType ( TcIdOcc(..), SYN_IE(TcIdBndr),
SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType),
SYN_IE(TcTyVarSet), SYN_IE(TcTyVar),
- newTyVarTy, zonkTcType, zonkSigTyVar,
+ newTyVarTy, zonkTcType, zonkTcTheta, zonkSigTyVar,
newTcTyVar, tcInstSigType, newTyVarTys
)
import Unify ( unifyTauTy, unifyTauTyLists )
import Kind ( isUnboxedTypeKind, mkTypeKind, isTypeKind, mkBoxedTypeKind )
-import Id ( GenId, idType, mkUserLocal, mkUserId )
+import Id ( GenId, idType, mkUserId )
import IdInfo ( noIdInfo )
import Maybes ( maybeToBool, assocMaybe, catMaybes )
import Name ( getOccName, getSrcLoc, Name )
@@ -230,11 +230,12 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
-- Create a new identifier for each binder, with each being given
-- a fresh unique, and a type-variable type.
- tcGetUniques no_of_binders `thenNF_Tc` \ uniqs ->
- mapNF_Tc mk_mono_id_ty binder_names `thenNF_Tc` \ mono_id_tys ->
+ -- For "mono_lies" see comments about polymorphic recursion at the
+ -- end of the function.
+ mapAndUnzipNF_Tc mk_mono_id binder_names `thenNF_Tc` \ (mono_lies, mono_ids) ->
let
- mono_ids = zipWith3Equal "tcBindAndSigs" mk_id binder_names uniqs mono_id_tys
- mk_id name uniq ty = mkUserLocal (getOccName name) uniq ty (getSrcLoc name)
+ mono_lie = plusLIEs mono_lies
+ mono_id_tys = map idType mono_ids
in
-- TYPECHECK THE BINDINGS
@@ -251,10 +252,12 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
getTyVarsToGen is_unrestricted mono_id_tys lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
-- DEAL WITH TYPE VARIABLE KINDS
- mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
+ mapTc defaultUncommittedTyVar
+ (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
let
real_tyvars_to_gen = mkTyVarSet real_tyvars_to_gen_list
- -- It's important that the final list (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully
+ -- It's important that the final list
+ -- (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully
-- zonked, *including boxity*, because they'll be included in the forall types of
-- the polymorphic Ids, and instances of these Ids will be generated from them.
--
@@ -268,21 +271,30 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
tcExtendGlobalTyVars tyvars_not_to_gen (
if null tc_ty_sigs then
-- No signatures, so just simplify the lie
+ -- NB: no signatures => no polymorphic recursion, so no
+ -- need to use mono_lies (which will be empty anyway)
tcSimplify real_tyvars_to_gen lie `thenTc` \ (lie_free, dict_binds, lie_bound) ->
returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
else
- zonk_theta sig_theta `thenNF_Tc` \ sig_theta' ->
+ zonkTcTheta sig_theta `thenNF_Tc` \ sig_theta' ->
newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) ->
-- It's important that sig_theta is zonked, because
-- dict_id is later used to form the type of the polymorphic thing,
-- and forall-types must be zonked so far as their bound variables
-- are concerned
+ let
+ -- The "givens" is the stuff available. We get that from
+ -- the context of the type signature, BUT ALSO the mono_lie
+ -- so that polymorphic recursion works right (see comments at end of fn)
+ givens = dicts_sig `plusLIE` mono_lie
+ in
+
-- Check that the needed dicts can be expressed in
-- terms of the signature ones
tcAddErrCtxt (sigsCtxt tysig_names) $
- tcSimplifyAndCheck real_tyvars_to_gen dicts_sig lie `thenTc` \ (lie_free, dict_binds) ->
+ tcSimplifyAndCheck real_tyvars_to_gen givens lie `thenTc` \ (lie_free, dict_binds) ->
returnTc (lie_free, dict_binds, dict_ids)
) `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
@@ -326,23 +338,86 @@ tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
where
no_of_binders = length binder_names
- mk_mono_id_ty binder_name = case maybeSig tc_ty_sigs binder_name of
- Just (TySigInfo name _ _ _ tau_ty _) -> returnNF_Tc tau_ty -- There's a signature
- otherwise -> newTyVarTy kind -- No signature
+ mk_mono_id binder_name
+ | theres_a_signature -- There's a signature; and it's overloaded,
+ && not (null sig_theta) -- so make a Method
+ = tcAddSrcLoc sig_loc $
+ newMethodWithGivenTy SignatureOrigin
+ (TcId poly_id) (mkTyVarTys sig_tyvars)
+ sig_theta sig_tau `thenNF_Tc` \ (mono_lie, TcId mono_id) ->
+ -- A bit turgid to have to strip the TcId
+ returnNF_Tc (mono_lie, mono_id)
+
+ | otherwise -- No signature or not overloaded;
+ = tcAddSrcLoc (getSrcLoc binder_name) $
+ (if theres_a_signature then
+ returnNF_Tc sig_tau -- Non-overloaded signature; use its type
+ else
+ newTyVarTy kind -- No signature; use a new type variable
+ ) `thenNF_Tc` \ mono_id_ty ->
+
+ newLocalId (getOccName binder_name) mono_id_ty `thenNF_Tc` \ mono_id ->
+ returnNF_Tc (emptyLIE, mono_id)
+ where
+ maybe_sig = maybeSig tc_ty_sigs binder_name
+ theres_a_signature = maybeToBool maybe_sig
+ Just (TySigInfo name poly_id sig_tyvars sig_theta sig_tau sig_loc) = maybe_sig
tysig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
is_unrestricted = isUnRestrictedGroup tysig_names mbind
kind | is_rec = mkBoxedTypeKind -- Recursive, so no unboxed types
| otherwise = mkTypeKind -- Non-recursive, so we permit unboxed types
-
-zonk_theta theta = mapNF_Tc zonk theta
- where
- zonk (c,t) = zonkTcType t `thenNF_Tc` \ t' ->
- returnNF_Tc (c,t')
\end{code}
-@getImplicitStuffToGen@ decides what type variables generalise over.
+Polymorphic recursion
+~~~~~~~~~~~~~~~~~~~~~
+The game plan for polymorphic recursion in the code above is
+
+ * Bind any variable for which we have a type signature
+ to an Id with a polymorphic type. Then when type-checking
+ the RHSs we'll make a full polymorphic call.
+
+This fine, but if you aren't a bit careful you end up with a horrendous
+amount of partial application and (worse) a huge space leak. For example:
+
+ f :: Eq a => [a] -> [a]
+ f xs = ...f...
+
+If we don't take care, after typechecking we get
+
+ f = /\a -> \d::Eq a -> let f' = f a d
+ in
+ \ys:[a] -> ...f'...
+
+Notice the the stupid construction of (f a d), which is of course
+identical to the function we're executing. In this case, the
+polymorphic recursion ins't being used (but that's a very common case).
+
+This can lead to a massive space leak, from the following top-level defn:
+
+ ff :: [Int] -> [Int]
+ ff = f dEqInt
+
+Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
+f' is another thunk which evaluates to the same thing... and you end
+up with a chain of identical values all hung onto by the CAF ff.
+
+Solution: when typechecking the RHSs we always have in hand the
+*monomorphic* Ids for each binding. So we just need to make sure that
+if (Method f a d) shows up in the constraints emerging from (...f...)
+we just use the monomorphic Id. We achieve this by adding monomorphic Ids
+to the "givens" when simplifying constraints. Thats' what the "mono_lies"
+is doing.
+
+
+%************************************************************************
+%* *
+\subsection{getTyVarsToGen}
+%* *
+%************************************************************************
+
+@getTyVarsToGen@ decides what type variables generalise over.
For a "restricted group" -- see the monomorphism restriction
for a definition -- we bind no dictionaries, and
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 6f2475852051..dbf3e6b5f6dc 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -754,8 +754,8 @@ tcId name
else
-- Yes, it's overloaded
newMethodWithGivenTy (OccurrenceOf tc_id_occ)
- tc_id_occ arg_tys rho `thenNF_Tc` \ (lie1, meth_id) ->
- instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
+ tc_id_occ arg_tys theta tau `thenNF_Tc` \ (lie1, meth_id) ->
+ instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
where
diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index 0bebb37ab914..e8235cf4c0c4 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -32,7 +32,7 @@ import Id ( GenId, mkDictFunId, mkSysLocal, SYN_IE(Id) )
import MatchEnv ( nullMEnv, insertMEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
import Name ( getSrcLoc, Name{--O only-} )
-import PprType ( GenClass, GenType, GenTyVar )
+import PprType ( GenClass, GenType, GenTyVar, pprParendType )
import Pretty
import SpecEnv ( SpecEnv, nullSpecEnv, addOneToSpecEnv )
import SrcLoc ( SrcLoc )
@@ -209,7 +209,7 @@ dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2)
failTc (\sty -> ptext SLIT("Duplicate or overlapping instance declarations"))
where
ctxt sty = sep [hsep [ptext SLIT("for"),
- pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty1],
+ pprQuote sty $ \ sty -> ppr sty clas <+> pprParendType sty ty1],
nest 4 (sep [ptext SLIT("at") <+> ppr sty locn1,
ptext SLIT("and") <+> ppr sty locn2])]
\end{code}
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 8f81f0b59a65..a04c032d2b8c 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -432,7 +432,10 @@ tcGetDefaultTys down env = returnSST (getDefaultTys down)
tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
-tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
+-- tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
+-- tcAddSrcLoc :: SrcLoc -> NF_TcM s a -> NF_TcM s a
+tcAddSrcLoc :: SrcLoc -> (TcDown s -> env -> result)
+ -> (TcDown s -> env -> result)
tcAddSrcLoc loc m down env = m (setLoc down loc) env
tcGetSrcLoc :: NF_TcM s SrcLoc
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 14a82abe3b3d..e2737adef4d2 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -577,7 +577,7 @@ bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
bindInstsOfLocalFuns init_lie local_ids
= foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie)
where
- bind_inst inst@(Method uniq (TcId id) tys rho orig loc) (insts, binds)
+ bind_inst inst@(Method uniq (TcId id) tys _ _ orig loc) (insts, binds)
| id `is_elem` local_ids
= lookupInst inst `thenTc` \ (dict_insts, bind) ->
returnTc (listToBag dict_insts `plusLIE` insts,
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index a4b7474e96f4..3c10a45ad677 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -28,7 +28,7 @@ module TcType (
tcInstTheta, tcInstId,
zonkTcTyVars, zonkSigTyVar,
- zonkTcType,
+ zonkTcType, zonkTcTheta,
zonkTcTypeToType,
zonkTcTyVar,
zonkTcTyVarToTyVar
@@ -458,4 +458,10 @@ zonkTcType (FunTy ty1 ty2 u)
zonkTcType (DictTy c ty u)
= zonkTcType ty `thenNF_Tc` \ ty' ->
returnNF_Tc (DictTy c ty' u)
+
+
+zonkTcTheta theta = mapNF_Tc zonk theta
+ where
+ zonk (c,t) = zonkTcType t `thenNF_Tc` \ t' ->
+ returnNF_Tc (c,t')
\end{code}
--
GitLab