From fb982282ff6307b342d8fbc09b58a990d76c68fb Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 7 Oct 2010 09:59:35 +0000 Subject: [PATCH] Avoid redundant simplification When adding specialisation for imported Ids, I noticed that the Glorious Simplifier was repeatedly (and fruitlessly) simplifying the same term. It turned out to be easy to fix this, because I already had a flag in the ApplyTo and Select constructors of SimplUtils.SimplCont. See Note [Avoid redundant simplification] --- compiler/simplCore/SimplUtils.lhs | 43 ++++++++++++++++++++++++++----------- compiler/simplCore/Simplify.lhs | 39 ++++++++++++++++++++++----------- 2 files changed, 58 insertions(+), 24 deletions(-) diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index a37cfe9..1fb04fe 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -15,8 +15,9 @@ module SimplUtils ( -- The continuation type SimplCont(..), DupFlag(..), ArgInfo(..), + isSimplified, contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, - pushArgs, countValArgs, countArgs, addArgTo, + pushSimplifiedArgs, countValArgs, countArgs, addArgTo, mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, interestingCallContext, @@ -99,12 +100,12 @@ data SimplCont SimplCont | ApplyTo -- C arg - DupFlag - InExpr StaticEnv -- The argument and its static env + DupFlag -- See Note [DupFlag invariants] + InExpr StaticEnv -- The argument and its static env SimplCont | Select -- case C of alts - DupFlag + DupFlag -- See Note [DupFlag invariants] InId [InAlt] StaticEnv -- The case binder, alts, and subst-env SimplCont @@ -151,14 +152,31 @@ instance Outputable SimplCont where (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont ppr (CoerceIt co cont) = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont -data DupFlag = OkToDup | NoDup +data DupFlag = NoDup -- Unsimplified, might be big + | Simplified -- Simplified + | OkToDup -- Simplified and small + +isSimplified :: DupFlag -> Bool +isSimplified NoDup = False +isSimplified _ = True -- Invariant: the subst-env is empty instance Outputable DupFlag where - ppr OkToDup = ptext (sLit "ok") - ppr NoDup = ptext (sLit "nodup") + ppr OkToDup = ptext (sLit "ok") + ppr NoDup = ptext (sLit "nodup") + ppr Simplified = ptext (sLit "simpl") +\end{code} +Note [DupFlag invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In both (ApplyTo dup _ env k) + and (Select dup _ _ env k) +the following invariants hold + (a) if dup = OkToDup, then continuation k is also ok-to-dup + (b) if dup = OkToDup or Simplified, the subst-env is empty + (and and hence no need to re-simplify) +\begin{code} ------------------- mkBoringStop :: SimplCont mkBoringStop = Stop BoringCtxt @@ -179,8 +197,8 @@ contIsRhsOrArg _ = False ------------------- contIsDupable :: SimplCont -> Bool contIsDupable (Stop {}) = True -contIsDupable (ApplyTo OkToDup _ _ _) = True -contIsDupable (Select OkToDup _ _ _ _) = True +contIsDupable (ApplyTo OkToDup _ _ _) = True -- See Note [DupFlag invariants] +contIsDupable (Select OkToDup _ _ _ _) = True -- ...ditto... contIsDupable (CoerceIt _ cont) = contIsDupable cont contIsDupable _ = False @@ -238,9 +256,10 @@ contArgs cont@(ApplyTo {}) contArgs cont = (True, [], cont) -pushArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont -pushArgs _env [] cont = cont -pushArgs env (arg:args) cont = ApplyTo NoDup arg env (pushArgs env args cont) +pushSimplifiedArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont +pushSimplifiedArgs _env [] cont = cont +pushSimplifiedArgs env (arg:args) cont = ApplyTo Simplified arg env (pushSimplifiedArgs env args cont) + -- The env has an empty SubstEnv dropArgs :: Int -> SimplCont -> SimplCont dropArgs 0 cont = cont diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 379fce1..9e73359 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -322,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) @@ -387,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 @@ -547,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 @@ -722,7 +723,7 @@ simplUnfolding env top_lvl id _ _ 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 InlineRhs (isTopLevel top_lvl) (isBottomingId id) new_rhs) @@ -896,10 +897,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) @@ -951,7 +951,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} @@ -1089,7 +1091,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 @@ -1237,7 +1240,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 @@ -1266,7 +1272,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 } } @@ -1277,7 +1283,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 @@ -1285,6 +1291,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 -- 1.7.10.4