X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=ef69b479893e843f34244b57fb8a6ea0b3538827;hp=820bd9ac3e6ba051a7f7cf93ec2e578c95c4fe93;hb=85f969a6585c06168645114d9524e7169dbc6e32;hpb=58521c72cec262496dabf5fffb057d25ab17a0f7 diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 820bd9a..ef69b47 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -43,12 +43,15 @@ import Type import Coercion import CoreSyn import CoreUtils +import CoreFVs import MkCore import DynFlags import StaticFlags import CostCentre import Id +import Var +import VarSet import PrelInfo import DataCon import TysWiredIn @@ -208,7 +211,9 @@ 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' <- dsCoercion co_fn + ; e' <- dsExpr e + ; return (co_fn' e') } dsExpr (NegApp expr neg_expr) = App <$> dsExpr neg_expr <*> dsLExpr expr @@ -318,6 +323,9 @@ dsExpr (HsDo ListComp stmts body 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 tbl) stmts body result_ty) = dsMDo tbl stmts body result_ty @@ -638,28 +646,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) @@ -676,13 +696,16 @@ dsDo :: [LStmt Id] -> Type -- Type of the whole expression -> DsM CoreExpr -dsDo stmts body _result_ty +dsDo stmts body result_ty = 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 stmt lstmts) + goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - go (ExprStmt rhs then_expr _) stmts + 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 @@ -691,23 +714,51 @@ dsDo stmts body _result_ty ; rest <- goL stmts ; return (mkApps then_expr2 [rhs2, rest]) } - go (LetStmt binds) stmts + go _ (LetStmt binds) stmts = do { rest <- goL stmts ; dsLocalBinds binds rest } - 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 _ (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_dicts = binds }) stmts + = ASSERT( length rec_ids > 0 ) + goL (new_bind_stmt : let_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 + + let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] [])) + + 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 + -- In a do expression, pattern-match failure just calls -- the monadic 'fail' rather than throwing an exception handle_failure pat match fail_op @@ -774,10 +825,11 @@ dsMDo tbl stmts body result_ty ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, rhs', Lam var match_code]) } - go loc (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 ) - goL (new_bind_stmt : let_stmt : stmts) + pprTrace "dsMDo" (ppr later_ids) $ + goL (new_bind_stmt : let_stmt : stmts) where new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] [])) @@ -803,8 +855,7 @@ 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]) (mkLHsTupleExpr rets)