import NameEnv
#ifdef GHCI
-import PrelNames
-- Template Haskell stuff iff bootstrapped
import DsMeta
#endif
import MkCore
import DynFlags
+import StaticFlags
import CostCentre
import Id
import PrelInfo
import Bag
import Outputable
import FastString
+
+import Control.Monad
\end{code}
= uncurry mkLams <$> matchWrapper LambdaExpr a_Match
dsExpr (HsApp fun arg)
- = mkCoreApp <$> dsLExpr fun <*> dsLExpr arg
+ = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
\end{code}
Operator sections. At first it looks as if we can convert
\begin{code}
dsExpr (OpApp e1 op _ e2)
= -- for the type of y, we need the type of op's 2nd argument
- mkCoreApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
+ mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
- = mkCoreApp <$> dsLExpr op <*> dsLExpr expr
+ = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
dsExpr (SectionR op expr) = do
x_id <- newSysLocalDs x_ty
y_id <- newSysLocalDs y_ty
return (bindNonRec y_id y_core $
- Lam x_id (mkCoreApps core_op [Var x_id, Var y_id]))
+ Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
+
+dsExpr (ExplicitTuple tup_args boxity)
+ = do { let go (lam_vars, args) (Missing ty)
+ -- For every missing expression, we need
+ -- another lambda in the desugaring.
+ = do { lam_var <- newSysLocalDs ty
+ ; return (lam_var : lam_vars, Var lam_var : args) }
+ go (lam_vars, args) (Present expr)
+ -- Expressions that are present don't generate
+ -- lambdas, just arguments.
+ = do { core_expr <- dsLExpr expr
+ ; return (lam_vars, core_expr : args) }
+
+ ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
+ -- The reverse is because foldM goes left-to-right
+
+ ; return $ mkCoreLams lam_vars $
+ mkConApp (tupleCon boxity (length tup_args))
+ (map (Type . exprType) args ++ args) }
dsExpr (HsSCC cc expr) = do
mod_name <- getModuleDs
dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
| isEmptyMatchGroup matches -- A Core 'case' is always non-empty
= -- So desugar empty HsCase to error call
- mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) "case"
+ mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
| otherwise
= do { core_discrim <- dsLExpr discrim
unary fn x = mkApps (Var fn) [Type ty, x]
binary fn x y = mkApps (Var fn) [Type ty, x, y]
-dsExpr (ExplicitTuple expr_list boxity) = do
- core_exprs <- mapM dsLExpr expr_list
- return (mkConApp (tupleCon boxity (length expr_list))
- (map (Type . exprType) core_exprs ++ core_exprs))
-
dsExpr (ArithSeq expr (From from))
= App <$> dsExpr expr <*> dsLExpr from
= case findField (rec_flds rbinds) lbl of
(rhs:rhss) -> ASSERT( null rhss )
dsLExpr rhs
- [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
- unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
+ [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
+ unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
labels = dataConFieldLabels (idDataCon data_con_id)
-- The data_con_id is guaranteed to be the wrapper id of the constructor
Of course, if rules aren't turned on then there is pretty much no
point doing this fancy stuff, and it may even be harmful.
+
+=======> Note by SLPJ Dec 08.
+
+I'm unconvinced that we should *ever* generate a build for an explicit
+list. See the comments in GHC.Base about the foldr/cons rule, which
+points out that (foldr k z [a,b,c]) may generate *much* less code than
+(a `k` b `k` c `k` z).
+
+Furthermore generating builds messes up the LHS of RULES.
+Example: the foldr/single rule in GHC.Base
+ foldr k z [x] = ...
+We do not want to generate a build invocation on the LHS of this RULE!
+
+To test this I've added a (static) flag -fsimple-list-literals, which
+makes all list literals be generated via the simple route.
+
+
\begin{code}
dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
dsExplicitList elt_ty xs = do
dflags <- getDOptsDs
xs' <- mapM dsLExpr xs
- if not (dopt Opt_EnableRewriteRules dflags)
+ if opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags)
then return $ mkListExpr elt_ty xs'
else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
where
-> DsM CoreExpr
dsDo stmts body _result_ty
- = go (map unLoc stmts)
+ = goL stmts
where
- go [] = dsLExpr body
-
- go (ExprStmt rhs then_expr _ : stmts)
+ goL [] = dsLExpr body
+ goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go stmt lstmts)
+
+ go (ExprStmt rhs then_expr _) stmts
= do { rhs2 <- dsLExpr rhs
- ; then_expr2 <- dsExpr then_expr
- ; rest <- go stmts
+ ; case tcSplitAppTy_maybe (exprType rhs2) of
+ Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
+ _ -> return ()
+ ; then_expr2 <- dsExpr then_expr
+ ; rest <- goL stmts
; return (mkApps then_expr2 [rhs2, rest]) }
- go (LetStmt binds : stmts)
- = do { rest <- go stmts
+ go (LetStmt binds) stmts
+ = do { rest <- goL stmts
; dsLocalBinds binds rest }
- go (BindStmt pat rhs bind_op fail_op : stmts)
+ go (BindStmt pat rhs bind_op fail_op) stmts
=
- do { body <- go stmts
+ do { body <- goL stmts
; rhs' <- dsLExpr rhs
; bind_op' <- dsExpr bind_op
; var <- selectSimpleMatchVarL pat
-> DsM CoreExpr
dsMDo tbl stmts body result_ty
- = go (map unLoc stmts)
+ = 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)
mfix_id = lookupEvidence tbl mfixName
return_id = lookupEvidence tbl returnMName
fail_id = lookupEvidence tbl failMName
ctxt = MDoExpr tbl
- go [] = dsLExpr body
-
- go (LetStmt binds : stmts)
- = do { rest <- go stmts
+ go _ (LetStmt binds) stmts
+ = do { rest <- goL stmts
; dsLocalBinds binds rest }
- go (ExprStmt rhs _ rhs_ty : stmts)
+ go _ (ExprStmt rhs _ rhs_ty) stmts
= do { rhs2 <- dsLExpr rhs
- ; rest <- go stmts
+ ; warnDiscardedDoBindings rhs m_ty rhs_ty
+ ; rest <- goL stmts
; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
- go (BindStmt pat rhs _ _ : stmts)
- = do { body <- go stmts
+ go _ (BindStmt pat rhs _ _) stmts
+ = do { body <- goL stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
result_ty (cantFailMatchResult body)
; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
- go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
+ go loc (RecStmt rec_stmts later_ids rec_ids rec_rets binds) stmts
= ASSERT( length rec_ids > 0 )
ASSERT( length rec_ids == length rec_rets )
- go (new_bind_stmt : let_stmt : stmts)
+ goL (new_bind_stmt : let_stmt : stmts)
where
- new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
- let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
+ new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
+ let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
-- Remove the later_ids that appear (without fancy coercions)
-- mkCoreTupTy deals with singleton case
return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
- (mk_ret_tup rets)
+ (mkLHsTupleExpr rets)
mk_wild_pat :: Id -> LPat Id
mk_wild_pat v = noLoc $ WildPat $ idType v
mk_tup_pat :: [LPat Id] -> LPat Id
mk_tup_pat [p] = p
mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Errors and contexts}
+%* *
+%************************************************************************
- mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
- mk_ret_tup [r] = r
- mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed
+\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 {
+ -- Warn about discarding non-() things in 'monadic' binding
+ ; warn_unused <- doptDs Opt_WarnUnusedDoBind
+ ; if warn_unused && not (returning_ty `tcEqType` unitTy)
+ then warnDs (unusedMonadBind rhs returning_ty)
+ else do {
+ -- Warn about discarding m a things in 'monadic' binding of the same type,
+ -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
+ ; warn_wrong <- doptDs Opt_WarnWrongDoBind
+ ; case tcSplitAppTy_maybe returning_ty of
+ Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
+ warnDs (wrongMonadBind rhs returning_ty)
+ _ -> return () } }
+
+unusedMonadBind :: LHsExpr Id -> Type -> SDoc
+unusedMonadBind rhs returning_ty
+ = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
+ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
+ ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
+
+wrongMonadBind :: LHsExpr Id -> Type -> SDoc
+wrongMonadBind rhs returning_ty
+ = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
+ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
+ ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
\end{code}
projects / ghc-hetmet.git / blobdiff