X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=2ac19ce5cb97d8bf40031988360495ea5ece7122;hp=043f54fa8066f491968487ea1b50355be150a329;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=146d36e87447f34fd9d0f6a1135173f899aa7f52 diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 043f54f..2ac19ce 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -26,37 +26,43 @@ import DsUtils import DsArrows import DsMonad 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 import TcType import Type +import Coercion import CoreSyn import CoreUtils +import CoreFVs import MkCore import DynFlags +import StaticFlags import CostCentre import Id -import PrelInfo +import VarSet +import VarEnv import DataCon import TysWiredIn import BasicTypes import PrelNames +import Maybes import SrcLoc import Util import Bag import Outputable import FastString + +import Control.Monad \end{code} @@ -78,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 } @@ -96,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) } @@ -154,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) @@ -198,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 @@ -212,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 @@ -239,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 @@ -254,22 +288,43 @@ 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 -dsExpr (HsCase discrim matches) = do - core_discrim <- dsLExpr discrim - ([discrim_var], matching_code) <- matchWrapper CaseAlt matches - return (scrungleMatch discrim_var core_discrim matching_code) +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) (ptext (sLit "case")) + + | otherwise + = do { core_discrim <- dsLExpr discrim + ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches + ; return (scrungleMatch discrim_var core_discrim matching_code) } -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints @@ -280,26 +335,21 @@ 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 (MDoExpr tbl) stmts body result_ty) - = dsMDo tbl 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 (HsIf guard_expr then_expr else_expr) - = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr +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 + ; 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} @@ -310,25 +360,20 @@ dsExpr (HsIf guard_expr then_expr else_expr) dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs --- we create a list from the array elements and convert them into a list using --- `PrelPArr.toP' --- --- * the main disadvantage to this scheme is that `toP' traverses the list --- twice: once to determine the length and a second time to put to elements --- into the array; this inefficiency could be avoided by exposing some of --- the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so --- that we can exploit the fact that we already know the length of the array --- here at compile time +-- We desugar [:x1, ..., xn:] as +-- singletonP x1 +:+ ... +:+ singletonP xn -- +dsExpr (ExplicitPArr ty []) = do + emptyP <- dsLookupDPHId emptyPName + return (Var emptyP `App` Type ty) dsExpr (ExplicitPArr ty xs) = do - toP <- dsLookupGlobalId toPName - coreList <- dsExpr (ExplicitList ty xs) - return (mkApps (Var toP) [Type ty, coreList]) - -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)) + singletonP <- dsLookupDPHId singletonPName + appP <- dsLookupDPHId appPName + xs' <- mapM dsLExpr xs + return . foldr1 (binary appP) $ map (unary singletonP) xs' + where + unary fn x = mkApps (Var fn) [Type ty, x] + binary fn x y = mkApps (Var fn) [Type ty, x, y] dsExpr (ArithSeq expr (From from)) = App <$> dsExpr expr <*> dsLExpr from @@ -387,8 +432,8 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do = 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 @@ -421,52 +466,101 @@ RHSs, and do not generate a Core constructor application directly, because the c might do some argument-evaluation first; and may have to throw away some dictionaries. +Note [Update for GADTs] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b where + T1 { f1 :: a } :: T a Int + +Then the wrapper function for T1 has type + $WT1 :: a -> T a Int +But if x::T a b, then + x { f1 = v } :: T a b (not T a Int!) +So we need to cast (T a Int) to (T a b). Sigh. + \begin{code} dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) cons_to_upd in_inst_tys out_inst_tys) | null fields = dsLExpr record_expr | otherwise - = -- Record stuff doesn't work for existentials - -- The type checker checks for this, but we need - -- worry only about the constructors that are to be updated - ASSERT2( notNull cons_to_upd && all isVanillaDataCon cons_to_upd, ppr expr ) + = ASSERT2( notNull cons_to_upd, ppr expr ) do { record_expr' <- dsLExpr record_expr - ; let -- Awkwardly, for families, the match goes - -- from instance type to family type - tycon = dataConTyCon (head cons_to_upd) - in_ty = mkTyConApp tycon in_inst_tys - in_out_ty = mkFunTy in_ty - (mkFamilyTyConApp tycon out_inst_tys) - - mk_val_arg field old_arg_id - = case findField fields field of - (rhs:rest) -> ASSERT(null rest) rhs - [] -> nlHsVar old_arg_id - - mk_alt con - = ASSERT( isVanillaDataCon con ) - do { arg_ids <- newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) - -- This call to dataConInstOrigArgTys won't work for existentials - -- but existentials don't have record types anyway - ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg - (dataConFieldLabels con) arg_ids - rhs = foldl (\a b -> nlHsApp a b) - (nlHsTyApp (dataConWrapId con) out_inst_tys) - val_args - pat = mkPrefixConPat con (map nlVarPat arg_ids) in_ty - - ; return (mkSimpleMatch [pat] rhs) } + ; field_binds' <- mapM ds_field fields + ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding + upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] -- It's important to generate the match with matchWrapper, -- and the right hand sides with applications of the wrapper Id -- so that everything works when we are doing fancy unboxing on the -- constructor aguments. - ; alts <- mapM mk_alt cons_to_upd - ; ([discrim_var], matching_code) <- matchWrapper RecUpd (MatchGroup alts in_out_ty) + ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd + ; ([discrim_var], matching_code) + <- matchWrapper RecUpd (MatchGroup alts in_out_ty) + + ; return (add_field_binds field_binds' $ + bindNonRec discrim_var record_expr' matching_code) } + where + ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr) + -- Clone the Id in the HsRecField, because its Name is that + -- of the record selector, and we must not make that a lcoal binder + -- else we shadow other uses of the record selector + -- Hence 'lcl_id'. Cf Trac #2735 + ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field) + ; let fld_id = unLoc (hsRecFieldId rec_field) + ; lcl_id <- newSysLocalDs (idType fld_id) + ; return (idName fld_id, lcl_id, rhs) } + + add_field_binds [] expr = expr + add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) + + -- Awkwardly, for families, the match goes + -- from instance type to family type + tycon = dataConTyCon (head cons_to_upd) + in_ty = mkTyConApp tycon in_inst_tys + in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys) + + mk_alt upd_fld_env con + = do { let (univ_tvs, ex_tvs, eq_spec, + theta, arg_tys, _) = dataConFullSig con + subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys) + + -- I'm not bothering to clone the ex_tvs + ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) + ; theta_vars <- mapM newPredVarDs (substTheta subst theta) + ; arg_ids <- newSysLocalsDs (substTys subst arg_tys) + ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg + (dataConFieldLabels con) arg_ids + mk_val_arg field_name pat_arg_id + = 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 = mkWpEvVarApps theta_vars `WpCompose` + mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose` + mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys + , not (tv `elemVarEnv` wrap_subst) ] + rhs = foldl (\a b -> nlHsApp a b) inst_con val_args + + -- Tediously wrap the application in a cast + -- Note [Update for GADTs] + wrapped_rhs | null eq_spec = rhs + | otherwise = mkLHsWrap (WpCast wrap_co) rhs + wrap_co = mkTyConAppCo tycon [ lookup tv ty + | (tv,ty) <- univ_tvs `zip` out_inst_tys] + lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of + Just co' -> co' + Nothing -> mkReflCo ty + wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var)) + | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ] + + pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs + , pat_dicts = eqs_vars ++ theta_vars + , pat_binds = emptyTcEvBinds + , pat_args = PrefixCon $ map nlVarPat arg_ids + , pat_ty = in_ty } + ; return (mkSimpleMatch [pat] wrapped_rhs) } - ; return (bindNonRec discrim_var record_expr' matching_code) } \end{code} Here is where we desugar the Template Haskell brackets and escapes @@ -499,7 +593,7 @@ dsExpr (HsTick ix vars e) = do dsExpr (HsBinTick ixT ixF e) = do e2 <- dsLExpr e - do { ASSERT(exprType e2 `coreEqType` boolTy) + do { ASSERT(exprType e2 `eqType` boolTy) mkBinaryTickBox ixT ixF e2 } \end{code} @@ -552,24 +646,53 @@ allocation in some nofib programs. Specifically 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. -\begin{code} +=======> 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! + +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 not (dopt Opt_RewriteRules 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) @@ -581,150 +704,150 @@ 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 - = go (map unLoc stmts) +dsDo :: [LStmt Id] -> DsM CoreExpr +dsDo stmts + = goL stmts where - go [] = dsLExpr body - - go (ExprStmt rhs then_expr _ : stmts) + goL [] = panic "dsDo" + goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + + 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 - ; then_expr2 <- dsExpr then_expr - ; rest <- go stmts + ; warnDiscardedDoBindings rhs (exprType rhs2) + ; 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, recS_ret_ty = body_ty }) stmts + = ASSERT( length rec_ids > 0 ) + goL (new_bind_stmt : stmts) + where + 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 ++ [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 -- 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 " ++ 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)) +%************************************************************************ +%* * + 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} -dsMDo :: PostTcTable - -> [LStmt Id] - -> LHsExpr Id - -> Type -- Type of the whole expression - -> DsM CoreExpr - -dsMDo tbl stmts body result_ty - = go (map unLoc stmts) - where - (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 - ; dsLocalBinds binds rest } +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 `eqType` 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} - go (ExprStmt rhs _ rhs_ty : stmts) - = do { rhs2 <- dsLExpr rhs - ; rest <- go stmts - ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) } - - go (BindStmt pat rhs _ _ : stmts) - = do { body <- go stmts - ; 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]) } - - go (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) - where - new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app - let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] [])) - - - -- 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 (nlHsTyApp mfix_id [tup_ty]) 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 = mkCoreTupTy (map idType (later_ids' ++ rec_ids)) - -- mkCoreTupTy deals with singleton case - - return_app = nlHsApp (nlHsTyApp 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` 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 - - mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id - mk_ret_tup [r] = r - mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed +%************************************************************************ +%* * +\subsection{Errors and contexts} +%* * +%************************************************************************ + +\begin{code} +-- Warn about certain types of values discarded in monadic bindings (#3263) +warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () +warnDiscardedDoBindings rhs rhs_ty + | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty + = do { -- Warn about discarding non-() things in 'monadic' binding + ; warn_unused <- doptDs Opt_WarnUnusedDoBind + ; if warn_unused && not (isUnitTy elt_ty) + then warnDs (unusedMonadBind rhs elt_ty) + else + -- 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 + do { warn_wrong <- doptDs Opt_WarnWrongDoBind + ; case tcSplitAppTy_maybe elt_ty of + Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty + -> warnDs (wrongMonadBind rhs elt_ty) + _ -> return () } } + + | otherwise -- RHS does have type of form (m ty), which is wierd + = return () -- but at lesat this warning is irrelevant + +unusedMonadBind :: LHsExpr Id -> Type -> SDoc +unusedMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_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 elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_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}