From 95e31ad5d5dbb3f3a3994fc267f6ed7591b86d17 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 17 Oct 2001 11:05:36 +0000
Subject: [PATCH] [project @ 2001-10-17 11:05:36 by simonpj]
 ------------------------------------------- 	Desugar
 bindings into Rec groups more often 
 -------------------------------------------

In rather obscure cases (involving functional dependencies)
it is possible to get an AbsBinds [] [] (no tyvars, no dicts)
which nevertheless has some "dictionary bindings".  These
come out of the typechecker in non-dependency order, so we
need to Rec them just in case.

It turns out to be a bit awkward.  The smallest fix is
to make dsLet always make a Rec; brutal but correct.
---
 ghc/compiler/deSugar/DsBinds.lhs |   24 ++++++++++++++++--------
 ghc/compiler/deSugar/DsExpr.lhs  |   13 +++++++++----
 2 files changed, 25 insertions(+), 12 deletions(-)

diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index ddfbd6c..4f2323d 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -90,12 +90,16 @@ dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest
     returnDs (sel_binds ++ rest)
 
 	-- Common special case: no type or dictionary abstraction
+	-- For the (rare) case when there are some mixed-up
+	-- dictionary bindings (for which a Rec is convenient)
+	-- we reply on the enclosing dsBind to wrap a Rec around.
 dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
   = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
     let 
-	exports' = [(global, Var local) | (_, global, local) <- exports]
+	core_prs' = addLocalInlines exports inlines core_prs
+	exports'  = [(global, Var local) | (_, global, local) <- exports]
     in
-    returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest)
+    returnDs (core_prs' ++ exports' ++ rest)
 
 	-- Another common case: one exported variable
 	-- Non-recursive bindings come through this way
@@ -106,22 +110,26 @@ dsMonoBinds auto_scc
     let 
 	-- Always treat the binds as recursive, because the typechecker
 	-- makes rather mixed-up dictionary bindings
-	core_binds = [Rec core_prs]
-	global'    = (global, mkInline (idName global `elemNameSet` inlines) $
+	core_bind = Rec core_prs
+
+	-- The mkInline does directly what the 
+	-- addLocalInlines do in the other cases
+	export'    = (global, mkInline (idName global `elemNameSet` inlines) $
 			      mkLams tyvars $ mkLams dicts $ 
-	                      mkDsLets core_binds (Var local))
+	                      Let core_bind (Var local))
     in
-    returnDs (global' : rest)
+    returnDs (export' : rest)
 
 dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
   = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
     let 
-	core_binds = [Rec (addLocalInlines exports inlines core_prs)]
+	-- Rec because of mixed-up dictionary bindings
+	core_bind = Rec (addLocalInlines exports inlines core_prs)
 
 	tup_expr      = mkTupleExpr locals
 	tup_ty	      = exprType tup_expr
 	poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
-		        mkDsLets core_binds tup_expr
+		        Let core_bind tup_expr
 	locals        = [local | (_, _, local) <- exports]
 	local_tys     = map idType locals
     in
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 0693b36..c14935a 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -33,7 +33,7 @@ import DsBinds		( dsMonoBinds, AutoScc(..) )
 import DsGRHSs		( dsGuarded )
 import DsCCall		( dsCCall, resultWrapper )
 import DsListComp	( dsListComp )
-import DsUtils		( mkErrorAppDs, mkDsLets, mkStringLit, mkStringLitFS, 
+import DsUtils		( mkErrorAppDs, mkStringLit, mkStringLitFS, 
 			  mkConsExpr, mkNilExpr, mkIntegerLit
 			)
 import Match		( matchWrapper, matchSimply )
@@ -106,9 +106,14 @@ dsLet (MonoBind (AbsBinds [] [] binder_triples inlines
 -- Ordinary case for bindings
 dsLet (MonoBind binds sigs is_rec) body
   = dsMonoBinds NoSccs binds []  `thenDs` \ prs ->
-    case is_rec of
-      Recursive    -> returnDs (Let (Rec prs) body)
-      NonRecursive -> returnDs (mkDsLets [NonRec b r | (b,r) <- prs] body)
+    returnDs (Let (Rec prs) body)
+	-- Use a Rec regardless of is_rec. 
+	-- Why? Because it allows the MonoBinds to be all
+	-- mixed up, which is what happens in one rare case
+	-- Namely, for an AbsBind with no tyvars and no dicts,
+	-- 	   but which does have dictionary bindings.
+	-- See notes with TcSimplify.inferLoop [NO TYVARS]
+	-- It turned out that wrapping a Rec here was the easiest solution
 \end{code}
 
 %************************************************************************
-- 
1.7.10.4