Commit 45d9a15c authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix a huge space leak in the mighty Simplifier

This long-standing, terrible, adn somewhat subtle bug was exposed
by Trac #10370, thanks to Reid Barton's brilliant test case (comment:3).

The effect is large on the Trac #10370 test.
Here is what the profile report says:

Before:
 total time  =       24.35 secs   (24353 ticks @ 1000 us, 1 processor)
 total alloc = 11,864,360,816 bytes  (excludes profiling overheads)

After:
 total time  =       21.16 secs   (21160 ticks @ 1000 us, 1 processor)
 total alloc = 7,947,141,136 bytes  (excludes profiling overheads)

The /combined/ effect of the tidyOccName fix, plus this one, is dramtic
for Trac #10370.  Here is what +RTS -s says:

Before:
  15,490,210,952 bytes allocated in the heap
   1,783,919,456 bytes maximum residency (20 sample(s))

  MUT     time   30.117s  ( 31.383s elapsed)
  GC      time   90.103s  ( 90.107s elapsed)
  Total   time  120.843s  (122.065s elapsed)

After:
   7,928,671,936 bytes allocated in the heap
      52,914,832 bytes maximum residency (25 sample(s))

  MUT     time   13.912s  ( 15.110s elapsed)
  GC      time    6.809s  (  6.808s elapsed)
  Total   time   20.789s  ( 21.954s elapsed)

- Heap allocation halved
- Residency cut by a factor of more than 30.
- ELapsed time cut by a factor of 6

Not bad!

The details
~~~~~~~~~~~
The culprit was SimplEnv.mkCoreSubst, which used mapVarEnv to do some
impedence-matching from the substitituion used by the simplifier to
the one used by CoreSubst.  But the impedence-mactching was recursive!

  mk_subst tv_env cv_env id_env
    = CoreSubst.mkSubst in_scope tv_env cv_env (mapVarEnv fiddle id_env)

  fiddle (DoneEx e)          = e
  fiddle (DoneId v)          = Var v
  fiddle (ContEx tv cv id e) = CoreSubst.substExpr (mk_subst tv cv id) e

Inside fiddle, in the ContEx case, we may do another whole level of
fiddle.  And so on.  Moreover, UniqFM (which is built on Data.IntMap) is
strict, so the fiddling is done eagerly.  I didn't wok through all the
details but the result is a gargatuan blow-up of entirely unnecessary work.

Laziness would make this go away, I think, but I don't want to mess
with IntMap.  And in any case, the impedence matching is a royal pain.

In the end I simply ceased trying to use CoreSubst.substExpr in the
simplifier, and instead just use simplExpr.  That does mean bit of
duplication; e.g.  new code for simplRules.  But it's not a big deal
and it's far more direct and easy to reason about.

A bit of knock-on refactoring:

 * Data type ArgSummary moves to CoreUnfold.

 * interestingArg moves from CoreUnfold to SimplUtils, and gets a
   SimplEnv argument which can be used when we encounter a variable.

 * simplLamBndrs, addBndrRules move from SimplEnv to Simplify
   (because they now calls simplUnfolding, simplRules resp)

 * SimplUtils.substExpr, substUnfolding, mkCoreSubst die completely

 * In Simplify some several functions that were previously pure
   substitution-based functions are now monadic:
     - addBndrRules, simplRule
     - addCoerce, add_coerce in simplCast

 * In case 2c of Simplify.rebuildCase, there was a pretty disgusting
   expression-substitution taking place for 'rhs'; and we really don't
   want to make that monadic becuase 'rhs' can be big.
   Solution: reduce the arity of the rules for seq.
   See Note [User-defined RULES for seq] in MkId.
parent c89bd681
......@@ -27,7 +27,7 @@ module CoreUnfold (
mkCompulsoryUnfolding, mkDFunUnfolding,
specUnfolding,
interestingArg, ArgSummary(..),
ArgSummary(..),
couldBeSmallEnoughToInline, inlineBoringOk,
certainlyWillInline, smallEnoughToInline,
......@@ -986,11 +986,20 @@ callSiteInline :: DynFlags
-> CallCtxt -- True <=> continuation is interesting
-> Maybe CoreExpr -- Unfolding, if any
data ArgSummary = TrivArg -- Nothing interesting
| NonTrivArg -- Arg has structure
| ValueArg -- Arg is a con-app or PAP
-- ..or con-like. Note [Conlike is interesting]
instance Outputable ArgSummary where
ppr TrivArg = ptext (sLit "TrivArg")
ppr NonTrivArg = ptext (sLit "NonTrivArg")
ppr ValueArg = ptext (sLit "ValueArg")
nonTriv :: ArgSummary -> Bool
nonTriv TrivArg = False
nonTriv _ = True
data CallCtxt
= BoringCtxt
| RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets]
......@@ -1358,80 +1367,3 @@ computeDiscount dflags arg_discounts res_discount arg_infos cont_info
-- But we want to aovid inlining large functions that return
-- constructors into contexts that are simply "interesting"
{-
************************************************************************
* *
Interesting arguments
* *
************************************************************************
Note [Interesting arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
An argument is interesting if it deserves a discount for unfoldings
with a discount in that argument position. The idea is to avoid
unfolding a function that is applied only to variables that have no
unfolding (i.e. they are probably lambda bound): f x y z There is
little point in inlining f here.
Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But
we must look through lets, eg (let x = e in C a b), because the let will
float, exposing the value, if we inline. That makes it different to
exprIsHNF.
Before 2009 we said it was interesting if the argument had *any* structure
at all; i.e. (hasSomeUnfolding v). But does too much inlining; see Trac #3016.
But we don't regard (f x y) as interesting, unless f is unsaturated.
If it's saturated and f hasn't inlined, then it's probably not going
to now!
Note [Conlike is interesting]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f d = ...((*) d x y)...
... f (df d')...
where df is con-like. Then we'd really like to inline 'f' so that the
rule for (*) (df d) can fire. To do this
a) we give a discount for being an argument of a class-op (eg (*) d)
b) we say that a con-like argument (eg (df d)) is interesting
-}
data ArgSummary = TrivArg -- Nothing interesting
| NonTrivArg -- Arg has structure
| ValueArg -- Arg is a con-app or PAP
-- ..or con-like. Note [Conlike is interesting]
interestingArg :: CoreExpr -> ArgSummary
-- See Note [Interesting arguments]
interestingArg e = go e 0
where
-- n is # value args to which the expression is applied
go (Lit {}) _ = ValueArg
go (Var v) n
| isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that
-- data constructors here
| idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding
| n > 0 = NonTrivArg -- Saturated or unknown call
| conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding
-- See Note [Conlike is interesting]
| otherwise = TrivArg -- n==0, no useful unfolding
where
conlike_unfolding = isConLikeUnfolding (idUnfolding v)
go (Type _) _ = TrivArg
go (Coercion _) _ = TrivArg
go (App fn (Type _)) n = go fn n
go (App fn (Coercion _)) n = go fn n
go (App fn _) n = go fn (n+1)
go (Tick _ a) n = go a n
go (Cast e _) n = go e n
go (Lam v e) n
| isTyVar v = go e n
| n>0 = go e (n-1)
| otherwise = ValueArg
go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
go (Case {}) _ = NonTrivArg
nonTriv :: ArgSummary -> Bool
nonTriv TrivArg = False
nonTriv _ = True
......@@ -12,7 +12,6 @@ module SimplCore ( core2core, simplifyExpr ) where
import DynFlags
import CoreSyn
import CoreSubst
import HscTypes
import CSE ( cseProgram )
import Rules ( emptyRuleBase, mkRuleBase, unionRuleBase,
......@@ -24,7 +23,7 @@ import CoreUtils ( coreBindsSize, coreBindsStats, exprSize,
mkTicks, stripTicksTop )
import CoreLint ( showPass, endPass, lintPassResult, dumpPassResult,
lintAnnots )
import Simplify ( simplTopBinds, simplExpr )
import Simplify ( simplTopBinds, simplExpr, simplRule )
import SimplUtils ( simplEnvForGHCi, activeRule )
import SimplEnv
import SimplMonad
......@@ -640,20 +639,20 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
eps <- hscEPS hsc_env ;
let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
; rule_base2 = extendRuleBaseList rule_base1 rules
; simpl_binds = {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
-- Simplify the program
(env1, counts1) <- initSmpl dflags rule_base2 fam_envs us1 sz simpl_binds ;
-- Apply the substitution to rules defined in this module
-- for imported Ids. Eg RULE map my_f = blah
-- If we have a substitution my_f :-> other_f, we'd better
-- apply it to the rule to, or it'll never match
let { binds1 = getFloatBinds env1
; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
} ;
((binds1, rules1), counts1) <- initSmpl dflags rule_base2 fam_envs us1 sz $
do { env1 <- {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
-- Apply the substitution to rules defined in this module
-- for imported Ids. Eg RULE map my_f = blah
-- If we have a substitution my_f :-> other_f, we'd better
-- apply it to the rule to, or it'll never match
; rules1 <- mapM (simplRule env1 Nothing) rules
; return (getFloatBinds env1, rules1) } ;
-- Stop if nothing happened; don't dump output
if isZeroSimplCount counts1 then
......
......@@ -21,13 +21,12 @@ module SimplEnv (
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
getSimplRules,
SimplSR(..), mkContEx, substId, lookupRecBndr,
SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
simplBinder, simplBinders, addBndrRules,
substExpr, substTy, substTyVar, getTvSubst,
simplNonRecBndr, simplRecBndrs,
simplBinder, simplBinders,
substTy, substTyVar, getTvSubst,
getCvSubst, substCo, substCoVar,
mkCoreSubst,
-- Floats
Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
......@@ -39,7 +38,6 @@ module SimplEnv (
import SimplMonad
import CoreMonad ( SimplifierMode(..) )
import IdInfo
import CoreSyn
import CoreUtils
import Var
......@@ -49,7 +47,6 @@ import OrdList
import Id
import MkCore ( mkWildValBinder )
import TysWiredIn
import qualified CoreSubst
import qualified Type
import Type hiding ( substTy, substTyVarBndr, substTyVar )
import qualified Coercion
......@@ -516,16 +513,16 @@ substId :: SimplEnv -> InId -> SimplSR
-- Returns DoneEx only on a non-Var expression
substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
= case lookupVarEnv ids v of -- Note [Global Ids in the substitution]
Nothing -> DoneId (refine in_scope v)
Just (DoneId v) -> DoneId (refine in_scope v)
Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
Nothing -> DoneId (refineFromInScope in_scope v)
Just (DoneId v) -> DoneId (refineFromInScope in_scope v)
Just (DoneEx (Var v)) -> DoneId (refineFromInScope in_scope v)
Just res -> res -- DoneEx non-var, or ContEx
-- Get the most up-to-date thing from the in-scope set
-- Even though it isn't in the substitution, it may be in
-- the in-scope set with better IdInfo
refine :: InScopeSet -> Var -> Var
refine in_scope v
refineFromInScope :: InScopeSet -> Var -> Var
refineFromInScope in_scope v
| isLocalId v = case lookupInScope in_scope v of
Just v' -> v'
Nothing -> WARN( True, ppr v ) v -- This is an error!
......@@ -538,7 +535,7 @@ lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
= case lookupVarEnv ids v of
Just (DoneId v) -> v
Just _ -> pprPanic "lookupRecBndr" (ppr v)
Nothing -> refine in_scope v
Nothing -> refineFromInScope in_scope v
{-
************************************************************************
......@@ -551,10 +548,8 @@ lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
These functions are in the monad only so that they can be made strict via seq.
-}
simplBinders, simplLamBndrs
:: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
simplBinders env bndrs = mapAccumLM simplBinder env bndrs
simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
-------------
simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
......@@ -569,23 +564,6 @@ simplBinder env bndr
| otherwise = do { let (env', id) = substIdBndr env bndr
; seqId id `seq` return (env', id) }
-------------
simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
-- Used for lambda binders. These sometimes have unfoldings added by
-- the worker/wrapper pass that must be preserved, because they can't
-- be reconstructed from context. For example:
-- f x = case x of (a,b) -> fw a b x
-- fw a b x{=(a,b)} = ...
-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
simplLamBndr env bndr
| isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2) -- Special case
| otherwise = simplBinder env bndr -- Normal case
where
old_unf = idUnfolding bndr
(env1, id1) = substIdBndr env bndr
id2 = id1 `setIdUnfolding` substUnfolding env old_unf
env2 = modifyInScope env1 id2
---------------
simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- A non-recursive let binder
......@@ -696,29 +674,8 @@ Note [Robust OccInfo]
It's important that we *do* retain the loop-breaker OccInfo, because
that's what stops the Id getting inlined infinitely, in the body of
the letrec.
Note [Rules in a letrec]
~~~~~~~~~~~~~~~~~~~~~~~~
After creating fresh binders for the binders of a letrec, we
substitute the RULES and add them back onto the binders; this is done
*before* processing any of the RHSs. This is important. Manuel found
cases where he really, really wanted a RULE for a recursive function
to apply in that function's own right-hand side.
See Note [Loop breaking and RULES] in OccAnal.
-}
addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
-- Rules are added back into the bin
addBndrRules env in_id out_id
| isEmptySpecInfo old_rules = (env, out_id)
| otherwise = (modifyInScope env final_id, final_id)
where
subst = mkCoreSubst (text "local rules") env
old_rules = idSpecialisation in_id
new_rules = CoreSubst.substSpec subst out_id old_rules
final_id = out_id `setIdSpecialisation` new_rules
{-
************************************************************************
......@@ -760,22 +717,6 @@ substCoVarBndr env cv
substCo :: SimplEnv -> Coercion -> Coercion
substCo env co = Coercion.substCo (getCvSubst env) co
-- When substituting in rules etc we can get CoreSubst to do the work
-- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
-- here. I think the this will not usually result in a lot of work;
-- the substitutions are typically small, and laziness will avoid work in many cases.
mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst
mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env, seIdSubst = id_env })
= mk_subst tv_env cv_env id_env
where
mk_subst tv_env cv_env id_env = CoreSubst.mkSubst in_scope tv_env cv_env (mapVarEnv fiddle id_env)
fiddle (DoneEx e) = e
fiddle (DoneId v) = Var v
fiddle (ContEx tv cv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv cv id) e
-- Don't shortcut here
------------------
substIdType :: SimplEnv -> Id -> Id
substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id
......@@ -786,16 +727,3 @@ substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id
-- in a Note in the id's type itself
where
old_ty = idType id
------------------
substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr
substExpr doc env
= CoreSubst.substExpr (text "SimplEnv.substExpr1" <+> doc)
(mkCoreSubst (text "SimplEnv.substExpr2" <+> doc) env)
-- Do *not* short-cut in the case of an empty substitution
-- See Note [SimplEnv invariants]
substUnfolding :: SimplEnv -> Unfolding -> Unfolding
substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst (text "subst-unfolding") env) unf
-- Do *not* short-cut in the case of an empty substitution
-- See Note [SimplEnv invariants]
This diff is collapsed.
This diff is collapsed.
......@@ -636,8 +636,10 @@ test('T9872d',
test('T9961',
[ only_ways(['normal']),
compiler_stats_num_field('bytes allocated',
[(wordsize(64), 772510192, 5),
[(wordsize(64), 663978160, 5),
# 2015-01-12 807117816 Initally created
# 2015-spring 772510192 Got better
# 2015-05-22 663978160 Fix for #10370 improves it more
(wordsize(32), 375647160, 5)
]),
],
......
......@@ -4,5 +4,7 @@
forall ($dMyFunctor :: MyFunctor []) (irred :: Domain [] Int).
shared @ [] $dMyFunctor irred
= bar_$sshared
"SPEC/Foo myfmap @ []" [ALWAYS]
forall (tpl :: MyFunctor []). myfmap @ [] tpl = $cmyfmap
......@@ -10,13 +10,14 @@
==================== Grand total simplifier statistics ====================
Total ticks: 11
Total ticks: 12
2 PreInlineUnconditionally
1 f
1 lvl
1 UnfoldingDone 1 Roman.bar
1 RuleFired 1 foo/bar
1 EtaReduction 1 ds
7 BetaReduction
1 f
1 m
......
......@@ -10,7 +10,7 @@ module Main where
f x = not x
{-# RULES
"f/seq" forall n e. seq (f n) e = True
"f/seq" forall n. seq (f n) = const True
#-}
main = print (seq (f True) False)
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment