[project @ 1997-10-20 10:21:11 by simonm]

fix for overloading-related space leak (typecheck/should_run/tcrun002)

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
 

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]

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

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

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}

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

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, 

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}