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]

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index a37cfe9..1fb04fe 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -15,8 +15,9 @@ module SimplUtils (
 
        -- The continuation type
        SimplCont(..), DupFlag(..), ArgInfo(..),
 
        -- The continuation type
        SimplCont(..), DupFlag(..), ArgInfo(..),

+        isSimplified,

        contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, 
        contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, 

-       pushArgs, countValArgs, countArgs, addArgTo,
+       pushSimplifiedArgs, countValArgs, countArgs, addArgTo,

        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
        interestingCallContext, 
 
        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
        interestingCallContext, 
 

@@ -99,12 +100,12 @@ data SimplCont
        SimplCont
 
   | ApplyTo            -- C arg
        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
        SimplCont
 
   | Select             -- case C of alts

-       DupFlag 
+       DupFlag                 -- See Note [DupFlag invariants]

        InId [InAlt] StaticEnv  -- The case binder, alts, and subst-env
        SimplCont
 
        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
 
                                       (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
 
 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
 -------------------
 mkBoringStop :: SimplCont
 mkBoringStop = Stop BoringCtxt

@@ -179,8 +197,8 @@ contIsRhsOrArg _               = False
 -------------------
 contIsDupable :: SimplCont -> Bool
 contIsDupable (Stop {})                  = True
 -------------------
 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
 
 contIsDupable (CoerceIt _ cont)          = contIsDupable cont
 contIsDupable _                          = False
 

@@ -238,9 +256,10 @@ contArgs cont@(ApplyTo {})
 
 contArgs cont = (True, [], cont)
 
 
 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
 
 dropArgs :: Int -> SimplCont -> SimplCont
 dropArgs 0 cont = cont

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 379fce1..9e73359 100644 (file)
--- 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
               -> 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)
                (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
 
 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
                 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
   = 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
        ; 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
   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)
 
 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
   | 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 }
         ; 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)
 
 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 }
       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}
 
                                          ; 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)
 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
 
   | 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 })
 
 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
   | 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 $
        ; 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
     } }
                  -- 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
 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 
    ...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.
 
        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
 Note [Shadowing]
 ~~~~~~~~~~~~~~~~
 This part of the simplifier may break the no-shadowing invariant