X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=9d1edc761eb65e1ee1e90e44016dc55905d7f8b1;hp=509cce23b6e710c4a25a7f0bbf401394d3cf7da1;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=79b22beb4d2eca1877d99d55838ba6ce69658405 diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 509cce2..9d1edc7 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -29,13 +29,11 @@ import Name import NameEnv #ifdef GHCI -import PrelNames -- Template Haskell stuff iff bootstrapped import DsMeta #endif import HsSyn -import TcHsSyn -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types @@ -44,13 +42,15 @@ import Type import Coercion import CoreSyn import CoreUtils +import CoreFVs import MkCore import DynFlags import StaticFlags import CostCentre import Id -import PrelInfo +import Var +import VarSet import DataCon import TysWiredIn import BasicTypes @@ -61,6 +61,8 @@ import Util import Bag import Outputable import FastString + +import Control.Monad \end{code} @@ -82,9 +84,9 @@ dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds ------------------------- dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr -dsIPBinds (IPBinds ip_binds dict_binds) body - = do { prs <- dsLHsBinds dict_binds - ; let inner = Let (Rec prs) body +dsIPBinds (IPBinds ip_binds ev_binds) body + = do { ds_ev_binds <- dsTcEvBinds ev_binds + ; let inner = wrapDsEvBinds ds_ev_binds body -- The dict bindings may not be in -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } @@ -100,50 +102,18 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind (NonRecursive, hsbinds) body - | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds, - (L loc bind : null_binds) <- bagToList binds, - isBangHsBind bind - || isUnboxedTupleBind bind - || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports] - = let - body_w_exports = foldr bind_export body exports - bind_export (tvs, g, l, _) body = ASSERT( null tvs ) - bindNonRec g (Var l) body - in - ASSERT (null null_binds) + | [L loc bind] <- bagToList hsbinds, -- Non-recursive, non-overloaded bindings only come in ones -- 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.) - putSrcSpanDs loc $ - case bind of - FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, - fun_tick = tick, fun_infix = inf } - -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches - MASSERT( null args ) -- Functions aren't lifted - MASSERT( isIdHsWrapper co_fn ) - rhs' <- mkOptTickBox tick rhs - return (bindNonRec fun rhs' body_w_exports) - - PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty } - -> -- let C x# y# = rhs in body - -- ==> case rhs of C x# y# -> body - putSrcSpanDs loc $ - do { rhs <- dsGuarded grhss ty - ; let upat = unLoc pat - eqn = EqnInfo { eqn_pats = [upat], - eqn_rhs = cantFailMatchResult body_w_exports } - ; var <- selectMatchVar upat - ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) - ; return (scrungleMatch var rhs result) } - - _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body) - + strictMatchOnly bind + = putSrcSpanDs loc (dsStrictBind bind body) -- Ordinary case for bindings; none should be unlifted ds_val_bind (_is_rec, binds) body = do { prs <- dsLHsBinds binds - ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) ) + ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds ) case prs of [] -> return body _ -> return (Let (Rec prs) body) } @@ -158,9 +128,53 @@ ds_val_bind (_is_rec, binds) body -- NB The previous case dealt with unlifted bindings, so we -- only have to deal with lifted ones now; so Rec is ok -isUnboxedTupleBind :: HsBind Id -> Bool -isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty -isUnboxedTupleBind _ = False +------------------ +dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr +dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = binds }) body + = do { ds_ev_binds <- dsTcEvBinds ev_binds + ; let body1 = foldr bind_export body exports + bind_export (_, g, l, _) b = bindNonRec g (Var l) b + ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) + body1 binds + ; return (wrapDsEvBinds ds_ev_binds body2) } + +dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn + , fun_tick = tick, fun_infix = inf }) body + -- Can't be a bang pattern (that looks like a PatBind) + -- so must be simply unboxed + = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches + ; MASSERT( null args ) -- Functions aren't lifted + ; MASSERT( isIdHsWrapper co_fn ) + ; rhs' <- mkOptTickBox tick rhs + ; return (bindNonRec fun rhs' body) } + +dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body + = -- let C x# y# = rhs in body + -- ==> case rhs of C x# y# -> body + do { rhs <- dsGuarded grhss ty + ; let upat = unLoc pat + eqn = EqnInfo { eqn_pats = [upat], + eqn_rhs = cantFailMatchResult body } + ; var <- selectMatchVar upat + ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) + ; return (scrungleMatch var rhs result) } + +dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) + +---------------------- +strictMatchOnly :: HsBind Id -> Bool +strictMatchOnly (AbsBinds { abs_binds = binds }) + = anyBag (strictMatchOnly . unLoc) binds +strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty }) + = isUnboxedTupleType ty + || isBangLPat lpat + || any (isUnLiftedType . idType) (collectPatBinders lpat) +strictMatchOnly (FunBind { fun_id = L _ id }) + = isUnLiftedType (idType id) +strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr -- Returns something like (let var = scrut in body) @@ -202,12 +216,28 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e + +dsExpr (HsHetMetBrak c e) = do { e' <- dsExpr (unLoc e) + ; brak <- dsLookupGlobalId hetmet_brak_name + ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] } +dsExpr (HsHetMetEsc c t e) = do { e' <- dsExpr (unLoc e) + ; esc <- dsLookupGlobalId hetmet_esc_name + ; return $ mkApps (Var esc) [ (Type c), (Type t), e'] } +dsExpr (HsHetMetCSP c e) = do { e' <- dsExpr (unLoc e) + ; csp <- dsLookupGlobalId hetmet_csp_name + ; return $ mkApps (Var csp) [ (Type c), (Type $ exprType e'), e'] } dsExpr (ExprWithTySigOut e _) = dsLExpr e dsExpr (HsVar var) = return (Var var) dsExpr (HsIPVar ip) = return (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit -dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e) + +dsExpr (HsWrap co_fn e) + = do { co_fn' <- dsHsWrapper co_fn + ; e' <- dsExpr e + ; warn_id <- doptDs Opt_WarnIdentities + ; when warn_id $ warnAboutIdentities e' co_fn' + ; return (co_fn' e') } dsExpr (NegApp expr neg_expr) = App <$> dsExpr neg_expr <*> dsLExpr expr @@ -216,7 +246,7 @@ dsExpr (HsLam a_Match) = 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 @@ -243,10 +273,10 @@ will sort it out. \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 @@ -258,15 +288,31 @@ 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 Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr - --- hdaume: core annotation - dsExpr (HsCoreAnn fs expr) = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr @@ -298,8 +344,11 @@ dsExpr (HsDo ListComp stmts body result_ty) dsExpr (HsDo DoExpr stmts body result_ty) = dsDo stmts body result_ty -dsExpr (HsDo (MDoExpr tbl) stmts body result_ty) - = dsMDo tbl 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 @@ -307,8 +356,14 @@ dsExpr (HsDo PArrComp stmts body result_ty) where [elt_ty] = tcTyConAppArgs result_ty -dsExpr (HsIf guard_expr then_expr else_expr) - = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr +dsExpr (HsIf mb_fun guard_expr then_expr else_expr) + = do { pred <- dsLExpr guard_expr + ; b1 <- dsLExpr then_expr + ; b2 <- dsLExpr else_expr + ; case mb_fun of + Just fun -> do { core_fun <- dsExpr fun + ; return (mkCoreApps core_fun [pred,b1,b2]) } + Nothing -> return $ mkIfThenElse pred b1 b2 } \end{code} @@ -334,11 +389,6 @@ dsExpr (ExplicitPArr ty xs) = do 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 @@ -500,8 +550,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id) inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con)) -- Reconstruct with the WrapId so that unpacking happens - wrap = mkWpApps theta_vars `WpCompose` - mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose` + wrap = mkWpEvVarApps theta_vars `WpCompose` + mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose` mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys , isNothing (lookupTyVar wrap_subst tv) ] rhs = foldl (\a b -> nlHsApp a b) inst_con val_args @@ -520,7 +570,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs , pat_dicts = eqs_vars ++ theta_vars - , pat_binds = emptyLHsBinds + , pat_binds = emptyTcEvBinds , pat_args = PrefixCon $ map nlVarPat arg_ids , pat_ty = in_ty } ; return (mkSimpleMatch [pat] wrapped_rhs) } @@ -623,28 +673,40 @@ 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! +We fix this by disabling rules in rule LHSs, and testing that +flag here; see Note [Desugaring RULE left hand sides] in Desugar + 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 -- See Note [Desugaring explicit lists] -dsExplicitList elt_ty xs = do - dflags <- getDOptsDs - xs' <- mapM dsLExpr xs - if opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags) - then return $ mkListExpr elt_ty xs' - else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs') +dsExplicitList elt_ty xs + = do { dflags <- getDOptsDs + ; xs' <- mapM dsLExpr xs + ; let (dynamic_prefix, static_suffix) = spanTail is_static xs' + ; if opt_SimpleListLiterals -- -fsimple-list-literals + || not (dopt Opt_EnableRewriteRules dflags) -- Rewrite rules off + -- Don't generate a build if there are no rules to eliminate it! + -- See Note [Desugaring RULE left hand sides] in Desugar + || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)! + then return $ mkListExpr elt_ty xs' + else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) } where - mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do - let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs' - static_suffix' = mkListExpr elt_ty static_suffix - - folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix' - let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix - return build_body + is_static :: CoreExpr -> Bool + is_static e = all is_static_var (varSetElems (exprFreeVars e)) + + is_static_var :: Var -> Bool + is_static_var v + | isId v = isExternalName (idName v) -- Top-level things are given external names + | otherwise = False -- Type variables + + mkSplitExplicitList prefix suffix (c, _) (n, n_ty) + = do { let suffix' = mkListExpr elt_ty suffix + ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix' + ; return (foldr (App . App (Var c)) folded_suffix prefix) } spanTail :: (a -> Bool) -> [a] -> ([a], [a]) spanTail f xs = (reverse rejected, reverse satisfying) @@ -661,43 +723,77 @@ dsDo :: [LStmt Id] -> Type -- Type of the whole expression -> DsM CoreExpr -dsDo stmts body _result_ty - = go (map unLoc stmts) +dsDo stmts body result_ty + = goL stmts where - go [] = dsLExpr body - - go (ExprStmt rhs then_expr _ : stmts) + -- 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) + + 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) - = - do { body <- go stmts - ; rhs' <- dsLExpr rhs - ; bind_op' <- dsExpr bind_op - ; var <- selectSimpleMatchVarL pat - ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2 - res1_ty = funResultTy (funArgTy (funResultTy bind_ty)) - ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat - res1_ty (cantFailMatchResult body) - ; match_code <- handle_failure pat match fail_op - ; return (mkApps bind_op' [rhs', Lam var match_code]) } + go _ (BindStmt pat rhs bind_op fail_op) stmts + = do { body <- goL stmts + ; rhs' <- dsLExpr rhs + ; bind_op' <- dsExpr bind_op + ; var <- selectSimpleMatchVarL pat + ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2 + res1_ty = funResultTy (funArgTy (funResultTy bind_ty)) + ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat + res1_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_ret_fn = return_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op + , recS_rec_rets = rec_rets }) 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 + noSyntaxExpr -- Tuple cannot fail + + tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids + 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 + +handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr -- In a do expression, pattern-match failure just calls -- the monadic 'fail' rather than throwing an exception - handle_failure pat match fail_op - | matchCanFail match - = do { fail_op' <- dsExpr fail_op - ; fail_msg <- mkStringExpr (mk_fail_msg pat) - ; extractMatchResult match (App fail_op' fail_msg) } - | otherwise - = extractMatchResult match (error "It can't fail") +handle_failure pat match fail_op + | matchCanFail match + = do { fail_op' <- dsExpr fail_op + ; fail_msg <- mkStringExpr (mk_fail_msg pat) + ; extractMatchResult match (App fail_op' fail_msg) } + | otherwise + = extractMatchResult match (error "It can't fail") mk_fail_msg :: Located e -> String mk_fail_msg pat = "Pattern match failure in do expression at " ++ @@ -712,55 +808,58 @@ We turn (RecStmt [v1,..vn] stmts) into: return (v1,..vn)) \begin{code} -dsMDo :: PostTcTable +{- +dsMDo :: HsStmtContext Name + -> [(Name,Id)] -> [LStmt Id] -> LHsExpr Id -> Type -- Type of the whole expression -> DsM CoreExpr -dsMDo tbl stmts body result_ty - = go (map unLoc stmts) +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) - mfix_id = lookupEvidence tbl mfixName return_id = lookupEvidence tbl returnMName bind_id = lookupEvidence tbl bindMName then_id = lookupEvidence tbl thenMName 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 then_expr rhs_ty) stmts = do { rhs2 <- dsLExpr rhs - ; rest <- go stmts - ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) } + ; warnDiscardedDoBindings rhs m_ty rhs_ty + ; then_expr2 <- dsExpr then_expr + ; rest <- goL stmts + ; return (mkApps then_expr2 [rhs2, rest]) } - go (BindStmt pat rhs _ _ : stmts) - = do { body <- go stmts - ; var <- selectSimpleMatchVarL pat + 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) - ; fail_msg <- mkStringExpr (mk_fail_msg pat) - ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg] - ; match_code <- extractMatchResult match fail_expr - - ; rhs' <- dsLExpr rhs - ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, - rhs', Lam var match_code]) } + result_ty (cantFailMatchResult body) + ; match_code <- handle_failure pat match fail_op + ; return (mkApps bind_op [rhs', Lam var match_code]) } - go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts) + 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 ) - go (new_bind_stmt : let_stmt : stmts) + ASSERT( isEmptyTcEvBinds _ev_binds ) + pprTrace "dsMDo" (ppr later_ids) $ + goL (new_bind_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 $ 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 @@ -768,7 +867,7 @@ dsMDo tbl stmts body result_ty later_ids' = filter (`notElem` mono_rec_ids) later_ids mono_rec_ids = [ id | HsVar id <- rec_rets ] - mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg + mfix_app = nlHsApp (noLoc mfix_op) mfix_arg mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] (mkFunTy tup_ty body_ty)) @@ -782,11 +881,9 @@ dsMDo tbl stmts body result_ty 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 = mkCoreTupTy (map idType (later_ids' ++ rec_ids)) - -- mkCoreTupTy deals with singleton case + tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case - return_app = nlHsApp (nlHsTyApp return_id [tup_ty]) - (mk_ret_tup rets) + return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) mk_wild_pat :: Id -> LPat Id mk_wild_pat v = noLoc $ WildPat $ idType v @@ -798,8 +895,72 @@ dsMDo tbl stmts body result_ty mk_tup_pat :: [LPat Id] -> LPat Id mk_tup_pat [p] = p mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed +-} +\end{code} - mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id - mk_ret_tup [r] = r - mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed + +%************************************************************************ +%* * + Warning about identities +%* * +%************************************************************************ + +Warn about functions that convert between one type and another +when the to- and from- types are the same. Then it's probably +(albeit not definitely) the identity +\begin{code} +warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM () +warnAboutIdentities (Var v) co_fn + | idName v `elem` conversionNames + , let fun_ty = exprType (co_fn (Var v)) + , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty + , arg_ty `tcEqType` res_ty -- So we are converting ty -> ty + = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty + , nest 2 $ ptext (sLit "can probably be omitted") + , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)")) + ]) +warnAboutIdentities _ _ = return () + +conversionNames :: [Name] +conversionNames + = [ toIntegerName, toRationalName + , fromIntegralName, realToFracName ] + -- We can't easily add fromIntegerName, fromRationalName, + -- becuase they are generated by literals +\end{code} + +%************************************************************************ +%* * +\subsection{Errors and contexts} +%* * +%************************************************************************ + +\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}