[Git][ghc/ghc][wip/simplifier-fixes] 3 commits: Avoid retaining bindings via ModGuts held on the stack
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Fri Aug 26 10:12:38 UTC 2022
Matthew Pickering pushed to branch wip/simplifier-fixes at Glasgow Haskell Compiler / GHC
Commits:
b27d95ce by Matthew Pickering at 2022-08-26T10:53:08+01:00
Avoid retaining bindings via ModGuts held on the stack
It's better to overwrite the bindings fields of the ModGuts before
starting an iteration as then all the old bindings can be collected as
soon as the simplifier has processed them. Otherwise we end up with the
old bindings being alive until right at the end of the simplifier pass
as the mg_binds field is only modified right at the end.
- - - - -
01e9b9f0 by Matthew Pickering at 2022-08-26T10:53:08+01:00
Force imposs_deflt_cons in filterAlts
This fixes a pretty serious space leak as the forced thunk would retain
`Alt b` values which would then contain reference to a lot of old
bindings and other simplifier gunk.
The OtherCon unfolding was not forced on subsequent simplifier runs so
more and more old stuff would be retained until the end of
simplification.
Fixing this has a drastic effect on maximum residency for the mmark
package which goes from
```
45,005,401,056 bytes allocated in the heap
17,227,721,856 bytes copied during GC
818,281,720 bytes maximum residency (33 sample(s))
9,659,144 bytes maximum slop
2245 MiB total memory in use (0 MB lost due to fragmentation)
```
to
```
45,039,453,304 bytes allocated in the heap
13,128,181,400 bytes copied during GC
331,546,608 bytes maximum residency (40 sample(s))
7,471,120 bytes maximum slop
916 MiB total memory in use (0 MB lost due to fragmentation)
```
See #21993 for some more discussion.
- - - - -
0dfaf303 by Matthew Pickering at 2022-08-26T11:03:58+01:00
Use Solo to avoid retaining the SCE but to avoid performing the substitution
The use of Solo here allows us to force the selection into the SCE to obtain
the Subst but without forcing the substitution to be applied. The resulting thunk
is placed into a lazy field which is rarely forced, so forcing it regresses
peformance.
- - - - -
4 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -3437,24 +3437,26 @@ lintAnnots pname pass guts = {-# SCC "lintAnnots" #-} do
logger <- getLogger
when (gopt Opt_DoAnnotationLinting dflags) $
liftIO $ Err.showPass logger "Annotation linting - first run"
- nguts <- pass guts
-- If appropriate re-run it without debug annotations to make sure
-- that they made no difference.
- when (gopt Opt_DoAnnotationLinting dflags) $ do
- liftIO $ Err.showPass logger "Annotation linting - second run"
- nguts' <- withoutAnnots pass guts
- -- Finally compare the resulting bindings
- liftIO $ Err.showPass logger "Annotation linting - comparison"
- let binds = flattenBinds $ mg_binds nguts
- binds' = flattenBinds $ mg_binds nguts'
- (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'
- when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat
- [ lint_banner "warning" pname
- , text "Core changes with annotations:"
- , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs
- ]
- -- Return actual new guts
- return nguts
+ if gopt Opt_DoAnnotationLinting dflags
+ then do
+ nguts <- pass guts
+ liftIO $ Err.showPass logger "Annotation linting - second run"
+ nguts' <- withoutAnnots pass guts
+ -- Finally compare the resulting bindings
+ liftIO $ Err.showPass logger "Annotation linting - comparison"
+ let binds = flattenBinds $ mg_binds nguts
+ binds' = flattenBinds $ mg_binds nguts'
+ (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'
+ when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat
+ [ lint_banner "warning" pname
+ , text "Core changes with annotations:"
+ , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs
+ ]
+ return nguts
+ else
+ pass guts
-- | Run the given pass without annotations. This means that we both
-- set the debugLevel setting to 0 in the environment as well as all
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -152,8 +152,10 @@ simplifyPgm logger unit_env opts
, mg_deps = deps
, mg_binds = binds, mg_rules = rules
, mg_fam_inst_env = fam_inst_env })
- = do { (termination_msg, it_count, counts_out, guts')
- <- do_iteration 1 [] binds rules
+ = do { -- If you don't do this then all the old bindings are retained until
+ -- the end of the simplifier pass.
+ ; (termination_msg, it_count, counts_out, guts')
+ <- do_iteration 1 [] binds rules
; when (logHasDumpFlag logger Opt_D_verbose_core2core
&& logHasDumpFlag logger Opt_D_dump_simpl_stats) $
@@ -175,6 +177,7 @@ simplifyPgm logger unit_env opts
print_unqual = mkPrintUnqualified unit_env rdr_env
active_rule = activeRule mode
active_unf = activeUnfolding mode
+ !guts_no_binds = guts { mg_binds = [], mg_rules = [] }
do_iteration :: Int -- Counts iterations
-> [SimplCount] -- Counts from earlier iterations, reversed
@@ -198,7 +201,7 @@ simplifyPgm logger unit_env opts
-- number of iterations we actually completed
return ( "Simplifier baled out", iteration_no - 1
, totalise counts_so_far
- , guts { mg_binds = binds, mg_rules = rules } )
+ , guts_no_binds { mg_binds = binds, mg_rules = rules } )
-- Try and force thunks off the binds; significantly reduces
-- space usage, especially with -O. JRS, 000620.
@@ -253,7 +256,7 @@ simplifyPgm logger unit_env opts
if isZeroSimplCount counts1 then
return ( "Simplifier reached fixed point", iteration_no
, totalise (counts1 : counts_so_far) -- Include "free" ticks
- , guts { mg_binds = binds1, mg_rules = rules1 } )
+ , guts_no_binds { mg_binds = binds1, mg_rules = rules1 } )
else do {
-- Short out indirections
-- We do this *after* at least one run of the simplifier
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -79,6 +79,7 @@ import Control.Monad ( zipWithM )
import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )
import Data.Maybe( mapMaybe )
import Data.Ord( comparing )
+import Data.Tuple
{-
-----------------------------------------------------
@@ -971,8 +972,16 @@ lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
scSubstId :: ScEnv -> InId -> OutExpr
scSubstId env v = lookupIdSubst (sc_subst env) v
-scSubstTy :: ScEnv -> InType -> OutType
-scSubstTy env ty = substTyUnchecked (sc_subst env) ty
+-- The use of Solo here allows us to force the selection (sc_subst env) that extracts
+-- the substitution from the ScEnv but without forcing the substitution
+-- to be applied to the type. The resulting thunk
+-- is placed into a lazy field (either a Type argument or the type field of a Case)
+-- which is rarely forced, so forcing it reemptively regresses peformance.
+-- See #22102
+scSubstTy :: ScEnv -> InType -> Solo OutType
+scSubstTy env ty =
+ let !subst = sc_subst env
+ in Solo (substTyUnchecked subst ty)
scSubstCo :: ScEnv -> Coercion -> Coercion
scSubstCo env co = substCo (sc_subst env) co
@@ -1407,7 +1416,9 @@ scExpr' env (Var v) = case scSubstId env v of
Var v' -> return (mkVarUsage env v' [], Var v')
e' -> scExpr (zapScSubst env) e'
-scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
+scExpr' env (Type t) =
+ let !(Solo ty') = scSubstTy env t
+ in return (nullUsage, Type ty')
scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))
scExpr' _ e@(Lit {}) = return (nullUsage, e)
scExpr' env (Tick t e) = do (usg, e') <- scExpr env e
@@ -1451,9 +1462,10 @@ scExpr' env (Case scrut b ty alts)
-- The combined usage of the scrutinee is given
-- by scrut_occ, which is passed to scScrut, which
-- in turn treats a bare-variable scrutinee specially
+ ; let !(Solo ty') = scSubstTy env ty
; return (foldr combineUsage scrut_usg' alt_usgs,
- Case scrut' b' (scSubstTy env ty) alts') }
+ Case scrut' b' ty' alts') }
sc_alt env scrut' b' (Alt con bs rhs)
= do { let (env1, bs1) = extendBndrsWith RecArg env bs
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -706,7 +706,11 @@ filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (us
-- in a "case" statement then they will need to manually add a dummy case branch that just
-- calls "error" or similar.
filterAlts _tycon inst_tys imposs_cons alts
- = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt)
+ = imposs_deflt_cons `seqList`
+ (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt)
+ -- Very important to force `imposs_deflt_cons` as that forces `alt_cons`, which
+ -- is essentially as retaining `alts_wo_default` or any `Alt b` for that matter
+ -- leads to a huge space leak (see !8896)
where
(alts_wo_default, maybe_deflt) = findDefault alts
alt_cons = [con | Alt con _ _ <- alts_wo_default]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/396818e733cfc96cef39cc6f0db94f920c069374...0dfaf3034ae207651b0a85a12c5cdf330f66399d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/396818e733cfc96cef39cc6f0db94f920c069374...0dfaf3034ae207651b0a85a12c5cdf330f66399d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220826/964630a6/attachment-0001.html>
More information about the ghc-commits
mailing list