Commit ca53c383 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge master into the ghc-new-co branch

parents 4f8d7149 246183c6
......@@ -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:
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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))
......
......@@ -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 {