Replace mapAccumLM with mapAccumLM', a strict version.wip/andreask/strict_mapAccumLM

Overall performance doesn't seem to shift much. But given that nothing
changed I prefer the strict version as it avoids future space leaks.

19 files changed, 41 insertions, 45 deletions

diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
index 9f66793a03..063c82d7a6 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
@@ -203,9 +203,9 @@ regSpill_instr platform regSlotMap (LiveInstr instr (Just _)) = do
   let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify
 
   -- rewrite the instr and work out spill code.
-  (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead
-  (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten
-  (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
+  (instr1, prepost1)      <- mapAccumLM' (spillRead   regSlotMap) instr  rsSpillRead
+  (instr2, prepost2)      <- mapAccumLM' (spillWrite  regSlotMap) instr1 rsSpillWritten
+  (instr3, prepost3)      <- mapAccumLM' (spillModify regSlotMap) instr2 rsSpillModify
 
   let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3)
   let prefixes                = concat mPrefixes
diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
index ad8190270f..c61246f378 100644
--- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
@@ -446,7 +446,7 @@ slurpReloadCoalesce live
                                         then getSlotMap blockId
                                         else return emptyUFM
 
-                (_, mMoves)     <- mapAccumLM slurpLI slotMap instrs
+                (_, mMoves)     <- mapAccumLM' slurpLI slotMap instrs
                 return $ listToBag $ catMaybes mMoves
 
         slurpLI :: SlotMap Reg                           -- current slotMap
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
index eab4d0ef4e..314ad7e82e 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/compiler/GHC/Core/Opt/SetLevels.hs
@@ -120,7 +120,7 @@ import GHC.Builtin.Names      ( runRWKey )
 import GHC.Data.FastString
 
 import GHC.Utils.FV
-import GHC.Utils.Monad  ( mapAccumLM )
+import GHC.Utils.Monad  ( mapAccumLM' )
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
@@ -440,7 +440,7 @@ lvlApp env orig_expr ((_,AnnVar fn), args)
         ; return (foldl' App lapp' rargs') }
 
   | otherwise
-  = do { (_, args') <- mapAccumLM lvl_arg stricts args
+  = do { (_, args') <- mapAccumLM' lvl_arg stricts args
             -- Take account of argument strictness; see
             -- Note [Floating to the top]
        ; return (foldl' App (lookupVar env fn) args') }
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index f77411e0b1..551817083a 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -69,7 +69,7 @@ import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import GHC.Utils.Constants (debugIsOn)
 import GHC.Utils.Trace
-import GHC.Utils.Monad  ( mapAccumLM, liftIO )
+import GHC.Utils.Monad  ( mapAccumLM', liftIO )
 import GHC.Utils.Logger
 
 import Control.Monad
@@ -256,7 +256,7 @@ simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont
              -> [(InId, InExpr)]
              -> SimplM (SimplFloats, SimplEnv)
 simplRecBind env0 top_lvl mb_cont pairs0
-  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0
+  = do  { (env_with_info, triples) <- mapAccumLM' add_rules env0 pairs0
         ; (rec_floats, env1) <- go env_with_info triples
         ; return (mkRecFloats rec_floats, env1) }
   where
@@ -1650,7 +1650,7 @@ simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 simplLamBndr env bndr = simplBinder env bndr
 
 simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
-simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
+simplLamBndrs env bndrs = mapAccumLM' simplLamBndr env bndrs
 
 ------------------
 simplNonRecE :: SimplEnv
@@ -3547,7 +3547,7 @@ mkDupableContWithDmds env _
         -- NB: we don't use alt_env further; it has the substEnv for
         --     the alternatives, and we don't want that
 
-        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr')
+        ; (join_floats, alts'') <- mapAccumLM' (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr')
                                               emptyJoinFloats alts'
 
         ; let all_floats = floats `addJoinFloats` join_floats
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index 54a5f171ec..5abfe895a0 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -760,7 +760,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)
diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs
index 8ee49f4968..2f093ff223 100644
--- a/compiler/GHC/Core/Opt/Simplify/Monad.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs
@@ -170,7 +170,7 @@ thenSmpl_ m k
 -- TODO: this specializing is not allowed
 -- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
 -- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
--- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
+-- {-# SPECIALIZE mapAccumLM'   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
 
 traceSmpl :: String -> SDoc -> SimplM ()
 traceSmpl herald doc
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index ec26ba89fb..a673ba2ce0 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -1991,7 +1991,7 @@ abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
 abstractFloats uf_opts top_lvl main_tvs floats body
   = assert (notNull body_floats) $
     assert (isNilOL (sfJoinFloats floats)) $
-    do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
+    do  { (subst, float_binds) <- mapAccumLM' abstract empty_subst body_floats
         ; return (float_binds, GHC.Core.Subst.substExpr subst body) }
   where
     is_top_lvl  = isTopLevel top_lvl
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 79be8e6e11..a9b1dd15c8 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -327,7 +327,7 @@ coreTopBindToStg dflags this_mod env ccs (Rec pairs)
         -- generate StgTopBindings and CAF cost centres created for CAFs
         (ccs', stg_rhss)
           = initCts dflags env' $
-              mapAccumLM (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs)
+              mapAccumLM' (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs)
                          ccs
                          pairs
         bind = StgTopLifted $ StgRec (zip binders stg_rhss)
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index b8593b47a0..085fb82d58 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -58,7 +58,7 @@ import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import GHC.Utils.Outputable
-import GHC.Utils.Monad  ( mapAccumLM )
+import GHC.Utils.Monad  ( mapAccumLM' )
 import GHC.Utils.Logger
 import GHC.Utils.Trace
 
@@ -2107,7 +2107,7 @@ subst_cv_bndr tce cv
 -- ---------------------------------------------------------------------------
 
 cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
-cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
+cpCloneBndrs env bs = mapAccumLM' cpCloneBndr env bs
 
 cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
 cpCloneBndr env bndr
diff --git a/compiler/GHC/Data/Bag.hs b/compiler/GHC/Data/Bag.hs
index 0dcdef55a5..bc4e275927 100644
--- a/compiler/GHC/Data/Bag.hs
+++ b/compiler/GHC/Data/Bag.hs
@@ -293,7 +293,7 @@ mapAccumBagLM f s (UnitBag x)     = do { (s1, x1) <- f s x; return (s1, UnitBag
 mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s  b1
                                        ; (s2, b2') <- mapAccumBagLM f s1 b2
                                        ; return (s2, TwoBags b1' b2') }
-mapAccumBagLM f s (ListBag xs)    = do { (s', xs') <- mapAccumLM f s xs
+mapAccumBagLM f s (ListBag xs)    = do { (s', xs') <- mapAccumLM' f s xs
                                        ; return (s', ListBag xs') }
 
 listToBag :: [a] -> Bag a
diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs
index 04709b38cf..4f58a0a05b 100644
--- a/compiler/GHC/Runtime/Debugger.hs
+++ b/compiler/GHC/Runtime/Debugger.hs
@@ -67,7 +67,7 @@ pprintClosureCommand bindThings force str = do
 
   -- Obtain the terms and the recovered type information
   let ids = [id | AnId id <- pprintables]
-  (subst, terms) <- mapAccumLM go emptyTCvSubst ids
+  (subst, terms) <- mapAccumLM' go emptyTCvSubst ids
 
   -- Apply the substitutions obtained after recovering the types
   modifySession $ \hsc_env ->
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index d46719298e..6fd2496a41 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -252,7 +252,7 @@ import GHC.Types.Id
 import GHC.Types.Literal
 import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID)
 import GHC.Types.Id.Make (voidPrimId, voidArgId)
-import GHC.Utils.Monad (mapAccumLM)
+import GHC.Utils.Monad (mapAccumLM')
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
@@ -776,7 +776,7 @@ unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
 unariseFunArgs = concatMap . unariseFunArg
 
 unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
-unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
+unariseFunArgBinders rho xs = second concat <$> mapAccumLM' unariseFunArgBinder rho xs
 
 -- Result list of binders is never empty
 unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
@@ -806,7 +806,7 @@ unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
 unariseConArgs = concatMap . unariseConArg
 
 unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
-unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
+unariseConArgBinders rho xs = second concat <$> mapAccumLM' unariseConArgBinder rho xs
 
 -- Different from `unariseFunArgBinder`: result list of binders may be empty.
 -- See DataCon applications case in Note [Post-unarisation invariants].
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index 2055b3101c..61ff252f4c 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -139,7 +139,7 @@ emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet
 accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y)))
              -> [x]
              -> TcRn [y]
-accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum
+accumExports f = fmap (catMaybes . snd) . mapAccumLM' f' emptyExportAccum
   where f' acc x = do
           m <- attemptM (f acc x)
           pure $ case m of
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 189eb989c5..80d810cbe1 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -774,7 +774,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_
         ; let result_inst_tys = mkTyVarTys con1_tvs'
               init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)
 
-        ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst
+        ; (scrut_subst, scrut_inst_tys) <- mapAccumLM' mk_inst_ty init_subst
                                                       (con1_tvs `zip` result_inst_tys)
 
         ; let rec_res_ty    = TcType.substTy result_subst con1_res_ty
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 8091869187..5e822fe1a6 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -425,7 +425,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
            tcCheckPat PatSyn lpat (unrestricted skol_pat_ty)   $
            do { let in_scope    = mkInScopeSet (mkVarSet skol_univ_tvs)
                     empty_subst = mkEmptyTCvSubst in_scope
-              ; (inst_subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst skol_ex_tvs
+              ; (inst_subst, ex_tvs') <- mapAccumLM' newMetaTyVarX empty_subst skol_ex_tvs
                     -- newMetaTyVarX: see the "Existential type variables"
                     -- part of Note [Checking against a pattern signature]
               ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 78c7ad4c12..767696db3a 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -223,7 +223,7 @@ instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType
 -- instantiates the the type variables tvs, emits the (instantiated)
 -- constraints theta, and returns the (instantiated) type ty
 instantiateSigma orig tvs theta body_ty
-  = do { (subst, inst_tvs) <- mapAccumLM newMetaTyVarX empty_subst tvs
+  = do { (subst, inst_tvs) <- mapAccumLM' newMetaTyVarX empty_subst tvs
        ; let inst_theta  = substTheta subst theta
              inst_body   = substTy subst body_ty
              inst_tv_tys = mkTyVarTys inst_tvs
@@ -484,7 +484,7 @@ tcInstTypeBndrs id
                   --      (?x :: Int) => Int -> Int
   = return ([], theta, tau)
   | otherwise
-  = do { (subst, tyvars') <- mapAccumLM inst_invis_bndr emptyTCvSubst tyvars
+  = do { (subst, tyvars') <- mapAccumLM' inst_invis_bndr emptyTCvSubst tyvars
        ; let tv_prs  = map (tyVarName . binderVar) tyvars `zip` tyvars'
              subst'  = extendTCvInScopeSet subst (tyCoVarsOfType rho)
        ; return (tv_prs, substTheta subst' theta, substTy subst' tau) }
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 8c59e30d95..d986c81cd7 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -1144,7 +1144,7 @@ newMetaTyVars = newMetaTyVarsX emptyTCvSubst
 
 newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
 -- Just like newMetaTyVars, but start with an existing substitution.
-newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst
+newMetaTyVarsX subst = mapAccumLM' newMetaTyVarX subst
 
 newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
 -- Make a new unification variable tyvar whose Name and Kind come from
@@ -2665,7 +2665,7 @@ zonkTidyOrigin env (CycleBreakerOrigin orig)
   = do { (env1, orig') <- zonkTidyOrigin env orig
        ; return (env1, CycleBreakerOrigin orig') }
 zonkTidyOrigin env (InstProvidedOrigin mod cls_inst)
-  = do { (env1, is_tys') <- mapAccumLM zonkTidyTcType env (is_tys cls_inst)
+  = do { (env1, is_tys') <- mapAccumLM' zonkTidyTcType env (is_tys cls_inst)
        ; return (env1, InstProvidedOrigin mod (cls_inst {is_tys = is_tys'})) }
 zonkTidyOrigin env (FixedRuntimeRepOrigin ty frr_orig)
   = do { (env1, ty') <- zonkTidyTcType env ty
@@ -2677,7 +2677,7 @@ zonkTidyOrigin env (WantedSuperclassOrigin pty orig)
 zonkTidyOrigin env orig = return (env, orig)
 
 zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> TcM (TidyEnv, [CtOrigin])
-zonkTidyOrigins = mapAccumLM zonkTidyOrigin
+zonkTidyOrigins = mapAccumLM' zonkTidyOrigin
 
 ----------------
 tidyCt :: TidyEnv -> Ct -> Ct
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index ba6c98905f..218f6b569d 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -398,7 +398,7 @@ zonkFieldOcc env (FieldOcc sel lbl)
   = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
 
 zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
-zonkEvBndrsX = mapAccumLM zonkEvBndrX
+zonkEvBndrsX = mapAccumLM' zonkEvBndrX
 
 zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
 -- Works for dictionaries and coercions
@@ -428,13 +428,13 @@ zonkCoreBndrX env v
   | otherwise = zonkTyBndrX env v
 
 zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
-zonkCoreBndrsX = mapAccumLM zonkCoreBndrX
+zonkCoreBndrsX = mapAccumLM' zonkCoreBndrX
 
 zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])
 zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs
 
 zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
-zonkTyBndrsX = mapAccumLM zonkTyBndrX
+zonkTyBndrsX = mapAccumLM' zonkTyBndrX
 
 zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
 -- This guarantees to return a TyVar (not a TcTyVar)
@@ -452,7 +452,7 @@ zonkTyBndrX env tv
 
 zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
                              -> TcM (ZonkEnv, [VarBndr TyVar vis])
-zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
+zonkTyVarBindersX = mapAccumLM' zonkTyVarBinderX
 
 zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis
                             -> TcM (ZonkEnv, VarBndr TyVar vis)
@@ -970,7 +970,7 @@ zonkSyntaxExpr env (SyntaxExprTc { syn_expr      = expr
                                , syn_res_wrap  = res_wrap })
   = do { (env0, res_wrap')  <- zonkCoFn env res_wrap
        ; expr'              <- zonkExpr env0 expr
-       ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
+       ; (env1, arg_wraps') <- mapAccumLM' zonkCoFn env0 arg_wraps
        ; return (env1, SyntaxExprTc { syn_expr      = expr'
                                     , syn_arg_wraps = arg_wraps'
                                     , syn_res_wrap  = res_wrap' }) }
@@ -1505,7 +1505,7 @@ zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc)
 zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
                           , rd_lhs = lhs
                           , rd_rhs = rhs })
-  = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs
+  = do { (env_inside, new_tm_bndrs) <- mapAccumLM' zonk_tm_bndr env tm_bndrs
 
        ; let env_lhs = setZonkType env_inside SkolemiseFlexi
               -- See Note [Zonking the LHS of a RULE]
@@ -1630,7 +1630,7 @@ zonkEvTypeable env (EvTypeableTyLit t1)
        ; return (EvTypeableTyLit t1') }
 
 zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
-zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
+zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM' zonk_tc_ev_binds env bs
                             ; return (env, [EvBinds (unionManyBags bs')]) }
 
 zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
diff --git a/compiler/GHC/Utils/Monad.hs b/compiler/GHC/Utils/Monad.hs
index 59964b8024..ef254fce63 100644
--- a/compiler/GHC/Utils/Monad.hs
+++ b/compiler/GHC/Utils/Monad.hs
@@ -10,7 +10,7 @@ module GHC.Utils.Monad
 
         , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM
         , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M
-        , mapAccumLM
+        , mapAccumLM'
         , liftFstM, liftSndM
         , mapSndM
         , concatMapM
@@ -137,21 +137,17 @@ mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f
 -- See Note [Inline @mapAndUnzipNM@ functions] above.
 mapAndUnzip5M f xs =  unzip5 <$> traverse f xs
 
--- TODO: mapAccumLM is used in many places. Surely most of
--- these don't actually want to be lazy. We should add a strict
--- variant and use it where appropriate.
-
--- | Monadic version of mapAccumL
-mapAccumLM :: Monad m
+-- | Monadic version of mapAccumL, but strict both in state and elements.
+mapAccumLM' :: Monad m
             => (acc -> x -> m (acc, y)) -- ^ combining function
             -> acc                      -- ^ initial state
             -> [x]                      -- ^ inputs
             -> m (acc, [y])             -- ^ final state, outputs
-mapAccumLM f s xs =
+mapAccumLM' f s xs =
   go s xs
   where
     go s (x:xs) = do
-      (s1, x')  <- f s x
+      (!s1, !x')  <- f s x
       (s2, xs') <- go s1 xs
       return    (s2, x' : xs')
     go s [] = return (s, [])