Commit 09c1d5af authored by Andreas Klebinger's avatar Andreas Klebinger Committed by Ben Gamari

Replace most occurences of foldl with foldl'.

This patch adds foldl' to GhcPrelude and changes must occurences
of foldl to foldl'. This leads to better performance especially
for quick builds where GHC does not perform strictness analysis.

It does change strictness behaviour when we use foldl' to turn
a argument list into function applications. But this is only a
drawback if code looks ONLY at the last argument but not at the first.
And as the benchmarks show leads to fewer allocations in practice
at O2.

Compiler performance for Nofib:

O2 Allocations:
        -1 s.d.                -----            -0.0%
        +1 s.d.                -----            -0.0%
        Average                -----            -0.0%

O2 Compile Time:
        -1 s.d.                -----            -2.8%
        +1 s.d.                -----            +1.3%
        Average                -----            -0.8%

O0 Allocations:
        -1 s.d.                -----            -0.2%
        +1 s.d.                -----            -0.1%
        Average                -----            -0.2%

Test Plan: ci

Reviewers: goldfire, bgamari, simonmar, tdammers, monoidal

Reviewed By: bgamari, monoidal

Subscribers: tdammers, rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4929
parent 02518f9d
......@@ -249,7 +249,7 @@ filterAvail keep ie rest =
-- will give Ix(Ix,index,range) and Ix(index)
-- We want to combine these; addAvail does that
nubAvails :: [AvailInfo] -> [AvailInfo]
nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails)
nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails)
where
add env avail = extendNameEnv_C plusAvail env (availName avail) avail
......
......@@ -117,4 +117,4 @@ initNameCache us names
nsNames = initOrigNames names }
initOrigNames :: [Name] -> OrigNameCache
initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names
......@@ -81,7 +81,7 @@ delFromNameSet = delOneFromUniqSet
filterNameSet = filterUniqSet
intersectNameSet = intersectUniqSets
delListFromNameSet set ns = foldl delFromNameSet set ns
delListFromNameSet set ns = foldl' delFromNameSet set ns
intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2))
......
......@@ -842,7 +842,7 @@ emptyTidyOccEnv :: TidyOccEnv
emptyTidyOccEnv = emptyUFM
initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid!
initTidyOccEnv = foldl add emptyUFM
initTidyOccEnv = foldl' add emptyUFM
where
add env (OccName _ fs) = addToUFM env fs 1
......
......@@ -88,7 +88,7 @@ import Util
import NameEnv
import Data.Data
import Data.List( sortBy, foldl', nub )
import Data.List( sortBy, nub )
{-
************************************************************************
......@@ -995,7 +995,7 @@ extendGlobalRdrEnv env gre
(greOccName gre) gre
shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv
shadowNames = foldl shadowName
shadowNames = foldl' shadowName
{- Note [GlobalRdrEnv shadowing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -131,7 +131,7 @@ extendInScopeSet (InScope in_scope n) v
extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
extendInScopeSetList (InScope in_scope n) vs
= InScope (foldl (\s v -> extendVarSet s v) in_scope vs)
= InScope (foldl' (\s v -> extendVarSet s v) in_scope vs)
(n + length vs)
extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet
......
......@@ -24,7 +24,6 @@ import Panic
import Util
import Control.Monad
import Data.List
-- Note [What is shortcutting]
......
......@@ -41,7 +41,6 @@ import Outputable (panic)
import Unique
import Data.Set (Set)
import Data.List
import qualified Data.Set as Set
-----------------------------------------------------------------------------
......
......@@ -24,7 +24,6 @@ import PprCmm ()
import qualified Data.IntSet as IntSet
import Data.List (partition)
import qualified Data.Set as Set
import Data.List
import Data.Maybe
-- Compact sets for membership tests of local variables.
......
......@@ -40,7 +40,6 @@ import Cmm
import UniqSupply
import Data.Array
import Data.List
import Data.Maybe
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
......
......@@ -632,7 +632,7 @@ forkAlts branch_fcodes
, cgs_hp_usg = cgs_hp_usg state }
(_us, results) = mapAccumL compile us branch_fcodes
(branch_results, branch_out_states) = unzip results
; setState $ foldl stateIncUsage state branch_out_states
; setState $ foldl' stateIncUsage state branch_out_states
-- NB foldl. state is the *left* argument to stateIncUsage
; return branch_results }
......
......@@ -937,7 +937,7 @@ etaExpand n orig_expr
-- See Note [Eta expansion and source notes]
(expr', args) = collectArgs expr
(ticks, expr'') = stripTicksTop tickishFloatable expr'
sexpr = foldl App expr'' args
sexpr = foldl' App expr'' args
retick expr = foldr mkTick expr ticks
-- Abstraction Application
......
......@@ -483,7 +483,7 @@ trieMapView ty
-- First check for TyConApps that need to be expanded to
-- AppTy chains.
| Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty
= Just $ foldl AppTy (TyConApp tc []) tys
= Just $ foldl' AppTy (TyConApp tc []) tys
-- Then resolve any remaining nullary synonyms.
| Just ty' <- tcView ty = Just ty'
......@@ -716,7 +716,7 @@ extendCME (CME { cme_next = bv, cme_env = env }) v
= CME { cme_next = bv+1, cme_env = extendVarEnv env v bv }
extendCMEs :: CmEnv -> [Var] -> CmEnv
extendCMEs env vs = foldl extendCME env vs
extendCMEs env vs = foldl' extendCME env vs
lookupCME :: CmEnv -> Var -> Maybe BoundVar
lookupCME (CME { cme_env = env }) v = lookupVarEnv env v
......
......@@ -144,7 +144,7 @@ simpleOptPgm dflags this_mod binds rules
(\_ -> False) {- No rules active -}
rules binds
(final_env, binds') = foldl do_one (emptyEnv dflags, []) occ_anald_binds
(final_env, binds') = foldl' do_one (emptyEnv dflags, []) occ_anald_binds
final_subst = soe_subst final_env
rules' = substRulesForImportedIds final_subst rules
......@@ -332,7 +332,7 @@ simple_opt_bind env (Rec prs)
res_bind = Just (Rec (reverse rev_prs'))
prs' = joinPointBindings_maybe prs `orElse` prs
(env', bndrs') = subst_opt_bndrs env (map fst prs')
(env'', rev_prs') = foldl do_pr (env', []) (prs' `zip` bndrs')
(env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs')
do_pr (env, prs) ((b,r), b')
= (env', case mb_pr of
Just pr -> pr : prs
......
......@@ -1815,12 +1815,12 @@ mkVarApps :: Expr b -> [Var] -> Expr b
-- use 'MkCore.mkCoreConApps' if possible
mkConApp :: DataCon -> [Arg b] -> Expr b
mkApps f args = foldl App f args
mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args
mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
mkApps f args = foldl' App f args
mkCoApps f args = foldl' (\ e a -> App e (Coercion a)) f args
mkVarApps f vars = foldl' (\ e a -> App e (varToCoreExpr a)) f vars
mkConApp con args = mkApps (Var (dataConWorkId con)) args
mkTyApps f args = foldl (\ e a -> App e (mkTyArg a)) f args
mkTyApps f args = foldl' (\ e a -> App e (mkTyArg a)) f args
mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b
mkConApp2 con tys arg_ids = Var (dataConWorkId con)
......
......@@ -666,7 +666,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
-- differently than `univ_tvs ++ ex_tvs) above.
-- See Note [DataCon user type variable binders]
-- in DataCon.
rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args
-- Tediously wrap the application in a cast
-- Note [Update for GADTs]
......
......@@ -605,7 +605,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
-- the expression we give to rts_evalIO
expr_to_run
= foldl appArg the_cfun arg_info -- NOT aug_arg_info
= foldl' appArg the_cfun arg_info -- NOT aug_arg_info
where
appArg acc (arg_cname, _, arg_hty, _)
= text "rts_apply"
......
......@@ -1886,7 +1886,7 @@ unC (MkC x) = x
rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
rep2 n xs = do { id <- dsLookupGlobalId n
; return (MkC (foldl App (Var id) xs)) }
; return (MkC (foldl' App (Var id) xs)) }
dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
dataCon' n args = do { id <- dsLookupDataCon n
......
......@@ -490,7 +490,7 @@ mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore
-- NB: No argument can be levity polymorphic
mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args
mkCastDs :: CoreExpr -> Coercion -> CoreExpr
-- We define a desugarer-specific version of CoreUtils.mkCast,
......
......@@ -53,8 +53,8 @@ import Unique
import UniqDFM
import Control.Monad( when, unless )
import Data.List ( groupBy )
import qualified Data.Map as Map
import Data.List (groupBy)
{-
************************************************************************
......@@ -880,7 +880,7 @@ subGroup :: (m -> [[EquationInfo]]) -- Map.elems
-- Parameterized by map operations to allow different implementations
-- and constraints, eg. types without Ord instance.
subGroup elems empty lookup insert group
= map reverse $ elems $ foldl accumulate empty group
= map reverse $ elems $ foldl' accumulate empty group
where
accumulate pg_map (pg, eqn)
= case lookup pg pg_map of
......
......@@ -91,6 +91,7 @@ import FastString
import Maybes( isJust )
import Data.Data hiding ( Fixity, Prefix, Infix )
import Data.List ( foldl' )
import Data.Maybe ( fromMaybe )
{-
......@@ -1033,7 +1034,7 @@ mkHsAppTy t1 t2
mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
-> LHsType (GhcPass p)
mkHsAppTys = foldl mkHsAppTy
mkHsAppTys = foldl' mkHsAppTy
{-
************************************************************************
......
......@@ -184,7 +184,7 @@ mkHsAppType e t = addCLoc e t_body (HsAppType paren_wct e)
paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
mkHsAppTypes = foldl mkHsAppType
mkHsAppTypes = foldl' mkHsAppType
mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExt matches))
......@@ -210,7 +210,7 @@ nlHsTyApp fun_id tys
nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)]
-> LHsExpr (GhcPass id)
nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs
--------- Adding parens ---------
mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
......@@ -418,17 +418,17 @@ nlHsSyntaxApps (SyntaxExpr { syn_expr = fun
, syn_res_wrap = res_wrap }) args
| [] <- arg_wraps -- in the noSyntaxExpr case
= ASSERT( isIdHsWrapper res_wrap )
foldl nlHsApp (noLoc fun) args
foldl' nlHsApp (noLoc fun) args
| otherwise
= mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
= mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
mkLHsWrap arg_wraps args))
nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs
nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps f xs = noLoc (foldl mk (HsVar noExt (noLoc f))
nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExt (noLoc f))
(map ((HsVar noExt) . noLoc) xs))
where
mk f a = HsApp noExt (noLoc f) (noLoc a)
......@@ -510,7 +510,7 @@ nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a)
nlHsParTy t = noLoc (HsParTy noExt t)
nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys
{-
Tuples. All these functions are *pre-typechecker* because they lack
......
......@@ -1014,7 +1014,7 @@ mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
-- each sublist in canonical order
[decl]) -- Orphan decls; in canonical order
mkOrphMap get_key decls
= foldl go (emptyOccEnv, []) decls
= foldl' go (emptyOccEnv, []) decls
where
go (non_orphs, orphs) d
| NotOrphan occ <- get_key d
......
......@@ -75,7 +75,6 @@ import ListSetOps
import GHC.Fingerprint
import qualified BooleanFormula as BF
import Data.List
import Control.Monad
import qualified Data.Map as Map
......
......@@ -544,7 +544,7 @@ toIfaceApp (Var v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as
---------------------
toIfaceVar :: Id -> IfaceExpr
......
......@@ -261,7 +261,7 @@ fileInfo fp = go <$> POSIX.getFileStatus fp
)
oct2dec :: Int -> Int
oct2dec = foldl (\a b -> a * 10 + b) 0 . reverse . dec 8
oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8
where dec _ 0 = []
dec b i = let (rest, last) = i `quotRem` b
in last:dec b rest
......
......@@ -2650,7 +2650,7 @@ safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String])
safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns)
where
-- Handle illegal flags under safe language.
(dflagsUnset, warns) = foldl check_method (dflags, []) unsafeFlags
(dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags
check_method (df, warns) (str,loc,test,fix)
| test df = (fix df, warns ++ safeFailure (loc df) str)
......
......@@ -710,7 +710,7 @@ checkStability
-> StableModules
checkStability hpt sccs all_home_mods =
foldl checkSCC (emptyUniqSet, emptyUniqSet) sccs
foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs
where
checkSCC :: StableModules -> SCC ModSummary -> StableModules
checkSCC (stable_obj, stable_bco) scc0
......
......@@ -203,7 +203,6 @@ import qualified GHC.LanguageExtensions as LangExt
import Foreign
import Control.Monad ( guard, liftM, ap )
import Data.Foldable ( foldl' )
import Data.IORef
import Data.Time
import Exception
......@@ -1711,7 +1710,7 @@ icExtendGblRdrEnv env tythings
| is_sub_bndr thing
= env
| otherwise
= foldl extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)
= foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)
where
env1 = shadowNames env (concatMap availNames avail)
avail = tyThingAvailInfo thing
......@@ -2115,7 +2114,7 @@ extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv
extendTypeEnv env thing = extendNameEnv env (getName thing) thing
extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv
extendTypeEnvList env things = foldl extendTypeEnv env things
extendTypeEnvList env things = foldl' extendTypeEnv env things
extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds env ids
......
......@@ -417,7 +417,7 @@ searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
extendPackageConfigMap
:: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs
= PackageConfigMap (foldl add pkg_map new_pkgs) closure
= PackageConfigMap (foldl' add pkg_map new_pkgs) closure
-- We also add the expanded version of the packageConfigId, so that
-- 'improveUnitId' can find it.
where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p)
......@@ -1519,7 +1519,7 @@ mkPackageState dflags dbs preload0 = do
--
let preload1 = Map.keys (Map.filter uv_explicit vis_map)
let pkgname_map = foldl add Map.empty pkgs2
let pkgname_map = foldl' add Map.empty pkgs2
where add pn_map p
= Map.insert (packageName p) (componentId p) pn_map
......
......@@ -365,7 +365,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
-- build the global register conflict graph
let graphGlobal
= foldl Color.union Color.initGraph
= foldl' Color.union Color.initGraph
$ [ Color.raGraph stat
| stat@Color.RegAllocStatsStart{} <- stats]
......@@ -957,7 +957,7 @@ build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
-- shorted.
-- Don't completely eliminate loops here -- that can leave a dangling jump!
(_, shortcut_blocks, others) =
foldl split (setEmpty :: LabelSet, [], []) blocks
foldl' split (setEmpty :: LabelSet, [], []) blocks
split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
| Just jd <- canShortcut ncgImpl insn,
Just dest <- getJumpDestBlockId ncgImpl jd,
......
......@@ -16,8 +16,6 @@ import UniqFM
import UniqSet
import UniqSupply
import Data.List
-- | Do register coalescing on this top level thing
--
......
......@@ -27,7 +27,6 @@ import UniqSet
import UniqSupply
import Util (seqList)
import Data.List
import Data.Maybe
import Control.Monad
......
......@@ -34,9 +34,6 @@ import UniqFM
import UniqSet
import State
import Data.List
-- | Holds interesting statistics from the register allocator.
data RegAllocStats statics instr
......
......@@ -15,7 +15,6 @@ import Instruction
import UniqFM
import Outputable
import Data.List
import State
-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
......
......@@ -171,8 +171,8 @@ knownKeyNamesOkay all_names
| otherwise
= Just badNamesStr
where
namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n)
emptyUFM all_names
namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) singleton m n n)
emptyUFM all_names
badNamesEnv = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv
badNamesPairs = nonDetUFMToList badNamesEnv
-- It's OK to use nonDetUFMToList here because the ordering only affects
......
......@@ -563,7 +563,7 @@ extendGlobalRdrEnvRn avails new_fixities
; rdr_env2 <- foldlM add_gre rdr_env1 new_gres
; let fix_env' = foldl extend_fix_env fix_env new_gres
; let fix_env' = foldl' extend_fix_env fix_env new_gres
gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)
......
......@@ -760,4 +760,4 @@ lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity
lubArityEnv = plusVarEnv_C min
lubRess :: [CallArityRes] -> CallArityRes
lubRess = foldl lubRes emptyArityRes
lubRess = foldl' lubRes emptyArityRes
......@@ -181,7 +181,7 @@ fiExpr dflags to_drop ann_expr@(_,AnnApp {})
-- lists without evaluating extra_fvs, and hence without
-- peering into each argument
(_, extra_fvs) = foldl add_arg (fun_ty, extra_fvs0) ann_args
(_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args
extra_fvs0 = case ann_fun of
(_, AnnVar _) -> fun_fvs
_ -> emptyDVarSet
......@@ -471,7 +471,7 @@ fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts)
alts_fvs = map alt_fvs alts
all_alts_fvs = unionDVarSets alts_fvs
alt_fvs (_con, args, rhs)
= foldl delDVarSet (freeVarsOf rhs) (case_bndr:args)
= foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)
-- Delete case_bndr and args from free vars of rhs
-- to get free vars of alt
......
......@@ -2436,7 +2436,7 @@ andUDs = combineUsageDetailsWith addOccInfo
orUDs = combineUsageDetailsWith orOccInfo
andUDsList :: [UsageDetails] -> UsageDetails
andUDsList = foldl andUDs emptyDetails
andUDsList = foldl' andUDs emptyDetails
mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails
mkOneOcc env id int_cxt arity
......
......@@ -403,13 +403,13 @@ lvlApp env orig_expr ((_,AnnVar fn), args)
, Nothing <- isClassOpId_maybe fn
= do { rargs' <- mapM (lvlNonTailMFE env False) rargs
; lapp' <- lvlNonTailMFE env False lapp
; return (foldl App lapp' rargs') }
; return (foldl' App lapp' rargs') }
| otherwise
= 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') }
; return (foldl' App (lookupVar env fn) args') }
where
n_val_args = count (isValArg . deAnnotate) args
arity = idArity fn
......@@ -450,7 +450,7 @@ lvlApp env _ (fun, args)
-- arguments and the function.
do { args' <- mapM (lvlNonTailMFE env False) args
; fun' <- lvlNonTailExpr env fun
; return (foldl App fun' args') }
; return (foldl' App fun' args') }
-------------------------------------------
lvlCase :: LevelEnv -- Level of in-scope names/tyvars
......@@ -1270,7 +1270,7 @@ substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])
-- So named only to avoid the name clash with CoreSubst.substBndrs
substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs
= ( env { le_subst = subst'
, le_env = foldl add_id id_env (bndrs `zip` bndrs') }
, le_env = foldl' add_id id_env (bndrs `zip` bndrs') }
, bndrs')
where
(subst', bndrs') = case is_rec of
......@@ -1479,7 +1479,7 @@ addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
addLvls dest_lvl env vs = foldl (addLvl dest_lvl) env vs
addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs
floatLams :: LevelEnv -> Maybe Int
floatLams le = floatOutLambdas (le_switches le)
......@@ -1596,8 +1596,8 @@ newPolyBndrs dest_lvl
; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
bndr_prs = bndrs `zip` new_bndrs
env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
, le_subst = foldl add_subst subst bndr_prs
, le_env = foldl add_id id_env bndr_prs }
, le_subst = foldl' add_subst subst bndr_prs
, le_env = foldl' add_id id_env bndr_prs }
; return (env', new_bndrs) }
where
add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
......@@ -1651,7 +1651,7 @@ cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env
, le_join_ceil = new_lvl
, le_lvl_env = addLvls new_lvl lvl_env vs'
, le_subst = subst'
, le_env = foldl add_id id_env (vs `zip` vs') }
, le_env = foldl' add_id id_env (vs `zip` vs') }
; return (env', vs') }
......@@ -1673,7 +1673,7 @@ cloneLetVars is_rec
prs = vs `zip` vs2
env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
, le_subst = subst'
, le_env = foldl add_id id_env prs }
, le_env = foldl' add_id id_env prs }
; return (env', vs2) }
where
......
......@@ -295,7 +295,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
do { tick LetFloatFromLet
; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl
tvs' body_floats2 body2
; let floats = foldl extendFloats (emptyFloats env) poly_binds
; let floats = foldl' extendFloats (emptyFloats env) poly_binds
; rhs' <- mkLam env tvs' body3 rhs_cont
; return (floats, rhs') }
......@@ -2978,7 +2978,7 @@ mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont })
= do { (floats1, cont') <- mkDupableCont env cont
; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))
(ai_args info)
; return ( foldl addLetFloats floats1 floats_s
; return ( foldl' addLetFloats floats1 floats_s
, StrictArg { sc_fun = info { ai_args = args' }
, sc_cci = cci
, sc_cont = cont'
......
......@@ -350,7 +350,7 @@ mkRuleBase rules = extendRuleBaseList emptyRuleBase rules
extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList rule_base new_guys
= foldl extendRuleBase rule_base new_guys
= foldl' extendRuleBase rule_base new_guys
unionRuleBase :: RuleBase -> RuleBase -> RuleBase
unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2
......@@ -907,7 +907,7 @@ match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
= do { subst1 <- match renv' subst r1 r2
; match_alts renv subst1 alts1 alts2 }
where
renv' = foldl mb renv (vs1 `zip` vs2)
renv' = foldl' mb renv (vs1 `zip` vs2)
mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2
match_alts _ _ _ _
......
......@@ -2096,7 +2096,7 @@ mkDB bind = (bind, bind_fvs bind)
-- | Identify the free variables of a 'CoreBind'
bind_fvs :: CoreBind -> VarSet
bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs
bind_fvs (Rec prs) = foldl' delVarSet rhs_fvs bndrs
where
bndrs = map fst prs
rhs_fvs = unionVarSets (map pair_fvs prs)
......
......@@ -644,7 +644,7 @@ dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
Nothing | (bndrs, body) <- collectBinders rhs
-> (bndrs, body, mkBodyDmd env body)
env_body = foldl extendSigsWithLam env bndrs
env_body = foldl' extendSigsWithLam env bndrs
(body_ty, body') = dmdAnal env_body body_dmd body
body_ty' = removeDmdTyArgs body_ty -- zap possible deep CPR info
(DmdType rhs_fv rhs_dmds rhs_res, bndrs')
......@@ -1193,7 +1193,7 @@ extendSigsWithLam env id
extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv
-- See Note [CPR in a product case alternative]
extendEnvForProdAlt env scrut case_bndr dc bndrs
= foldl do_con_arg env1 ids_w_strs
= foldl' do_con_arg env1 ids_w_strs
where
env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig
......
......@@ -541,7 +541,7 @@ oclose preds fixed_tvs
| null tv_fds = fixed_tvs -- Fast escape hatch for common case.
| otherwise = fixVarSet extend fixed_tvs
where
extend fixed_tvs = foldl add fixed_tvs tv_fds
extend fixed_tvs = foldl' add fixed_tvs tv_fds
where
add fixed_tvs (ls,rs)
| ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs
......
......@@ -364,7 +364,7 @@ collectHsWrapBinders wrap = go wrap []
go (WpEvLam v) wraps = add_lam v (gos wraps)
go (WpTyLam v) wraps = add_lam v (gos wraps)
go (WpCompose w1 w2) wraps = go w1 (w2:wraps)
go wrap wraps = ([], foldl (<.>) wrap wraps)
go wrap wraps = ([], foldl' (<.>) wrap wraps)
gos [] = ([], WpHole)
gos (w:ws) = go w ws
......
......@@ -2743,7 +2743,7 @@ missingFields con fields
header = text "Fields of" <+> quotes (ppr con) <+>
text "not initialised"
-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl mkHsApp fun args))
-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args))
noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
noPossibleParents rbinds
......
......@@ -1362,7 +1362,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
gfoldl_eqn con
= ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
foldl mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
where
con_name :: RdrName
con_name = getRdrName con
......@@ -1567,7 +1567,7 @@ gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)
lift_Expr
| is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]