Merge master into the ghc-new-co branch

Makefile

@@ -45,7 +45,7 @@ endif
 include mk/custom-settings.mk
 
 # No need to update makefiles for these targets:
-REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help install-docs test fulltest,$(MAKECMDGOALS))
+REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help test fulltest,$(MAKECMDGOALS))
 
 # configure touches certain files even if they haven't changed.  This
 # can mean a lot of unnecessary recompilation after a re-configure, so
@@ -102,12 +102,6 @@ framework-pkg:
 	$(MAKE) -C distrib/MacOS $@
 endif
 
-# install-docs is a historical target that isn't supported in GHC 6.12. See #3662.
-install-docs:
-	@echo "The install-docs target is not supported in GHC 6.12.1 and later."
-	@echo "'make install' now installs everything, including documentation."
-	@exit 1
-
 # If the user says 'make A B', then we don't want to invoke two
 # instances of the rule above in parallel:
 .NOTPARALLEL:

aclocal.m4

@@ -1031,18 +1031,6 @@ AC_SUBST([FopCmd])
 ])# FP_PROG_FOP
 
 
-# FP_PROG_HSTAGS
-# ----------------
-# Sets the output variable HstagsCmd to the full Haskell tags program path.
-# HstagsCmd is empty if no such program could be found.
-AC_DEFUN([FP_PROG_HSTAGS],
-[AC_PATH_PROG([HstagsCmd], [hasktags])
-if test -z "$HstagsCmd"; then
-  AC_MSG_WARN([cannot find hasktags in your PATH, you will not be able to build the tags])
-fi
-])# FP_PROG_HSTAGS
-
-
 # FP_PROG_GHC_PKG
 # ----------------
 # Try to find a ghc-pkg matching the ghc mentioned in the environment variable

compiler/cmm/CLabel.hs

@@ -101,7 +101,7 @@ module CLabel (
         hasCAF,
 	infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
 	needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
-        isMathFun, isCas,
+        isMathFun,
  	isCFunctionLabel, isGcPtrLabel, labelDynamic,
 
 	pprCLabel
@@ -590,14 +590,6 @@ maybeAsmTemp (AsmTempLabel uq) 		= Just uq
 maybeAsmTemp _ 	    	       		= Nothing
 
 
--- | Check whether a label corresponds to our cas function.
---      We #include the prototype for this, so we need to avoid
---      generating out own C prototypes.
-isCas :: CLabel -> Bool
-isCas (CmmLabel pkgId fn _) = pkgId == rtsPackageId && fn == fsLit "cas"
-isCas _                     = False
-
-
 -- | Check whether a label corresponds to a C function that has 
 --      a prototype in a system header somehere, or is built-in
 --      to the C compiler. For these labels we avoid generating our
@@ -858,8 +850,8 @@ instance Outputable CLabel where
 
 pprCLabel :: CLabel -> SDoc
 
-#if ! OMIT_NATIVE_CODEGEN
 pprCLabel (AsmTempLabel u)
+ | cGhcWithNativeCodeGen == "YES"
   =  getPprStyle $ \ sty ->
      if asmStyle sty then 
 	ptext asmTempLabelPrefix <> pprUnique u
@@ -867,23 +859,22 @@ pprCLabel (AsmTempLabel u)
 	char '_' <> pprUnique u
 
 pprCLabel (DynamicLinkerLabel info lbl)
+ | cGhcWithNativeCodeGen == "YES"
    = pprDynamicLinkerAsmLabel info lbl
    
 pprCLabel PicBaseLabel
+ | cGhcWithNativeCodeGen == "YES"
    = ptext (sLit "1b")
    
 pprCLabel (DeadStripPreventer lbl)
+ | cGhcWithNativeCodeGen == "YES"
    = pprCLabel lbl <> ptext (sLit "_dsp")
-#endif
 
-pprCLabel lbl = 
-#if ! OMIT_NATIVE_CODEGEN
-    getPprStyle $ \ sty ->
-    if asmStyle sty then 
-	maybe_underscore (pprAsmCLbl lbl)
-    else
-#endif
-       pprCLbl lbl
+pprCLabel lbl
+   = getPprStyle $ \ sty ->
+     if cGhcWithNativeCodeGen == "YES" && asmStyle sty
+     then maybe_underscore (pprAsmCLbl lbl)
+     else pprCLbl lbl
 
 maybe_underscore doc
   | underscorePrefix = pp_cSEP <> doc

compiler/cmm/CmmOpt.hs

@@ -14,6 +14,7 @@
 -----------------------------------------------------------------------------
 
 module CmmOpt (
+	cmmEliminateDeadBlocks,
 	cmmMiniInline,
 	cmmMachOpFold,
 	cmmLoopifyForC,
@@ -30,10 +31,69 @@ import UniqFM
 import Unique
 import FastTypes
 import Outputable
+import BlockId
 
 import Data.Bits
 import Data.Word
 import Data.Int
+import Data.Maybe
+import Data.List
+
+import Compiler.Hoopl hiding (Unique)
+
+-- -----------------------------------------------------------------------------
+-- Eliminates dead blocks
+
+{-
+We repeatedly expand the set of reachable blocks until we hit a
+fixpoint, and then prune any blocks that were not in this set.  This is
+actually a required optimization, as dead blocks can cause problems
+for invariants in the linear register allocator (and possibly other
+places.)
+-}
+
+-- Deep fold over statements could probably be abstracted out, but it
+-- might not be worth the effort since OldCmm is moribund
+cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock]
+cmmEliminateDeadBlocks [] = []
+cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
+    let -- Calculate what's reachable from what block
+        reachableMap = foldl' f emptyUFM blocks -- lazy in values
+            where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts)
+        reachableFrom stmts = foldl stmt [] stmts
+            where
+                stmt m CmmNop = m
+                stmt m (CmmComment _) = m
+                stmt m (CmmAssign _ e) = expr m e
+                stmt m (CmmStore e1 e2) = expr (expr m e1) e2
+                stmt m (CmmCall c _ as _ _) = f (actuals m as) c
+                    where f m (CmmCallee e _) = expr m e
+                          f m (CmmPrim _) = m
+                stmt m (CmmBranch b) = b:m
+                stmt m (CmmCondBranch e b) = b:(expr m e)
+                stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
+                stmt m (CmmJump e as) = expr (actuals m as) e
+                stmt m (CmmReturn as) = actuals m as
+                actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as
+                -- We have to do a deep fold into CmmExpr because
+                -- there may be a BlockId in the CmmBlock literal.
+                expr m (CmmLit l) = lit m l
+                expr m (CmmLoad e _) = expr m e
+                expr m (CmmReg _) = m
+                expr m (CmmMachOp _ es) = foldl' expr m es
+                expr m (CmmStackSlot _ _) = m
+                expr m (CmmRegOff _ _) = m
+                lit m (CmmBlock b) = b:m
+                lit m _ = m
+        -- go todo done
+        reachable = go [base_id] (setEmpty :: BlockSet)
+          where go []     m = m
+                go (x:xs) m
+                    | setMember x m = go xs m
+                    | otherwise     = go (add ++ xs) (setInsert x m)
+                        where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block")
+                                              (lookupUFM reachableMap x)
+    in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks
 
 -- -----------------------------------------------------------------------------
 -- The mini-inliner

compiler/cmm/PprC.hs

@@ -248,7 +248,7 @@ pprStmt stmt = case stmt of
                 | CmmNeverReturns <- ret ->
                     let myCall = pprCall (pprCLabel lbl) cconv results args safety
                     in (real_fun_proto lbl, myCall)
-                | not (isMathFun lbl || isCas lbl) ->
+                | not (isMathFun lbl) ->
                     let myCall = braces (
                                      pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
                                   $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi

compiler/deSugar/Check.lhs

@@ -111,7 +111,8 @@ check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
   -- if there are view patterns, just give up - don't know what the function is
 check qs = (untidy_warns, shadowed_eqns)
       where
-	(warns, used_nos) = check' ([1..] `zip` map tidy_eqn qs)
+        tidy_qs = map tidy_eqn qs
+	(warns, used_nos) = check' ([1..] `zip` tidy_qs)
 	untidy_warns = map untidy_exhaustive warns 
 	shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..], 
 				not (i `elementOfUniqSet` used_nos)]
@@ -670,8 +671,6 @@ tidy_pat (CoPat _ pat _)  = tidy_pat pat
 tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
 tidy_pat (ViewPat _ _ ty)     = WildPat ty
 
-tidy_pat (NPat lit mb_neg eq) = tidyNPat lit mb_neg eq
-
 tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps })
   = pat { pat_args = tidy_con id ps }
 
@@ -695,16 +694,18 @@ tidy_pat (TuplePat ps boxity ty)
   where
     arity = length ps
 
--- Unpack string patterns fully, so we can see when they overlap with
--- each other, or even explicit lists of Chars.
-tidy_pat (LitPat lit)
+tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
+tidy_pat (LitPat lit)         = tidy_lit_pat lit
+
+tidy_lit_pat :: HsLit -> Pat Id
+-- Unpack string patterns fully, so we can see when they 
+-- overlap with each other, or even explicit lists of Chars.
+tidy_lit_pat lit
   | HsString s <- lit
-  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mk_char_lit c, pat] stringTy)
+  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
 		  (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
   | otherwise
   = tidyLitPat lit 
-  where
-    mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy
 
 -----------------
 tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id

compiler/deSugar/Coverage.lhs

@@ -301,10 +301,9 @@ addTickHsExpr (HsLet binds e) =
 	liftM2 HsLet
 		(addTickHsLocalBinds binds) -- to think about: !patterns.
                 (addTickLHsExprNeverOrAlways e)
-addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
-        (stmts', last_exp') <- addTickLStmts' forQual stmts 
-                                     (addTickLHsExpr last_exp)
-	return (HsDo cxt stmts' last_exp' srcloc)
+addTickHsExpr (HsDo cxt stmts srcloc) 
+  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
+       ; return (HsDo cxt stmts' srcloc) }
   where
 	forQual = case cxt of
 		    ListComp -> Just $ BinBox QualBinBox
@@ -424,45 +423,50 @@ addTickLStmts isGuard stmts = do
 addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a 
                -> TM ([LStmt Id], a)
 addTickLStmts' isGuard lstmts res
-  = bindLocals binders $ do
-        lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
-        a <- res
-        return (lstmts', a)
-  where
-        binders = collectLStmtsBinders lstmts
+  = bindLocals (collectLStmtsBinders lstmts) $ 
+    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
+       ; a <- res
+       ; return (lstmts', a) }
 
 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
+addTickStmt _isGuard (LastStmt e ret) = do
+	liftM2 LastStmt
+		(addTickLHsExpr e)
+		(addTickSyntaxExpr hpcSrcSpan ret)
 addTickStmt _isGuard (BindStmt pat e bind fail) = do
 	liftM4 BindStmt
 		(addTickLPat pat)
 		(addTickLHsExprAlways e)
 		(addTickSyntaxExpr hpcSrcSpan bind)
 		(addTickSyntaxExpr hpcSrcSpan fail)
-addTickStmt isGuard (ExprStmt e bind' ty) = do
-	liftM3 ExprStmt
+addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
+	liftM4 ExprStmt
 		(addTick isGuard e)
 		(addTickSyntaxExpr hpcSrcSpan bind')
+		(addTickSyntaxExpr hpcSrcSpan guard')
 		(return ty)
 addTickStmt _isGuard (LetStmt binds) = do
 	liftM LetStmt
 		(addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt pairs) = do
-    liftM ParStmt 
+addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
+    liftM4 ParStmt 
         (mapM (addTickStmtAndBinders isGuard) pairs)
-
-addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr) = do
-    liftM4 TransformStmt 
-        (addTickLStmts isGuard stmts)
-        (return ids)
-        (addTickLHsExprAlways usingExpr)
-        (addTickMaybeByLHsExpr maybeByExpr)
-
-addTickStmt isGuard (GroupStmt stmts binderMap by using) = do
-    liftM4 GroupStmt 
-        (addTickLStmts isGuard stmts)
-        (return binderMap)
-        (fmapMaybeM  addTickLHsExprAlways by)
-	(fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using)
+        (addTickSyntaxExpr hpcSrcSpan mzipExpr)
+        (addTickSyntaxExpr hpcSrcSpan bindExpr)
+        (addTickSyntaxExpr hpcSrcSpan returnExpr)
+
+addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
+                                    , trS_by = by, trS_using = using
+                                    , trS_ret = returnExpr, trS_bind = bindExpr
+                                    , trS_fmap = liftMExpr }) = do
+    t_s <- addTickLStmts isGuard stmts
+    t_y <- fmapMaybeM  addTickLHsExprAlways by
+    t_u <- addTickLHsExprAlways using
+    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
+    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
+    t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
+    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
+                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
 
 addTickStmt isGuard stmt@(RecStmt {})
   = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
@@ -483,12 +487,6 @@ addTickStmtAndBinders isGuard (stmts, ids) =
         (addTickLStmts isGuard stmts)
         (return ids)
 
-addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
-addTickMaybeByLHsExpr maybeByExpr = 
-    case maybeByExpr of
-        Nothing -> return Nothing
-        Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)
-
 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 addTickHsLocalBinds (HsValBinds binds) = 
 	liftM HsValBinds 
@@ -569,9 +567,9 @@ addTickHsCmd (HsLet binds c) =
 	liftM2 HsLet
 		(addTickHsLocalBinds binds) -- to think about: !patterns.
                 (addTickLHsCmd c)
-addTickHsCmd (HsDo cxt stmts last_exp srcloc) = do
-        (stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp)
-	return (HsDo cxt stmts' last_exp' srcloc)
+addTickHsCmd (HsDo cxt stmts srcloc)
+  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
+       ; return (HsDo cxt stmts' srcloc) }
 
 addTickHsCmd (HsArrApp	 e1 e2 ty1 arr_ty lr) = 
         liftM5 HsArrApp
@@ -635,10 +633,15 @@ addTickCmdStmt (BindStmt pat c bind fail) = do
 		(addTickLHsCmd c)
 		(return bind)
 		(return fail)
-addTickCmdStmt (ExprStmt c bind' ty) = do
-	liftM3 ExprStmt
+addTickCmdStmt (LastStmt c ret) = do
+	liftM2 LastStmt
+		(addTickLHsCmd c)
+		(addTickSyntaxExpr hpcSrcSpan ret)
+addTickCmdStmt (ExprStmt c bind' guard' ty) = do
+	liftM4 ExprStmt
 		(addTickLHsCmd c)
-		(return bind')
+		(addTickSyntaxExpr hpcSrcSpan bind')
+                (addTickSyntaxExpr hpcSrcSpan guard')
 		(return ty)
 addTickCmdStmt (LetStmt binds) = do
 	liftM LetStmt

compiler/deSugar/DsArrows.lhs

@@ -541,8 +541,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
                         core_body,
         exprFreeVars core_binds `intersectVarSet` local_vars)
 
-dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
-  = dsCmdDo ids local_vars env_ids res_ty stmts body
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _)
+  = dsCmdDo ids local_vars env_ids res_ty stmts 
 
 --	A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
 --	A | xs |- ci :: [tsi] ti
@@ -618,7 +618,6 @@ dsCmdDo :: DsCmdEnv		-- arrow combinators
 				-- so don't pull on it too early
 	-> Type			-- return type of the statement
 	-> [LStmt Id]		-- statements to desugar
-	-> LHsExpr Id		-- body
 	-> DsM (CoreExpr,	-- desugared expression
 		IdSet)		-- set of local vars that occur free
 
@@ -626,15 +625,17 @@ dsCmdDo :: DsCmdEnv		-- arrow combinators
 --	--------------------------
 --	A | xs |- do { c } :: [] t
 
-dsCmdDo ids local_vars env_ids res_ty [] body
+dsCmdDo _ _ _ _ [] = panic "dsCmdDo"
+
+dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)]
   = dsLCmd ids local_vars env_ids [] res_ty body
 
-dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do
     let
         bound_vars = mkVarSet (collectLStmtBinders stmt)
         local_vars' = local_vars `unionVarSet` bound_vars
     (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
-        (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
+        (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts 
         return (core_stmts, fv_stmts, varSetElems fv_stmts))
     (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
     return (do_compose ids
@@ -674,7 +675,7 @@ dsCmdStmt
 --		---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
 --			arr snd >>> ss
 
-dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) = do
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd
     core_mux <- matchEnvStack env_ids []
         (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))

compiler/deSugar/DsExpr.lhs

@@ -325,26 +325,12 @@ dsExpr (HsLet binds body) = do
 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 -- because the interpretation of `stmts' depends on what sort of thing it is.
 --
-dsExpr (HsDo ListComp stmts body result_ty)
-  =	-- Special case for list comprehensions
-    dsListComp stmts body elt_ty
-  where
-    [elt_ty] = tcTyConAppArgs result_ty
-
-dsExpr (HsDo DoExpr stmts body result_ty)
-  = dsDo stmts body result_ty
-
-dsExpr (HsDo GhciStmt stmts body result_ty)
-  = dsDo stmts body result_ty
-
-dsExpr (HsDo MDoExpr stmts body result_ty)
-  = dsDo stmts body result_ty
-
-dsExpr (HsDo PArrComp stmts body result_ty)
-  =	-- Special case for array comprehensions
-    dsPArrComp (map unLoc stmts) body elt_ty
-  where
-    [elt_ty] = tcTyConAppArgs result_ty
+dsExpr (HsDo ListComp  stmts res_ty) = dsListComp stmts res_ty
+dsExpr (HsDo PArrComp  stmts _)      = dsPArrComp (map unLoc stmts)
+dsExpr (HsDo DoExpr    stmts _)      = dsDo stmts 
+dsExpr (HsDo GhciStmt  stmts _)      = dsDo stmts 
+dsExpr (HsDo MDoExpr   stmts _)      = dsDo stmts 
+dsExpr (HsDo MonadComp stmts _)      = dsMonadComp stmts
 
 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
   = do { pred <- dsLExpr guard_expr
@@ -708,25 +694,20 @@ handled in DsListComp).  Basically does the translation given in the
 Haskell 98 report:
 
 \begin{code}
-dsDo	:: [LStmt Id]
-	-> LHsExpr Id
-	-> Type			-- Type of the whole expression
-	-> DsM CoreExpr
-
-dsDo stmts body result_ty
+dsDo :: [LStmt Id] -> DsM CoreExpr
+dsDo stmts
   = goL stmts
   where
-    -- result_ty must be of the form (m b)
-    (m_ty, _b_ty) = tcSplitAppTy result_ty
-
-    goL [] = dsLExpr body
-    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+    goL [] = panic "dsDo"
+    goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
   
-    go _ (ExprStmt rhs then_expr _) stmts
+    go _ (LastStmt body _) stmts
+      = ASSERT( null stmts ) dsLExpr body
+        -- The 'return' op isn't used for 'do' expressions
+
+    go _ (ExprStmt rhs then_expr _ _) stmts
       = do { rhs2 <- dsLExpr rhs
-           ; case tcSplitAppTy_maybe (exprType rhs2) of
-                Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
-                _                                 -> return ()
+           ; warnDiscardedDoBindings rhs (exprType rhs2) 
            ; then_expr2 <- dsExpr then_expr
 	   ; rest <- goL stmts
 	   ; return (mkApps then_expr2 [rhs2, rest]) }
@@ -750,29 +731,29 @@ dsDo stmts body result_ty
     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
-                    , recS_rec_rets = rec_rets }) stmts
+                    , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
       = ASSERT( length rec_ids > 0 )
         goL (new_bind_stmt : stmts)
       where
-        -- returnE <- dsExpr return_id
-        -- mfixE <- dsExpr mfix_id
-        new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
-                                         bind_op 
+        new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats)
+                                         mfix_app bind_op 
                                          noSyntaxExpr  -- Tuple cannot fail
 
         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
+        tup_ty       = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
         rec_tup_pats = map nlVarPat tup_ids
         later_pats   = rec_tup_pats
         rets         = map noLoc rec_rets
-
-        mfix_app   = nlHsApp (noLoc mfix_op) mfix_arg
-        mfix_arg   = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
-                                             (mkFunTy tup_ty body_ty))
-        mfix_pat   = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
-        body       = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
-        return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
-	body_ty    = mkAppTy m_ty tup_ty
-        tup_ty     = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
+        mfix_app     = nlHsApp (noLoc mfix_op) mfix_arg
+        mfix_arg     = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
+                                                 (mkFunTy tup_ty body_ty))
+        mfix_pat     = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
+        body         = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
+        ret_app      = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
+        ret_stmt     = noLoc $ mkLastStmt ret_app
+		     -- This LastStmt will be desugared with dsDo, 
+		     -- which ignores the return_op in the LastStmt,
+		     -- so we must apply the return_op explicitly 
 
 handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
     -- In a do expression, pattern-match failure just calls
@@ -790,104 +771,6 @@ mk_fail_msg pat = "Pattern match failure in do expression at " ++
 		  showSDoc (ppr (getLoc pat))
 \end{code}
 
-Translation for RecStmt's: 
------------------------------
-We turn (RecStmt [v1,..vn] stmts) into:
-  
-  (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
-				      return (v1,..vn))
-
-\begin{code}
-{-
-dsMDo   :: HsStmtContext Name
-        -> [(Name,Id)]
-	-> [LStmt Id]
-	-> LHsExpr Id
-	-> Type			-- Type of the whole expression
-	-> DsM CoreExpr
-
-dsMDo ctxt tbl stmts body result_ty
-  = goL stmts
-  where
-    goL [] = dsLExpr body
-    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
-  
-    (m_ty, b_ty) = tcSplitAppTy result_ty	-- result_ty must be of the form (m b)
-    return_id = lookupEvidence tbl returnMName
-    bind_id   = lookupEvidence tbl bindMName
-    then_id   = lookupEvidence tbl thenMName
-    fail_id   = lookupEvidence tbl failMName
-
-    go _ (LetStmt binds) stmts
-      = do { rest <- goL stmts
-	   ; dsLocalBinds binds rest }
-
-    go _ (ExprStmt rhs then_expr rhs_ty) stmts
-      = do { rhs2 <- dsLExpr rhs
-	   ; warnDiscardedDoBindings rhs m_ty rhs_ty
-           ; then_expr2 <- dsExpr then_expr
-           ; rest <- goL stmts
-           ; return (mkApps then_expr2 [rhs2, rest]) }
-    
-    go _ (BindStmt pat rhs bind_op _) stmts
-      = do { body     <- goL stmts
-           ; rhs'     <- dsLExpr rhs
-           ; bind_op' <- dsExpr bind_op
-           ; var   <- selectSimpleMatchVarL pat
-	   ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
-                                     result_ty (cantFailMatchResult body)
-           ; match_code <- handle_failure pat match fail_op
-           ; return (mkApps bind_op [rhs', Lam var match_code]) }
-    
-    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
-                    , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
-                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
-      = ASSERT( length rec_ids > 0 )
-        ASSERT( length rec_ids == length rec_rets )
-        ASSERT( isEmptyTcEvBinds _ev_binds )
-        pprTrace "dsMDo" (ppr later_ids) $
-	 goL (new_bind_stmt : stmts)
-      where
-        new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app
-                                         bind_op noSyntaxExpr
-	
-		-- Remove the later_ids that appear (without fancy coercions) 
-		-- in rec_rets, because there's no need to knot-tie them separately
-		-- See Note [RecStmt] in HsExpr
-	later_ids'   = filter (`notElem` mono_rec_ids) later_ids
-	mono_rec_ids = [ id | HsVar id <- rec_rets ]
-    
-        mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
-	mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
-					     (mkFunTy tup_ty body_ty))
-
-	-- The rec_tup_pat must bind the rec_ids 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 later_ids' ++ map nlVarPat rec_ids
-	later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
-	rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
-
-	mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
-	body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
-	body_ty = mkAppTy m_ty tup_ty
-	tup_ty  = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids))  -- Deals with singleton case
-
-        return_app  = nlHsApp (noLoc return_op) (mkLHsTupleExpr 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` later_ids' = mk_wild_pat v
-		       | otherwise	     = nlVarPat v
-
- 	mk_tup_pat :: [LPat Id] -> LPat Id
-  	mk_tup_pat [p] = p
-	mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
--}
-\end{code}
-
 
 %************************************************************************
 %*									*
@@ -927,30 +810,34 @@ conversionNames
 
 \begin{code}
 -- Warn about certain types of values discarded in monadic bindings (#3263)
-warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
-warnDiscardedDoBindings rhs container_ty returning_ty = do {
-