Remove code that is dead now that we need >= 6.12 to build

[ghc-hetmet.git] / compiler / simplCore / Simplify.lhs

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 379fce1..7222703 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -24,16 +24,16 @@ import Coercion
 import OptCoercion     ( optCoercion )
 import FamInstEnv       ( topNormaliseType )
 import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )
 import OptCoercion     ( optCoercion )
 import FamInstEnv       ( topNormaliseType )
 import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )

-import CoreMonad       ( SimplifierSwitch(..), Tick(..) )
+import CoreMonad        ( Tick(..), SimplifierMode(..) )

 import CoreSyn
 import CoreSyn

-import Demand           ( isStrictDmd, splitStrictSig )
+import Demand           ( isStrictDmd )

 import PprCore          ( pprParendExpr, pprCoreExpr )
 import CoreUnfold       ( mkUnfolding, mkCoreUnfolding
                         , mkInlineUnfolding, mkSimpleUnfolding
                         , exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
 import CoreUtils
 import qualified CoreSubst
 import PprCore          ( pprParendExpr, pprCoreExpr )
 import CoreUnfold       ( mkUnfolding, mkCoreUnfolding
                         , mkInlineUnfolding, mkSimpleUnfolding
                         , exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
 import CoreUtils
 import qualified CoreSubst

-import CoreArity       ( exprArity )
+import CoreArity

 import Rules            ( lookupRule, getRules )
 import BasicTypes       ( isMarkedStrict, Arity )
 import CostCentre       ( currentCCS, pushCCisNop )
 import Rules            ( lookupRule, getRules )
 import BasicTypes       ( isMarkedStrict, Arity )
 import CostCentre       ( currentCCS, pushCCisNop )

@@ -237,7 +237,7 @@ simplTopBinds env0 binds0
     trace_bind False _    = \x -> x
 
     simpl_bind env (Rec pairs)  = simplRecBind      env  TopLevel pairs
     trace_bind False _    = \x -> x
 
     simpl_bind env (Rec pairs)  = simplRecBind      env  TopLevel pairs

-    simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel b b' r
+    simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r

         where
           (env', b') = addBndrRules env b (lookupRecBndr env b)
 \end{code}
         where
           (env', b') = addBndrRules env b (lookupRecBndr env b)
 \end{code}

@@ -272,7 +272,7 @@ simplRecBind env0 top_lvl pairs0
     go env [] = return env
 
     go env ((old_bndr, new_bndr, rhs) : pairs)
     go env [] = return env
 
     go env ((old_bndr, new_bndr, rhs) : pairs)

-        = do { env' <- simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
+        = do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs

              ; go env' pairs }
 \end{code}
 
              ; go env' pairs }
 \end{code}
 

@@ -284,18 +284,17 @@ It assumes the binder has already been simplified, but not its IdInfo.
 
 \begin{code}
 simplRecOrTopPair :: SimplEnv
 
 \begin{code}
 simplRecOrTopPair :: SimplEnv

-                  -> TopLevelFlag
+                  -> TopLevelFlag -> RecFlag

                   -> InId -> OutBndr -> InExpr  -- Binder and rhs
                   -> SimplM SimplEnv    -- Returns an env that includes the binding
 
                   -> InId -> OutBndr -> InExpr  -- Binder and rhs
                   -> SimplM SimplEnv    -- Returns an env that includes the binding
 

-simplRecOrTopPair env top_lvl old_bndr new_bndr rhs
+simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs

   | preInlineUnconditionally env top_lvl old_bndr rhs   -- Check for unconditional inline
   = do  { tick (PreInlineUnconditionally old_bndr)
         ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
 
   | otherwise
   | preInlineUnconditionally env top_lvl old_bndr rhs   -- Check for unconditional inline
   = do  { tick (PreInlineUnconditionally old_bndr)
         ; return (extendIdSubst env old_bndr (mkContEx env rhs)) }
 
   | otherwise

-  = simplLazyBind env top_lvl Recursive old_bndr new_bndr rhs env
-        -- May not actually be recursive, but it doesn't matter
+  = simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env

 \end{code}
 
 
 \end{code}
 
 

@@ -322,7 +321,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 +387,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 +547,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

@@ -628,21 +628,41 @@ completeBind :: SimplEnv
 --      * or by adding to the floats in the envt
 
 completeBind env top_lvl old_bndr new_bndr new_rhs
 --      * or by adding to the floats in the envt
 
 completeBind env top_lvl old_bndr new_bndr new_rhs

-  = do { let old_info = idInfo old_bndr
-             old_unf  = unfoldingInfo old_info
-             occ_info = occInfo old_info
+ = ASSERT( isId new_bndr )
+   do { let old_info = idInfo old_bndr
+           old_unf  = unfoldingInfo old_info
+           occ_info = occInfo old_info

 
 

-       ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf
+       -- Do eta-expansion on the RHS of the binding
+        -- See Note [Eta-expanding at let bindings] in SimplUtils
+      ; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs

 
 

-       ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding
+       -- Simplify the unfolding
+      ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info final_rhs old_unf
+
+      ; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding

                        -- Inline and discard the binding
                        -- Inline and discard the binding

-         then do  { tick (PostInlineUnconditionally old_bndr)
-                  ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $
-                     return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
+       then do  { tick (PostInlineUnconditionally old_bndr)
+                ; -- pprTrace "postInlineUnconditionally" 
+                   --         (ppr old_bndr <+> equals <+> ppr final_rhs $$ ppr occ_info) $
+                   return (extendIdSubst env old_bndr (DoneEx final_rhs)) }

                -- Use the substitution to make quite, quite sure that the
                -- substitution will happen, since we are going to discard the binding
                -- Use the substitution to make quite, quite sure that the
                -- substitution will happen, since we are going to discard the binding

+       else
+   do { let info1 = idInfo new_bndr `setArityInfo` new_arity
+       
+              -- Unfolding info: Note [Setting the new unfolding]
+           info2 = info1 `setUnfoldingInfo` new_unfolding
+
+             -- Demand info: Note [Setting the demand info]
+            info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
+                  | otherwise                      = info2

 
 

-         else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) }
+            final_id = new_bndr `setIdInfo` info3
+
+      ; -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
+        return (addNonRec env final_id final_rhs) } }
+               -- The addNonRec adds it to the in-scope set too

 
 ------------------------------
 addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
 
 ------------------------------
 addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv

@@ -661,44 +681,17 @@ addPolyBind top_lvl env (NonRec poly_id rhs)
   = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding
                        -- Assumes that poly_id did not have an INLINE prag
                        -- which is perhaps wrong.  ToDo: think about this
   = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding
                        -- Assumes that poly_id did not have an INLINE prag
                        -- which is perhaps wrong.  ToDo: think about this

-        ; return (addNonRecWithUnf env poly_id rhs unfolding) }
+        ; let final_id = setIdInfo poly_id $
+                         idInfo poly_id `setUnfoldingInfo` unfolding
+                                        `setArityInfo`     exprArity rhs

 
 

-addPolyBind _ env bind@(Rec _) = return (extendFloats env bind)
-               -- Hack: letrecs are more awkward, so we extend "by steam"
-               -- without adding unfoldings etc.  At worst this leads to
-               -- more simplifier iterations
+        ; return (addNonRec env final_id rhs) }

 
 

-------------------------------
-addNonRecWithUnf :: SimplEnv
-                -> OutId -> OutExpr    -- New binder and RHS
-                -> Unfolding           -- New unfolding
-                -> SimplEnv
-addNonRecWithUnf env new_bndr new_rhs new_unfolding
-  = let new_arity = exprArity new_rhs
-       old_arity = idArity new_bndr
-        info1 = idInfo new_bndr `setArityInfo` new_arity
-       
-              -- Unfolding info: Note [Setting the new unfolding]
-       info2 = info1 `setUnfoldingInfo` new_unfolding
-
-        -- Demand info: Note [Setting the demand info]
-        info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
-              | otherwise                      = info2
-
-        final_id = new_bndr `setIdInfo` info3
-       dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr
-    in
-    ASSERT( isId new_bndr )
-    WARN( new_arity < old_arity || new_arity < dmd_arity, 
-          (ptext (sLit "Arity decrease:") <+> (ppr final_id <+> ppr old_arity
-               <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs) )
-       -- Note [Arity decrease]
-
-    final_id `seq`   -- This seq forces the Id, and hence its IdInfo,
-                    -- and hence any inner substitutions
-           -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
-    addNonRec env final_id new_rhs
-               -- The addNonRec adds it to the in-scope set too
+addPolyBind _ env bind@(Rec _) 
+  = return (extendFloats env bind)
+       -- Hack: letrecs are more awkward, so we extend "by steam"
+       -- without adding unfoldings etc.  At worst this leads to
+       -- more simplifier iterations

 
 ------------------------------
 simplUnfolding :: SimplEnv-> TopLevelFlag
 
 ------------------------------
 simplUnfolding :: SimplEnv-> TopLevelFlag

@@ -709,7 +702,7 @@ simplUnfolding :: SimplEnv-> TopLevelFlag
 simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
   = return (DFunUnfolding ar con ops')
   where
 simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
   = return (DFunUnfolding ar con ops')
   where

-    ops' = map (substExpr (text "simplUnfolding") env) ops
+    ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops

 
 simplUnfolding env top_lvl id _ _ 
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
 
 simplUnfolding env top_lvl id _ _ 
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity

@@ -717,15 +710,30 @@ simplUnfolding env top_lvl id _ _
   | isStableSource src
   = do { expr' <- simplExpr rule_env expr
        ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) 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
                -- See Note [Top-level flag on inline rules] in CoreUnfold

+       }

   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 _
 
 simplUnfolding _ top_lvl id _occ_info new_rhs _

-  = return (mkUnfolding InlineRhs (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
   -- 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

@@ -866,22 +874,26 @@ simplExprF' env (App fun arg)  cont = simplExprF env fun $
                                       ApplyTo NoDup arg env cont
 
 simplExprF' env expr@(Lam _ _) cont
                                       ApplyTo NoDup arg env cont
 
 simplExprF' env expr@(Lam _ _) cont

-  = simplLam env (map zap bndrs) body cont
+  = simplLam env zapped_bndrs body cont

         -- The main issue here is under-saturated lambdas
         --   (\x1. \x2. e) arg1
         -- Here x1 might have "occurs-once" occ-info, because occ-info
         -- is computed assuming that a group of lambdas is applied
         -- all at once.  If there are too few args, we must zap the
         -- The main issue here is under-saturated lambdas
         --   (\x1. \x2. e) arg1
         -- Here x1 might have "occurs-once" occ-info, because occ-info
         -- is computed assuming that a group of lambdas is applied
         -- all at once.  If there are too few args, we must zap the

-        -- occ-info.
+        -- occ-info, UNLESS the remaining binders are one-shot

   where
   where

-    n_args   = countArgs cont
-    n_params = length bndrs

     (bndrs, body) = collectBinders expr
     (bndrs, body) = collectBinders expr

-    zap | n_args >= n_params = \b -> b
-        | otherwise          = \b -> if isTyCoVar b then b
-                                     else zapLamIdInfo b
-        -- NB: we count all the args incl type args
-        -- so we must count all the binders (incl type lambdas)
+    zapped_bndrs | need_to_zap = map zap bndrs
+                 | otherwise   = bndrs
+
+    need_to_zap = any zappable_bndr (drop n_args bndrs)
+    n_args = countArgs cont
+        -- NB: countArgs counts all the args (incl type args)
+        -- and likewise drop counts all binders (incl type lambdas)
+        
+    zappable_bndr b = isId b && not (isOneShotBndr b)
+    zap b | isTyCoVar b = b
+          | otherwise   = zapLamIdInfo b

 
 simplExprF' env (Type ty) cont
   = ASSERT( contIsRhsOrArg cont )
 
 simplExprF' env (Type ty) cont
   = ASSERT( contIsRhsOrArg cont )

@@ -889,17 +901,16 @@ simplExprF' env (Type ty) cont
         ; rebuild env (Type ty') cont }
 
 simplExprF' env (Case scrut bndr _ alts) cont
         ; rebuild env (Type ty') cont }
 
 simplExprF' env (Case scrut bndr _ alts) cont

-  | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
+  | sm_case_case (getMode env)

   =     -- Simplify the scrutinee with a Select continuation
     simplExprF env scrut (Select NoDup bndr alts env cont)
 
   | otherwise
   =     -- If case-of-case is off, simply simplify the case expression
         -- in a vanilla Stop context, and rebuild the result around it
   =     -- Simplify the scrutinee with a Select continuation
     simplExprF env scrut (Select NoDup bndr alts env 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 }
         ; 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)

@@ -942,16 +953,17 @@ simplCoercion env co
 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
 -- At this point the substitution in the SimplEnv should be irrelevant
 -- only the in-scope set and floats should matter
 rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
 -- At this point the substitution in the SimplEnv should be irrelevant
 -- only the in-scope set and floats should matter

-rebuild env expr cont0
-  = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $
-    case cont0 of
+rebuild env expr cont
+  = case cont of

       Stop {}                      -> return (env, expr)
       CoerceIt co cont             -> rebuild env (mkCoerce co expr) cont
       Select _ bndr alts se cont   -> rebuildCase (se `setFloats` env) expr bndr alts 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 }
       Stop {}                      -> return (env, expr)
       CoerceIt co cont             -> rebuild env (mkCoerce co expr) cont
       Select _ bndr alts se cont   -> rebuildCase (se `setFloats` env) expr bndr alts 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 +1101,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 +1250,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 +1282,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 +1293,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 +1301,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

@@ -1329,7 +1354,7 @@ tryRules env rules fn args call_cont
        ; case activeRule dflags env of {
            Nothing     -> return Nothing  ; -- No rules apply
            Just act_fn -> 
        ; case activeRule dflags env of {
            Nothing     -> return Nothing  ; -- No rules apply
            Just act_fn -> 

-         case lookupRule act_fn (activeUnfInRule env) (getInScope env) fn args rules of {
+         case lookupRule act_fn (getUnfoldingInRuleMatch env) (getInScope env) fn args rules of {

            Nothing               -> return Nothing ;   -- No rule matches
            Just (rule, rule_rhs) ->
 
            Nothing               -> return Nothing ;   -- No rule matches
            Just (rule, rule_rhs) ->
 

@@ -1338,14 +1363,15 @@ tryRules env rules fn args call_cont
                   return (Just (ruleArity rule, rule_rhs)) }}}}
   where
     trace_dump dflags rule rule_rhs stuff
                   return (Just (ruleArity rule, rule_rhs)) }}}}
   where
     trace_dump dflags rule rule_rhs stuff

-      | not (dopt Opt_D_dump_rule_firings dflags) = stuff
-      | not (dopt Opt_D_verbose_core2core dflags) 
+      | not (dopt Opt_D_dump_rule_firings dflags)
+      , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff
+      | not (dopt Opt_D_dump_rule_rewrites dflags)

 
       = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff
       | otherwise
       = pprTrace "Rule fired"
            (vcat [text "Rule:" <+> ftext (ru_name rule),
 
       = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff
       | otherwise
       = pprTrace "Rule fired"
            (vcat [text "Rule:" <+> ftext (ru_name rule),

-                 text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
+                 text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),

                  text "After: " <+> pprCoreExpr rule_rhs,
                  text "Cont:  " <+> ppr call_cont])
            stuff
                  text "After: " <+> pprCoreExpr rule_rhs,
                  text "Cont:  " <+> ppr call_cont])
            stuff

@@ -1418,6 +1444,17 @@ Lastly, the code in SimplUtils.mkCase combines identical RHSs.  So
 
 Now again the case may be elminated by the CaseElim transformation.
 
 
 Now again the case may be elminated by the CaseElim transformation.
 

+Note [CaseElimination: lifted case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not use exprOkForSpeculation in the lifted case.  Consider
+   case (case a ># b of { True -> (p,q); False -> (q,p) }) of
+     r -> blah
+The scrutinee is ok-for-speculation (it looks inside cases), but we do
+not want to transform to
+   let r = case a ># b of { True -> (p,q); False -> (q,p) }
+   in blah
+because that builds an unnecessary thunk.
+

 
 Further notes about case elimination
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Further notes about case elimination
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -1482,7 +1519,7 @@ rebuildCase env scrut case_bndr alts cont
            Nothing           -> missingAlt env case_bndr alts cont
            Just (_, bs, rhs) -> simple_rhs bs rhs }
 
            Nothing           -> missingAlt env case_bndr alts cont
            Just (_, bs, rhs) -> simple_rhs bs rhs }
 

-  | Just (con, ty_args, other_args) <- exprIsConApp_maybe (activeUnfInRule env) scrut
+  | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut

         -- Works when the scrutinee is a variable with a known unfolding
         -- as well as when it's an explicit constructor application
   = do  { tick (KnownBranch case_bndr)
         -- Works when the scrutinee is a variable with a known unfolding
         -- as well as when it's an explicit constructor application
   = do  { tick (KnownBranch case_bndr)

@@ -1510,28 +1547,23 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
  | all isDeadBinder bndrs       -- bndrs are [InId]
 
         -- Check that the scrutinee can be let-bound instead of case-bound
  | all isDeadBinder bndrs       -- bndrs are [InId]
 
         -- Check that the scrutinee can be let-bound instead of case-bound

- , exprOkForSpeculation scrut
-                -- OK not to evaluate it
-                -- This includes things like (==# a# b#)::Bool
-                -- so that we simplify
-                --      case ==# a# b# of { True -> x; False -> x }
-                -- to just
-                --      x
-                -- This particular example shows up in default methods for
-                -- comparision operations (e.g. in (>=) for Int.Int32)
-        || exprIsHNF scrut                      -- It's already evaluated
-        || var_demanded_later scrut             -- It'll be demanded later
-
---      || not opt_SimplPedanticBottoms)        -- Or we don't care!
---      We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
---      but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
---      its argument:  case x of { y -> dataToTag# y }
---      Here we must *not* discard the case, because dataToTag# just fetches the tag from
---      the info pointer.  So we'll be pedantic all the time, and see if that gives any
---      other problems
---      Also we don't want to discard 'seq's
+ , if isUnLiftedType (idType case_bndr)
+   then exprOkForSpeculation scrut
+        -- Satisfy the let-binding invariant
+        -- This includes things like (==# a# b#)::Bool
+        -- so that we simplify
+        --      case ==# a# b# of { True -> x; False -> x }
+        -- to just
+        --      x
+        -- This particular example shows up in default methods for
+        -- comparision operations (e.g. in (>=) for Int.Int32)
+
+   else exprIsHNF scrut || var_demanded_later scrut
+        -- It's already evaluated, or will be demanded later
+        -- See Note [Case elimination: lifted case]

   = do  { tick (CaseElim case_bndr)
         ; env' <- simplNonRecX env case_bndr scrut
   = do  { tick (CaseElim case_bndr)
         ; env' <- simplNonRecX env case_bndr scrut

+          -- If case_bndr is deads, simplNonRecX will discard

         ; simplExprF env' rhs cont }
   where
         -- The case binder is going to be evaluated later,
         ; simplExprF env' rhs cont }
   where
         -- The case binder is going to be evaluated later,