X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=179af4f3450565ea013f8c9468c121697c3638fc;hb=a46bdb63d919da9478bcd1bee2933dc19bc174ab;hp=0a1fdd2d8719f26eee68a9a636cf9768f7d08d68;hpb=fc8e106e73a4c375d64b83c387a821fe355f4393;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 0a1fdd2..179af4f 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -28,8 +28,9 @@ import CoreMonad ( SimplifierSwitch(..), Tick(..) ) import CoreSyn import Demand ( isStrictDmd, splitStrictSig ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule, - exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) +import CoreUnfold ( mkUnfolding, mkCoreUnfolding + , mkInlineUnfolding, mkSimpleUnfolding + , exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) import CoreUtils import qualified CoreSubst import CoreArity ( exprArity ) @@ -321,7 +322,8 @@ simplLazyBind :: SimplEnv -> SimplM SimplEnv simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se - = do { let rhs_env = rhs_se `setInScope` env + = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ + do { let rhs_env = rhs_se `setInScope` env (tvs, body) = case collectTyBinders rhs of (tvs, body) | not_lam body -> (tvs,body) | otherwise -> ([], rhs) @@ -386,7 +388,7 @@ completeNonRecX :: TopLevelFlag -> SimplEnv completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs - ; (env2, rhs2) <- + ; (env2, rhs2) <- if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1 then do { tick LetFloatFromLet ; return (addFloats env env1, rhs1) } -- Add the floats to the main env @@ -546,7 +548,7 @@ makeTrivialWithInfo top_lvl env info expr = do { uniq <- getUniqueM ; let name = mkSystemVarName uniq (fsLit "a") var = mkLocalIdWithInfo name expr_ty info - ; env' <- completeNonRecX top_lvl env False var var expr + ; env' <- completeNonRecX top_lvl env False var var expr ; expr' <- simplVar env' var ; return (env', expr') } -- The simplVar is needed becase we're constructing a new binding @@ -713,18 +715,33 @@ simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops) simplUnfolding env top_lvl id _ _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity , uf_src = src, uf_guidance = guide }) - | isInlineRuleSource src + | isStableSource src = do { expr' <- simplExpr rule_env expr ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src - ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) } + is_top_lvl = isTopLevel top_lvl + ; case guide of + UnfIfGoodArgs{} -> + -- We need to force bottoming, or the new unfolding holds + -- on to the old unfolding (which is part of the id). + let bottoming = isBottomingId id + in bottoming `seq` return (mkUnfolding src' is_top_lvl bottoming expr') + -- If the guidance is UnfIfGoodArgs, this is an INLINABLE + -- unfolding, and we need to make sure the guidance is kept up + -- to date with respect to any changes in the unfolding. + _other -> + return (mkCoreUnfolding src' is_top_lvl expr' arity guide) -- See Note [Top-level flag on inline rules] in CoreUnfold + } where act = idInlineActivation id rule_env = updMode (updModeForInlineRules act) env - -- See Note [Simplifying gently inside InlineRules] in SimplUtils + -- See Note [Simplifying inside InlineRules] in SimplUtils simplUnfolding _ top_lvl id _occ_info new_rhs _ - = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs) + = -- We need to force bottoming, or the new unfolding holds + -- on to the old unfolding (which is part of the id). + let bottoming = isBottomingId id + in bottoming `seq` return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs) -- We make an unfolding *even for loop-breakers*. -- Reason: (a) It might be useful to know that they are WHNF -- (b) In TidyPgm we currently assume that, if we want to @@ -895,10 +912,9 @@ simplExprF' env (Case scrut bndr _ alts) cont | otherwise = -- If case-of-case is off, simply simplify the case expression -- in a vanilla Stop context, and rebuild the result around it - do { case_expr' <- simplExprC env scrut case_cont + do { case_expr' <- simplExprC env scrut + (Select NoDup bndr alts env mkBoringStop) ; rebuild env case_expr' cont } - where - case_cont = Select NoDup bndr alts env mkBoringStop simplExprF' env (Let (Rec pairs) body) cont = do { env' <- simplRecBndrs env (map fst pairs) @@ -950,7 +966,9 @@ rebuild env expr cont0 StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr ; simplLam env' bs body cont } - ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg + ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification] + | isSimplified dup_flag -> rebuild env (App expr arg) cont + | otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg ; rebuild env (App expr arg') cont } \end{code} @@ -1088,7 +1106,8 @@ simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont | preInlineUnconditionally env NotTopLevel bndr rhs = do { tick (PreInlineUnconditionally bndr) - ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } + ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ + simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } | isStrictId bndr = do { simplExprF (rhs_se `setFloats` env) rhs @@ -1236,7 +1255,10 @@ rebuildCall env info (ApplyTo _ (Type arg_ty) se cont) rebuildCall env info@(ArgInfo { ai_encl = encl_rules , ai_strs = str:strs, ai_discs = disc:discs }) - (ApplyTo _ arg arg_se cont) + (ApplyTo dup_flag arg arg_se cont) + | isSimplified dup_flag -- See Note [Avoid redundant simplification] + = rebuildCall env (addArgTo info' arg) cont + | str -- Strict argument = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setFloats` env) arg @@ -1265,7 +1287,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) ; mb_rule <- tryRules env rules fun args cont ; case mb_rule of { Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $ - pushArgs env' (drop n_args args) cont ; + pushSimplifiedArgs env' (drop n_args args) cont ; -- n_args says how many args the rule consumed ; Nothing -> rebuild env (mkApps (Var fun) args) cont -- No rules } } @@ -1276,7 +1298,7 @@ Note [RULES apply to simplified arguments] It's very desirable to try RULES once the arguments have been simplified, because doing so ensures that rule cascades work in one pass. Consider {-# RULES g (h x) = k x - f (k x) = x #-} + f (k x) = x #-} ...f (g (h x))... Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If we match f's rules against the un-simplified RHS, it won't match. This @@ -1284,6 +1306,15 @@ makes a particularly big difference when superclass selectors are involved: op ($p1 ($p2 (df d))) We want all this to unravel in one sweeep. +Note [Avoid redundant simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because RULES apply to simplified arguments, there's a danger of repeatedly +simplifying already-simplified arguments. An important example is that of + (>>=) d e1 e2 +Here e1, e2 are simplified before the rule is applied, but don't really +participate in the rule firing. So we mark them as Simplified to avoid +re-simplifying them. + Note [Shadowing] ~~~~~~~~~~~~~~~~ This part of the simplifier may break the no-shadowing invariant @@ -1789,7 +1820,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv addBinderUnfolding env bndr rhs - = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs) + = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs) addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv addBinderOtherCon env bndr cons @@ -2016,7 +2047,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') DataAlt dc -> setIdUnfolding case_bndr unf where -- See Note [Case binders and join points] - unf = mkInlineRule rhs Nothing + unf = mkInlineUnfolding Nothing rhs rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) ++ varsToCoreExprs bndrs') @@ -2243,7 +2274,7 @@ The desire not to duplicate is the entire reason that mkDupableCont returns a pair of continuations. -Note [Single-atlernative cases] +Note [Single-alternative cases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This case is just like the ArgOf case. Here's an example: data T a = MkT !a