[project @ 2005-01-04 16:26:55 by simonpj]

------------------
          Fix an mdo bug
  	------------------

Embarassingly, this bug makes GHC either panic (for some programs) or
go into a loop (on others) in a recursive mdo that involves a
polymorphic function.  Urk!

The fix is twofold:
  a) add a missing bindInstsOfLocalFuns to tcStmtAndThen (RecStmt case)
  b) bind the correct set of variables in dsRecStmt

I added some explanatory comments about RecStmt in HsExpr too.

The tests is mdo/should_compile/mdo006

ghc/compiler/deSugar/DsExpr.lhs

@@ -34,8 +34,8 @@ import TcHsSyn		( hsPatType )
 -- Sigh.  This is a pain.
 
 import TcType		( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon, tcTyConAppArgs,
-			  tcTyConAppArgs, isUnLiftedType, Type, mkAppTy )
-import Type		( mkFunTys, funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy )
+			  tcTyConAppArgs, isUnLiftedType, Type, mkAppTy, tcEqType )
+import Type		( funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy )
 import CoreSyn
 import CoreUtils	( exprType, mkIfThenElse, bindNonRec )
 
@@ -640,32 +640,57 @@ dsRecStmt :: Type		-- Monad type constructor :: * -> *
   	  -> [Id] -> [Id] -> [LHsExpr Id]
 	  -> Stmt Id
 dsRecStmt m_ty ds_meths stmts later_vars rec_vars rec_rets
-  = ASSERT( length vars == length rets )
-    BindStmt tup_pat mfix_app
+  = ASSERT( length rec_vars > 0 )
+    ASSERT( length rec_vars == length rec_rets )
+    BindStmt (mk_tup_pat later_pats) mfix_app
   where 
-	vars@(var1:rest) = later_vars           ++ rec_vars		-- Always at least one
-	rets@(ret1:_)    = map nlHsVar later_vars ++ rec_rets
-	one_var          = null rest
+	-- Remove any vars from later_vars that already in rec_vars
+	-- NB that having the same name is not enough; they must  have
+	--    the same type.  See Note [RecStmt] in HsExpr.
+	trimmed_laters = filter not_in_rec later_vars
+	not_in_rec lv  = null [ v | let lv_type = idType lv
+			 	  , v <- rec_vars
+				  , v == lv
+				  , lv_type `tcEqType` idType v ]
 
 	mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg
-	mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [tup_pat] body]
+	mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
 					     (mkFunTy tup_ty body_ty))
 
-	tup_expr | one_var   = ret1
-		 | otherwise = noLoc $ ExplicitTuple rets Boxed
-	var_tys		     = map idType vars
-	tup_ty   	     = mkCoreTupTy var_tys  -- Deals with singleton case
-	tup_pat  | one_var   = nlVarPat var1
-		 | otherwise = noLoc $ LazyPat (noLoc $ TuplePat (map nlVarPat vars) Boxed)
-
-	body = noLoc $ HsDo DoExpr (stmts ++ [return_stmt]) 
-			   [(n, HsVar id) | (n,id) <- ds_meths]	-- A bit of a hack
-			   body_ty
+	-- The rec_tup_pat must bind the rec_vars only; remember that the 
+	-- 	trimmed_laters may share the same Names
+	-- Meanwhile, the later_pats must bind the later_vars
+	rec_tup_pats = map mk_wild_pat trimmed_laters ++ map nlVarPat rec_vars
+	later_pats   = map nlVarPat trimmed_laters    ++ map mk_later_pat rec_vars
+	rets         = map nlHsVar trimmed_laters     ++ rec_rets
+
+	mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
+	body     = noLoc $ HsDo DoExpr (stmts ++ [return_stmt]) 
+			   	[(n, HsVar id) | (n,id) <- ds_meths]	-- A bit of a hack
+			   	body_ty
 	body_ty = mkAppTy m_ty tup_ty
+	tup_ty  = mkCoreTupTy (map idType (trimmed_laters ++ rec_vars))
+		  -- mkCoreTupTy deals with singleton case
 
   	Var return_id = lookupReboundName ds_meths returnMName
 	Var mfix_id   = lookupReboundName ds_meths mfixName
 
 	return_stmt = noLoc $ ResultStmt return_app
-	return_app  = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty]) tup_expr
+	return_app  = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty]) 
+			      (mk_ret_tup rets)
+
+	mk_wild_pat :: Id -> LPat Id 
+   	mk_wild_pat v = noLoc $ WildPat $ idType v
+
+	mk_later_pat :: Id -> LPat Id
+	mk_later_pat v | v `elem` trimmed_laters = mk_wild_pat v
+		       | otherwise		 = nlVarPat v
+
+ 	mk_tup_pat :: [LPat Id] -> LPat Id
+  	mk_tup_pat [p] = p
+	mk_tup_pat ps  = noLoc $ TuplePat ps Boxed
+
+	mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
+	mk_ret_tup [r] = r
+	mk_ret_tup rs  = noLoc $ ExplicitTuple rs Boxed
 \end{code}

ghc/compiler/hsSyn/HsExpr.lhs

@@ -701,7 +701,7 @@ data Stmt id
   | ParStmt	[([LStmt id], [id])]	-- After remaing, the ids are the binders
 					-- bound by the stmts and used subsequently
 
-	-- Recursive statement
+	-- Recursive statement (see Note [RecStmt] below)
   | RecStmt  [LStmt id] 
 		--- The next two fields are only valid after renaming
 	     [id] 	-- The ids are a subset of the variables bound by the stmts
@@ -756,6 +756,30 @@ depends on the context.  Consider the following contexts:
 
 Array comprehensions are handled like list comprehensions -=chak
 
+Note [RecStmt]
+~~~~~~~~~~~~~~
+Example:
+	HsDo [ BindStmt x ex
+
+	     , RecStmt [a::forall a. a -> a, b] 
+		       [a::Int -> Int,       c] 
+		       [ BindStmt b (return x)
+		       , LetStmt a = ea
+		       , BindStmt c ec ]
+
+	     , return (a b) ]
+
+Here, the RecStmt binds a,b,c; but 
+  - Only a,b are used in the stmts *following* the RecStmt, 
+	This 'a' is *polymorphic'
+  - Only a,c are used in the stmts *inside* the RecStmt
+	*before* their bindings
+	This 'a' is monomorphic
+
+Nota Bene: the two a's have different types, even though they
+have the same Name.
+
+
 \begin{code}
 instance OutputableBndr id => Outputable (Stmt id) where
     ppr stmt = pprStmt stmt

ghc/compiler/typecheck/TcMatches.lhs

@@ -18,7 +18,7 @@ import {-# SOURCE #-}	TcExpr( tcCheckRho, tcInferRho, tcMonoExpr )
 import HsSyn		( HsExpr(..), LHsExpr, MatchGroup(..),
 			  Match(..), LMatch, GRHSs(..), GRHS(..), 
 			  Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
-			  ReboundNames, LPat,
+			  ReboundNames, LPat, HsBindGroup(..),
 			  pprMatch, isDoExpr,
 			  pprMatchContext, pprStmtContext, pprStmtResultContext,
 			  collectPatsBinders, glueBindsOnGRHSs
@@ -40,11 +40,13 @@ import TcUnify		( Expected(..), zapExpectedType, readExpectedType,
 			  unifyTauTy, subFunTys, unifyListTy, unifyTyConApp,
 			  checkSigTyVarsWrt, zapExpectedBranches, tcSubExp, tcGen,
 			  unifyAppTy )
+import TcSimplify	( bindInstsOfLocalFuns )
 import Name		( Name )
 import TysWiredIn	( boolTy, parrTyCon, listTyCon )
 import Id		( idType, mkLocalId )
 import CoreFVs		( idFreeTyVars )
 import VarSet
+import BasicTypes	( RecFlag(..) )
 import Util		( isSingleton, notNull )
 import Outputable
 import SrcLoc		( Located(..), noLoc )
@@ -486,7 +488,6 @@ tcStmtAndThen combine ctxt (L src_loc (ParStmt bndr_stmts_s)) thing_inside
 
 	-- RecStmt
 tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thing_inside
--- gaw 2004
   = newTyFlexiVarTys (length recNames) liftedTypeKind		`thenM` \ recTys ->
     let
 	rec_ids = zipWith mkLocalId recNames recTys
@@ -500,10 +501,15 @@ tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thi
 
     tcExtendIdEnv later_ids		$
 	-- NB:	The rec_ids for the recursive things 
-	-- 	already scope over this part
-    thing_inside				`thenM` \ thing ->
+	-- 	already scope over this part. This binding may shadow
+	--	some of them with polymorphic things with the same Name
+	--	(see note [RecStmt] in HsExpr)
+    getLIE thing_inside				`thenM` \ (thing, lie) ->
+    bindInstsOfLocalFuns lie later_ids		`thenM` \ lie_binds ->
   
-    returnM (combine (L src_loc (RecStmt stmts' later_ids rec_ids rec_rets)) thing)
+    returnM (combine (L src_loc (RecStmt stmts' later_ids rec_ids rec_rets))     $
+	     combine (L src_loc (LetStmt [HsBindGroup lie_binds  [] Recursive])) $
+	     thing)
   where 
     combine_rec stmt (stmts, thing) = (stmt:stmts, thing)