Make the simplifier slightly stricter.wip/andreask/opt_simpl

This commit reduces allocations by the simplifier by 3% for the
Cabal test at -O2.

We do this by making a few select fields, bindings and arguments strict
which reduces allocations for the simplifier by around 3% in total
for the Cabal test. Which is about 2% fewer allocations in total at
-O2.

-------------------------
Metric Decrease:
    T18698a
    T18698b
    T9233
    T9675
    T9872a
    T9872b
    T9872c
    T9872d
    T10421
    T12425
    T13253
    T5321FD
    T9961
-------------------------

5 files changed, 133 insertions, 49 deletions

diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 13f0fdc46c..9e7f60c1e0 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -165,6 +165,38 @@ It's quite convenient. This way we don't need to manipulate the substitution all
 the time: every update to a binder is automatically reflected to its bound
 occurrences.
 
+Note [Bangs in the Simplifier]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Both SimplFloats and SimplEnv do *not* generally benefit from making
+their fields strict. I don't know if this is because of good use of
+laziness or unintended side effects like closures capturing more variables
+after WW has run.
+
+But the end result is that we keep these lazy, but force them in some places
+where we know it's beneficial to the compiler.
+
+Similarly environments returned from functions aren't *always* beneficial to
+force. In some places they would never be demanded so forcing them early
+increases allocation. In other places they almost always get demanded so
+it's worthwhile to force them early.
+
+Would it be better to through every allocation of e.g. SimplEnv and decide
+wether or not to make this one strict? Absolutely! Would be a good use of
+someones time? Absolutely not! I made these strict that showed up during
+a profiled build or which I noticed while looking at core for one reason
+or another.
+
+The result sadly is that we end up with "random" bangs in the simplifier
+where we sometimes force e.g. the returned environment from a function and
+sometimes we don't for the same function. Depending on the context around
+the call. The treatment is also not very consistent. I only added bangs
+where I saw it making a difference either in the core or benchmarks. Some
+patterns where it would be beneficial aren't convered as a consequence as
+I neither have the time to go through all of the core and some cases are
+too small to show up in benchmarks.
+
+
+
 ************************************************************************
 *                                                                      *
 \subsection{Bindings}
@@ -180,7 +212,8 @@ simplTopBinds env0 binds0
                 -- anything into scope, then we don't get a complaint about that.
                 -- It's rather as if the top-level binders were imported.
                 -- See note [Glomming] in "GHC.Core.Opt.OccurAnal".
-        ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)
+        -- See Note [Bangs in the Simplifier]
+        ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)
         ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0
         ; freeTick SimplifierDone
         ; return (floats, env2) }
@@ -193,7 +226,9 @@ simplTopBinds env0 binds0
     simpl_binds env []           = return (emptyFloats env, env)
     simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind
                                       ; (floats, env2) <- simpl_binds env1 binds
-                                      ; return (float `addFloats` floats, env2) }
+                                      -- See Note [Bangs in the Simplifier]
+                                      ; let !floats1 = float `addFloats` floats
+                                      ; return (floats1, env2) }
 
     simpl_bind env (Rec pairs)
       = simplRecBind env TopLevel Nothing pairs
@@ -294,7 +329,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
   = ASSERT( isId bndr )
     ASSERT2( not (isJoinId bndr), ppr bndr )
     -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
-    do  { let   rhs_env     = rhs_se `setInScopeFromE` env
+    do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]
                 (tvs, body) = case collectTyAndValBinders rhs of
                                 (tvs, [], body)
                                   | surely_not_lam body -> (tvs, body)
@@ -940,7 +975,7 @@ might do the same again.
 -}
 
 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-simplExpr env (Type ty)
+simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier]
   = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]
        ; return (Type ty') }
 
@@ -971,7 +1006,7 @@ simplExprF :: SimplEnv
            -> SimplCont
            -> SimplM (SimplFloats, OutExpr)
 
-simplExprF env e cont
+simplExprF !env e !cont -- See Note [Bangs in the Simplifier]
   = {- pprTrace "simplExprF" (vcat
       [ ppr e
       , text "cont =" <+> ppr cont
@@ -1868,24 +1903,33 @@ outside.  Surprisingly tricky!
 simplVar :: SimplEnv -> InVar -> SimplM OutExpr
 -- Look up an InVar in the environment
 simplVar env var
-  | isTyVar var = return (Type (substTyVar env var))
-  | isCoVar var = return (Coercion (substCoVar env var))
+  -- Why $! ? See Note [Bangs in the Simplifier]
+  | isTyVar var = return $! Type $! (substTyVar env var)
+  | isCoVar var = return $! Coercion $! (substCoVar env var)
   | otherwise
   = case substId env var of
-        ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
+        ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids
+                                in simplExpr env' e
         DoneId var1          -> return (Var var1)
         DoneEx e _           -> return e
 
 simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
 simplIdF env var cont
   = case substId env var of
-      ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
-                                -- Don't trim; haven't already simplified e,
-                                -- so the cont is not embodied in e
-
-      DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont)
-
-      DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont)
+      ContEx tvs cvs ids e ->
+          let env' = setSubstEnv env tvs cvs ids
+          in simplExprF env' e cont
+          -- Don't trim; haven't already simplified e,
+          -- so the cont is not embodied in e
+
+      DoneId var1 ->
+          let cont' = trimJoinCont var (isJoinId_maybe var1) cont
+          in completeCall env var1 cont'
+
+      DoneEx e mb_join ->
+          let env' = zapSubstEnv env
+              cont' = trimJoinCont var mb_join cont
+          in simplExprF env' e cont'
               -- Note [zapSubstEnv]
               -- The template is already simplified, so don't re-substitute.
               -- This is VITAL.  Consider
@@ -1906,12 +1950,14 @@ completeCall env var cont
   -- Inline the variable's RHS
   = do { checkedTick (UnfoldingDone var)
        ; dump_inline expr cont
-       ; simplExprF (zapSubstEnv env) expr cont }
+       ; let env1 = zapSubstEnv env
+       ; simplExprF env1 expr cont }
 
   | otherwise
   -- Don't inline; instead rebuild the call
   = do { rule_base <- getSimplRules
-       ; let info = mkArgInfo env var (getRules rule_base var)
+       ; let rules = getRules rule_base var
+             info = mkArgInfo env var rules
                               n_val_args call_cont
        ; rebuildCall env info cont }
 
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index 1bfa38e481..d1b33b0290 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -90,7 +90,7 @@ data SimplEnv
      -- Static in the sense of lexically scoped,
      -- wrt the original expression
 
-        seMode      :: SimplMode
+        seMode      :: !SimplMode
 
         -- The current substitution
       , seTvSubst   :: TvSubstEnv      -- InTyVar |--> OutType
@@ -103,7 +103,7 @@ data SimplEnv
 
         -- The current set of in-scope variables
         -- They are all OutVars, and all bound in this module
-      , seInScope   :: InScopeSet       -- OutVars only
+      , seInScope   :: !InScopeSet       -- OutVars only
 
       , seCaseDepth :: !Int  -- Depth of multi-branch case alternatives
     }
@@ -325,7 +325,10 @@ setMode :: SimplMode -> SimplEnv -> SimplEnv
 setMode mode env = env { seMode = mode }
 
 updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
-updMode upd env = env { seMode = upd (seMode env) }
+updMode upd env
+  = -- Avoid keeping env alive in case inlining fails.
+    let mode = upd $! (seMode env)
+    in env { seMode = mode }
 
 bumpCaseDepth :: SimplEnv -> SimplEnv
 bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 }
@@ -363,8 +366,12 @@ setInScopeFromF env floats = env { seInScope = sfInScope floats }
 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
         -- The new Ids are guaranteed to be freshly allocated
 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
-  = env { seInScope = in_scope `extendInScopeSetList` vs,
-          seIdSubst = id_subst `delVarEnvList` vs }
+-- See Note [Bangs in the Simplifier]
+  = let !in_scope1 = in_scope `extendInScopeSetList` vs
+        !id_subst1 = id_subst `delVarEnvList` vs
+    in
+    env { seInScope = in_scope1,
+          seIdSubst = id_subst1 }
         -- Why delete?  Consider
         --      let x = a*b in (x, \x -> x+3)
         -- We add [x |-> a*b] to the substitution, but we must
@@ -544,8 +551,8 @@ mkFloatBind env bind
       = SimplFloats { sfLetFloats  = unitLetFloat bind
                     , sfJoinFloats = emptyJoinFloats
                     , sfInScope    = in_scope' }
-
-    in_scope' = seInScope env `extendInScopeSetBind` bind
+    -- See Note [Bangs in the Simplifier]
+    !in_scope' = seInScope env `extendInScopeSetBind` bind
 
 extendFloats :: SimplFloats -> OutBind -> SimplFloats
 -- Add this binding to the floats, and extend the in-scope env too
@@ -616,10 +623,11 @@ mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs _ff
                 , sfJoinFloats = jfloats'
                 , sfInScope    = in_scope }
   where
-    floats'  | isNilOL bs  = emptyLetFloats
-             | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))
-    jfloats' | isNilOL jbs = emptyJoinFloats
-             | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
+    -- See Note [Bangs in the Simplifier]
+    !floats'  | isNilOL bs  = emptyLetFloats
+              | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))
+    !jfloats' | isNilOL jbs = emptyJoinFloats
+              | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
 
 wrapFloats :: SimplFloats -> OutExpr -> OutExpr
 -- Wrap the floats around the expression; they should all
@@ -649,12 +657,14 @@ getTopFloatBinds (SimplFloats { sfLetFloats  = lbs
   = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings
     letFloatBinds lbs
 
+{-# INLINE mapLetFloats #-}
 mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats
 mapLetFloats (LetFloats fs ff) fun
-   = LetFloats (mapOL app fs) ff
+   = LetFloats fs1 ff
    where
     app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
-    app (Rec bs)     = Rec (map fun bs)
+    app (Rec bs)     = Rec (strictMap fun bs)
+    !fs1 = (mapOL' app fs) -- See Note [Bangs in the Simplifier]
 
 {-
 ************************************************************************
@@ -748,7 +758,7 @@ See also Note [Scaling join point arguments].
 -}
 
 simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
-simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs
+simplBinders  !env bndrs = mapAccumLM simplBinder  env bndrs
 
 -------------
 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
@@ -757,7 +767,7 @@ simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
 -- The substitution is extended only if the variable is cloned, because
 -- we *don't* need to use it to track occurrence info.
-simplBinder env bndr
+simplBinder !env bndr
   | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr
                         ; seqTyVar tv `seq` return (env', tv) }
   | otherwise     = do  { let (env', id) = substIdBndr env bndr
@@ -766,16 +776,18 @@ simplBinder env bndr
 ---------------
 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 -- A non-recursive let binder
-simplNonRecBndr env id
-  = do  { let (env1, id1) = substIdBndr env id
+simplNonRecBndr !env id
+  -- See Note [Bangs in the Simplifier]
+  = do  { let (!env1, id1) = substIdBndr env id
         ; seqId id1 `seq` return (env1, id1) }
 
 ---------------
 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
 -- Recursive let binders
 simplRecBndrs env@(SimplEnv {}) ids
+  -- See Note [Bangs in the Simplifier]
   = ASSERT(all (not . isJoinId) ids)
-    do  { let (env1, ids1) = mapAccumL substIdBndr env ids
+    do  { let (!env1, ids1) = mapAccumL substIdBndr env ids
         ; seqIds ids1 `seq` return env1 }
 
 
@@ -810,6 +822,10 @@ substNonCoVarIdBndr
 --      all fragile info is zapped
 substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x)
 
+-- Inline to make the (OutId -> OutId) function a known call.
+-- This is especially important for `substNonCoVarIdBndr` which
+-- passes an identity lambda.
+{-# INLINE subst_id_bndr #-}
 subst_id_bndr :: SimplEnv
               -> InBndr    -- Env and binder to transform
               -> (OutId -> OutId)  -- Adjust the type
@@ -817,7 +833,7 @@ subst_id_bndr :: SimplEnv
 subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
               old_id adjust_type
   = ASSERT2( not (isCoVar old_id), ppr old_id )
-    (env { seInScope = in_scope `extendInScopeSet` new_id,
+    (env { seInScope = new_in_scope,
            seIdSubst = new_subst }, new_id)
     -- It's important that both seInScope and seIdSubst are updated with
     -- the new_id, /after/ applying adjust_type. That's why adjust_type
@@ -825,20 +841,23 @@ subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
     -- place that gives a non-identity adjust_type) we'd have to fiddle
     -- afresh with both seInScope and seIdSubst
   where
-    id1  = uniqAway in_scope old_id
-    id2  = substIdType env id1
-    id3  = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding
+    -- See Note [Bangs in the Simplifier]
+    !id1  = uniqAway in_scope old_id
+    !id2  = substIdType env id1
+    !id3  = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding
                                       -- and fragile OccInfo
-    new_id = adjust_type id3
+    !new_id = adjust_type id3
 
         -- Extend the substitution if the unique has changed,
         -- or there's some useful occurrence information
         -- See the notes with substTyVarBndr for the delSubstEnv
-    new_subst | new_id /= old_id
+    !new_subst | new_id /= old_id
               = extendVarEnv id_subst old_id (DoneId new_id)
               | otherwise
               = delVarEnv id_subst old_id
 
+    !new_in_scope = in_scope `extendInScopeSet` new_id
+
 ------------------------------------
 seqTyVar :: TyVar -> ()
 seqTyVar b = b `seq` ()
@@ -947,7 +966,7 @@ adjustJoinPointType mult new_res_ty join_id
     orig_ar = idJoinArity join_id
     orig_ty = idType join_id
 
-    new_join_ty = go orig_ar orig_ty
+    new_join_ty = go orig_ar orig_ty :: Type
 
     go 0 _  = new_res_ty
     go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty
@@ -956,7 +975,8 @@ adjustJoinPointType mult new_res_ty join_id
             | otherwise
             = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty)
 
-    scale_bndr (Anon af t) = Anon af (scaleScaled mult t)
+    -- See Note [Bangs in the Simplifier]
+    scale_bndr (Anon af t) = Anon af $! (scaleScaled mult t)
     scale_bndr b@(Named _) = b
 
 {- Note [Scaling join point arguments]
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 2e27466c55..24eb3a0512 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -1254,15 +1254,15 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
   | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]
                                                        -- in module Exitify
   | not (one_occ (idOccInfo bndr))           = Nothing
-  | not (isStableUnfolding unf)              = Just (extend_subst_with rhs)
+  | not (isStableUnfolding unf)              = Just $! (extend_subst_with rhs)
 
   -- Note [Stable unfoldings and preInlineUnconditionally]
   | not (isInlinePragma inline_prag)
-  , Just inl <- maybeUnfoldingTemplate unf   = Just (extend_subst_with inl)
+  , Just inl <- maybeUnfoldingTemplate unf   = Just $! (extend_subst_with inl)
   | otherwise                                = Nothing
   where
     unf = idUnfolding bndr
-    extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)
+    extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
 
     one_occ IAmDead = True -- Happens in ((\x.1) v)
     one_occ OneOcc{ occ_n_br   = 1
@@ -1941,7 +1941,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body
     abstract subst (NonRec id rhs)
       = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
            ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
-                 subst' = GHC.Core.Subst.extendIdSubst subst id poly_app
+                 !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app
            ; return (subst', NonRec poly_id2 poly_rhs) }
       where
         rhs' = GHC.Core.Subst.substExpr subst rhs
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index 493b2d767a..636dc87405 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -1928,13 +1928,16 @@ GHC.Core.Multiplicity above this module.
 -}
 
 -- | A shorthand for data with an attached 'Mult' element (the multiplicity).
-data Scaled a = Scaled Mult a
+data Scaled a = Scaled !Mult a
   deriving (Data.Data)
   -- You might think that this would be a natural candidate for
   -- Functor, Traversable but Krzysztof says (!3674) "it was too easy
   -- to accidentally lift functions (substitutions, zonking etc.) from
   -- Type -> Type to Scaled Type -> Scaled Type, ignoring
   -- multiplicities and causing bugs".  So we don't.
+  --
+  -- Being strict in a is worse for performance, so we are only strict on the
+  -- Mult part of scaled.
 
 
 instance (Outputable a) => Outputable (Scaled a) where
diff --git a/compiler/GHC/Data/OrdList.hs b/compiler/GHC/Data/OrdList.hs
index 510e6f0f15..c3f659cb02 100644
--- a/compiler/GHC/Data/OrdList.hs
+++ b/compiler/GHC/Data/OrdList.hs
@@ -17,13 +17,14 @@ module GHC.Data.OrdList (
         OrdList, pattern NilOL, pattern ConsOL, pattern SnocOL,
         nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,
         headOL,
-        mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,
+        mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,
         strictlyEqOL, strictlyOrdOL
 ) where
 
 import GHC.Prelude
 import Data.Foldable
 
+import GHC.Utils.Misc (strictMap)
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 
@@ -179,6 +180,20 @@ fromOLReverse a = go a []
 mapOL :: (a -> b) -> OrdList a -> OrdList b
 mapOL = fmap
 
+mapOL' :: (a->b) -> OrdList a -> OrdList b
+mapOL' _ None        = None
+mapOL' f (One x)     = One $! f x
+mapOL' f (Cons x xs) = let !x1 = f x
+                           !xs1 = mapOL' f xs
+                       in Cons x1 xs1
+mapOL' f (Snoc xs x) = let !x1 = f x
+                           !xs1 = mapOL' f xs
+                       in Snoc xs1 x1
+mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1
+                           !b2' = mapOL' f b2
+                       in Two b1' b2'
+mapOL' f (Many xs)   = Many $! strictMap f xs
+
 foldrOL :: (a->b->b) -> b -> OrdList a -> b
 foldrOL _ z None        = z
 foldrOL k z (One x)     = k x z