From: simonpj <unknown>
Date: Wed, 17 Oct 2001 13:16:03 +0000 (+0000)
Subject: [project @ 2001-10-17 13:16:03 by simonpj]
X-Git-Tag: Approximately_9120_patches~811
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=7a5920b38a37f366eec79ebf8294b5f7c4dc8be2;p=ghc-hetmet.git

[project @ 2001-10-17 13:16:03 by simonpj]
-------------------------------------------
  	Desugar bindings into Rec groups more often
		[Part 2]
  	-------------------------------------------

	** MERGE PLEASE **

	  [I forgot the unlifted case.]

  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.
---

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index c14935a..44ba746 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -85,23 +85,38 @@ dsLet (ThenBinds b1 b2) body
     dsLet b1 body'
   
 -- Special case for bindings which bind unlifted variables
+-- We need to do a case right away, rather than building
+-- a tuple and doing selections.
 -- Silently ignore INLINE pragmas...
-dsLet (MonoBind (AbsBinds [] [] binder_triples inlines
-                          (PatMonoBind pat grhss loc)) sigs is_rec) body
-  | or [isUnLiftedType (idType g) | (_, g, l) <- binder_triples]
+dsLet (MonoBind (AbsBinds [] [] exports inlines binds) sigs is_rec) body
+  | or [isUnLiftedType (idType g) | (_, g, l) <- exports]
   = ASSERT (case is_rec of {NonRecursive -> True; other -> False})
-    putSrcLocDs loc			$
-    dsGuarded grhss 			`thenDs` \ rhs ->
-    let
-	body' = foldr bind body binder_triples
-	bind (tyvars, g, l) body = ASSERT( null tyvars )
-				   bindNonRec g (Var l) body
-    in
-    mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat))
-    `thenDs` \ error_expr ->
-    matchSimply rhs PatBindRhs pat body' error_expr
+	-- Unlifted bindings are always non-recursive
+	-- and are always a Fun or Pat monobind
+	--
+	-- ToDo: in some bizarre case it's conceivable that there
+	--       could be dict binds in the 'binds'.  (See the notes
+	--	 below.  Then pattern-match would fail.  Urk.)
+    case binds of
+      FunMonoBind fun _ matches loc
+	-> putSrcLocDs loc			$
+	   matchWrapper (FunRhs fun) matches 	`thenDs` \ (args, rhs) ->
+	   ASSERT( null args )	-- Functions aren't lifted
+	   returnDs (bindNonRec fun rhs body_w_exports)
+
+      PatMonoBind pat grhss loc
+	-> putSrcLocDs loc			$
+	   dsGuarded grhss 			`thenDs` \ rhs ->
+	   mk_error_app pat			`thenDs` \ error_expr ->
+	   matchSimply rhs PatBindRhs pat body_w_exports error_expr
   where
-    result_ty = exprType body
+    body_w_exports		 = foldr bind_export body exports
+    bind_export (tvs, g, l) body = ASSERT( null tvs )
+				   bindNonRec g (Var l) body
+
+    mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID
+				    (exprType body)
+				    (showSDoc (ppr pat))
 
 -- Ordinary case for bindings
 dsLet (MonoBind binds sigs is_rec) body
@@ -114,7 +129,10 @@ dsLet (MonoBind binds sigs is_rec) body
 	-- 	   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}
+	--
+	-- NB The previous case dealt with unlifted bindings, so we
+	--    only have to deal with lifted ones now; so Rec is ok
+\end{code}	
 
 %************************************************************************
 %*									*
@@ -625,6 +643,3 @@ dsLit (HsRat r ty)
 		(tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
 				   (head (tyConDataCons tycon), i_ty)
 \end{code}
-
-
-