From 92694e0691df2059220d8d19720b7166cee83715 Mon Sep 17 00:00:00 2001 From: Andreas Klebinger Date: Wed, 13 Jan 2021 03:03:18 +0100 Subject: Replace mapAccumLM with mapAccumLM', a strict version. Overall performance doesn't seem to shift much. But given that nothing changed I prefer the strict version as it avoids future space leaks. --- compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs | 6 +++--- compiler/GHC/CmmToAsm/Reg/Liveness.hs | 2 +- compiler/GHC/Core/Opt/SetLevels.hs | 4 ++-- compiler/GHC/Core/Opt/Simplify.hs | 8 ++++---- compiler/GHC/Core/Opt/Simplify/Env.hs | 2 +- compiler/GHC/Core/Opt/Simplify/Monad.hs | 2 +- compiler/GHC/Core/Opt/Simplify/Utils.hs | 2 +- compiler/GHC/CoreToStg.hs | 2 +- compiler/GHC/CoreToStg/Prep.hs | 4 ++-- compiler/GHC/Data/Bag.hs | 2 +- compiler/GHC/Runtime/Debugger.hs | 2 +- compiler/GHC/Stg/Unarise.hs | 6 +++--- compiler/GHC/Tc/Gen/Export.hs | 2 +- compiler/GHC/Tc/Gen/Expr.hs | 2 +- compiler/GHC/Tc/TyCl/PatSyn.hs | 2 +- compiler/GHC/Tc/Utils/Instantiate.hs | 4 ++-- compiler/GHC/Tc/Utils/TcMType.hs | 6 +++--- compiler/GHC/Tc/Utils/Zonk.hs | 14 +++++++------- compiler/GHC/Utils/Monad.hs | 14 +++++--------- 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, []) -- cgit v1.2.1