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]
......@@ -20,10 +20,10 @@ module SimplUtils (
SimplCont(..), DupFlag(..),
isSimplified,
contIsDupable, contResultType, contHoleType,
contIsTrivial, contArgs,
contIsTrivial, contArgs,
countValArgs, countArgs,
mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
interestingCallContext, interestingArg,
interestingCallContext,
-- ArgInfo
ArgInfo(..), ArgSpec(..), mkArgInfo,
......@@ -54,6 +54,7 @@ import SimplMonad
import Type hiding( substTy )
import Coercion hiding( substCo, substTy )
import DataCon ( dataConWorkId )
import VarEnv
import VarSet
import BasicTypes
import Util
......@@ -390,77 +391,10 @@ contArgs cont
go args (CastIt _ k) = go args k
go args k = (False, reverse args, k)
is_interesting arg se = interestingArg (substExpr (text "contArgs") se arg)
is_interesting arg se = interestingArg se arg
-- Do *not* use short-cutting substitution here
-- because we want to get as much IdInfo as possible
{-
Note [Interesting call context]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to avoid inlining an expression where there can't possibly be
any gain, such as in an argument position. Hence, if the continuation
is interesting (eg. a case scrutinee, application etc.) then we
inline, otherwise we don't.
Previously some_benefit used to return True only if the variable was
applied to some value arguments. This didn't work:
let x = _coerce_ (T Int) Int (I# 3) in
case _coerce_ Int (T Int) x of
I# y -> ....
we want to inline x, but can't see that it's a constructor in a case
scrutinee position, and some_benefit is False.
Another example:
dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
.... case dMonadST _@_ x0 of (a,b,c) -> ....
we'd really like to inline dMonadST here, but we *don't* want to
inline if the case expression is just
case x of y { DEFAULT -> ... }
since we can just eliminate this case instead (x is in WHNF). Similar
applies when x is bound to a lambda expression. Hence
contIsInteresting looks for case expressions with just a single
default case.
-}
interestingCallContext :: SimplCont -> CallCtxt
-- See Note [Interesting call context]
interestingCallContext cont
= interesting cont
where
interesting (Select _ _bndr _ _ _) = CaseCtxt
interesting (ApplyToVal {}) = ValAppCtxt
-- Can happen if we have (f Int |> co) y
-- If f has an INLINE prag we need to give it some
-- motivation to inline. See Note [Cast then apply]
-- in CoreUnfold
interesting (StrictArg _ cci _) = cci
interesting (StrictBind {}) = BoringCtxt
interesting (Stop _ cci) = cci
interesting (TickIt _ k) = interesting k
interesting (ApplyToTy { sc_cont = k }) = interesting k
interesting (CastIt _ k) = interesting k
-- If this call is the arg of a strict function, the context
-- is a bit interesting. If we inline here, we may get useful
-- evaluation information to avoid repeated evals: e.g.
-- x + (y * z)
-- Here the contIsInteresting makes the '*' keener to inline,
-- which in turn exposes a constructor which makes the '+' inline.
-- Assuming that +,* aren't small enough to inline regardless.
--
-- It's also very important to inline in a strict context for things
-- like
-- foldr k z (f x)
-- Here, the context of (f x) is strict, and if f's unfolding is
-- a build it's *great* to inline it here. So we must ensure that
-- the context for (f x) is not totally uninteresting.
-------------------
mkArgInfo :: Id
......@@ -541,6 +475,80 @@ it'll just be floated out again. Even if f has lots of discounts
on its first argument -- it must be saturated for these to kick in
-}
{-
************************************************************************
* *
Interesting arguments
* *
************************************************************************
Note [Interesting call context]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to avoid inlining an expression where there can't possibly be
any gain, such as in an argument position. Hence, if the continuation
is interesting (eg. a case scrutinee, application etc.) then we
inline, otherwise we don't.
Previously some_benefit used to return True only if the variable was
applied to some value arguments. This didn't work:
let x = _coerce_ (T Int) Int (I# 3) in
case _coerce_ Int (T Int) x of
I# y -> ....
we want to inline x, but can't see that it's a constructor in a case
scrutinee position, and some_benefit is False.
Another example:
dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
.... case dMonadST _@_ x0 of (a,b,c) -> ....
we'd really like to inline dMonadST here, but we *don't* want to
inline if the case expression is just
case x of y { DEFAULT -> ... }
since we can just eliminate this case instead (x is in WHNF). Similar
applies when x is bound to a lambda expression. Hence
contIsInteresting looks for case expressions with just a single
default case.
-}
interestingCallContext :: SimplCont -> CallCtxt
-- See Note [Interesting call context]
interestingCallContext cont
= interesting cont
where
interesting (Select _ _bndr _ _ _) = CaseCtxt
interesting (ApplyToVal {}) = ValAppCtxt
-- Can happen if we have (f Int |> co) y
-- If f has an INLINE prag we need to give it some
-- motivation to inline. See Note [Cast then apply]
-- in CoreUnfold
interesting (StrictArg _ cci _) = cci
interesting (StrictBind {}) = BoringCtxt
interesting (Stop _ cci) = cci
interesting (TickIt _ k) = interesting k
interesting (ApplyToTy { sc_cont = k }) = interesting k
interesting (CastIt _ k) = interesting k
-- If this call is the arg of a strict function, the context
-- is a bit interesting. If we inline here, we may get useful
-- evaluation information to avoid repeated evals: e.g.
-- x + (y * z)
-- Here the contIsInteresting makes the '*' keener to inline,
-- which in turn exposes a constructor which makes the '+' inline.
-- Assuming that +,* aren't small enough to inline regardless.
--
-- It's also very important to inline in a strict context for things
-- like
-- foldr k z (f x)
-- Here, the context of (f x) is strict, and if f's unfolding is
-- a build it's *great* to inline it here. So we must ensure that
-- the context for (f x) is not totally uninteresting.
interestingArgContext :: [CoreRule] -> SimplCont -> Bool
-- If the argument has form (f x y), where x,y are boring,
-- and f is marked INLINE, then we don't want to inline f.
......@@ -579,6 +587,77 @@ interestingArgContext rules call_cont
interesting RuleArgCtxt = True
interesting _ = False
{- 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
-}
interestingArg :: SimplEnv -> CoreExpr -> ArgSummary
-- See Note [Interesting arguments]
interestingArg env e = go env 0 e
where
-- n is # value args to which the expression is applied
go env n (Var v)
| SimplEnv { seIdSubst = ids, seInScope = in_scope } <- env
= case lookupVarEnv ids v of
Nothing -> go_var n (refineFromInScope in_scope v)
Just (DoneId v') -> go_var n (refineFromInScope in_scope v')
Just (DoneEx e) -> go (zapSubstEnv env) n e
Just (ContEx tvs cvs ids e) -> go (setSubstEnv env tvs cvs ids) n e
go _ _ (Lit {}) = ValueArg
go _ _ (Type _) = TrivArg
go _ _ (Coercion _) = TrivArg
go env n (App fn (Type _)) = go env n fn
go env n (App fn (Coercion _)) = go env n fn
go env n (App fn _) = go env (n+1) fn
go env n (Tick _ a) = go env n a
go env n (Cast e _) = go env n e
go env n (Lam v e)
| isTyVar v = go env n e
| n>0 = go env (n-1) e
| otherwise = ValueArg
go env n (Let _ e) = case go env n e of { ValueArg -> ValueArg; _ -> NonTrivArg }
go _ _ (Case {}) = NonTrivArg
go_var n v
| 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)
{-
************************************************************************
* *
......
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)