From: simonpj <unknown>
Date: Wed, 25 Jul 2001 15:55:30 +0000 (+0000)
Subject: [project @ 2001-07-25 15:55:30 by simonpj]
X-Git-Tag: Approximately_9120_patches~1409
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=7fde87b3698ae84e1b6006a1c3ed0b2fd974b686;p=ghc-hetmet.git

[project @ 2001-07-25 15:55:30 by simonpj]
-----------------------------------------
	Fix a bug in the monomorphism restriction
	------------------------------------------

Thanks for Koen for reporting this bug.

In tcSimplifyRestricted, I wrongly called tcSimpifyToDicts,
whereas actually we have to simplfy further than simply to
a dictionary.

The test for this is in typecheck/should_compile/tc132.hs
---

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 65c2da8..fe8b600 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -722,16 +722,22 @@ tcSimplifyRestricted doc tau_tvs wanted_lie
 	--	foo = f (3::Int)
 	-- We want to infer the polymorphic type
 	--	foo :: forall b. b -> b
-    tcSimplifyToDicts wanted_lie	`thenTc` \ (dicts, _) ->
     let
-	constrained_tvs = tyVarsOfInsts dicts
+	wanteds = lieToList wanted_lie
+	try_me inst = ReduceMe		-- Reduce as far as we can.  Don't stop at
+					-- dicts; the idea is to get rid of as many type
+					-- variables as possible, and we don't want to stop
+					-- at (say) Monad (ST s), because that reduces
+					-- immediately, with no constraint on s.
     in
+    simpleReduceLoop doc try_me wanteds		`thenTc` \ (_, _, constrained_dicts) ->
 
 	-- Next, figure out the tyvars we will quantify over
     zonkTcTyVarsAndFV (varSetElems tau_tvs)	`thenNF_Tc` \ tau_tvs' ->
     tcGetGlobalTyVars				`thenNF_Tc` \ gbl_tvs ->
     let
-	qtvs = (tau_tvs' `minusVarSet` oclose (predsOfInsts dicts) gbl_tvs)
+	constrained_tvs = tyVarsOfInsts constrained_dicts
+	qtvs = (tau_tvs' `minusVarSet` oclose (predsOfInsts constrained_dicts) gbl_tvs)
 			 `minusVarSet` constrained_tvs
     in
 
@@ -752,7 +758,7 @@ tcSimplifyRestricted doc tau_tvs wanted_lie
     reduceContext doc try_me [] wanteds'	`thenTc` \ (no_improvement, frees, binds, irreds) ->
     ASSERT( no_improvement )
     ASSERT( null irreds )
-	-- No need to loop because tcSimplifyToDicts will have
+	-- No need to loop because simpleReduceLoop will have
 	-- already done any improvement necessary
 
     returnTc (varSetElems qtvs, mkLIE frees, binds)