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]

2 files changed, 58 insertions, 24 deletions

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index a37cfe9870..1fb04febf1 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 379fce1555..9e73359143 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