Commit c86161c5 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

More work on the simplifier's inlining strategies

This patch collects a small raft of related changes

* Arrange that during 
     (a) rule matching and 
     (b) uses of exprIsConApp_maybe
  we "look through" unfoldings only if they are active
  in the phase. Doing this for (a) required a bit of 
  extra plumbing in the rule matching code, but I think
  it's worth it.

  One wrinkle is that even if inlining is off (in the 'gentle'
  phase of simplification) during rule matching we want to
  "look through" things with inlinings.  
   See SimplUtils.activeUnfInRule.

  This fixes a long-standing bug, where things that were
  supposed to be (say) NOINLINE, could still be poked into
  via exprIsConApp_maybe. 

* In the above cases, also check for (non-rule) loop breakers; 
  we never look through these.  This fixes a bug that could make
  the simplifier diverge (and did for Roman).  
  Test = simplCore/should_compile/dfun-loop

* Try harder not to choose a DFun as a loop breaker. This is 
  just a small adjustment in the OccurAnal scoring function

* In the scoring function in OccurAnal, look at the InlineRule
  unfolding (if there is one) not the actual RHS, beause the
  former is what'll be inlined.  

* Make the application of any function to dictionary arguments
  CONLIKE.  Thus (f d1 d2) is CONLIKE.  
  Encapsulated in CoreUtils.isExpandableApp
  Reason: see Note [Expandable overloadings] in CoreUtils

* Make case expressions seem slightly smaller in CoreUnfold.
  This reverses an unexpected consequences of charging for
  alternatives.

Refactorings
~~~~~~~~~~~~
* Signficantly refactor the data type for Unfolding (again). 
  The result is much nicer.  

* Add type synonym BasicTypes.CompilerPhase = Int
  and use it

Many of the files touched by this patch are simply knock-on
consequences of these two refactorings.
parent f65f61e1
......@@ -345,7 +345,7 @@ mkDataConIds wrap_name wkr_name data_con
-- ...(let w = C x in ...(w p q)...)...
-- we want to see that w is strict in its two arguments
wrap_unf = mkInlineRule InlSat wrap_rhs (length dict_args + length id_args)
wrap_unf = mkInlineRule needSaturated wrap_rhs (length dict_args + length id_args)
wrap_rhs = mkLams wrap_tvs $
mkLams eq_args $
mkLams dict_args $ mkLams id_args $
......@@ -520,16 +520,16 @@ mkDictSelId no_unf name clas
| otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
[(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
dictSelRule :: Int -> Arity -> [CoreExpr] -> Maybe CoreExpr
dictSelRule :: Int -> Arity -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- Oh, very clever
-- op_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
-- op_i t1..tk (D t1..tk op1 ... opm) = opi
--
-- NB: the data constructor has the same number of type args as the class op
dictSelRule index n_ty_args args
dictSelRule index n_ty_args id_unf args
| (dict_arg : _) <- drop n_ty_args args
, Just (_, _, val_args) <- exprIsConApp_maybe dict_arg
, Just (_, _, val_args) <- exprIsConApp_maybe id_unf dict_arg
= Just (val_args !! index)
| otherwise
= Nothing
......@@ -958,12 +958,12 @@ seqId = pcMiscPrelId seqName ty info
, ru_try = match_seq_of_cast
}
match_seq_of_cast :: [CoreExpr] -> Maybe CoreExpr
match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- See Note [Built-in RULES for seq]
match_seq_of_cast [Type _, Type res_ty, Cast scrut co, expr]
match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr]
= Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty,
scrut, expr])
match_seq_of_cast _ = Nothing
match_seq_of_cast _ _ = Nothing
------------------------------------------------
lazyId :: Id -- See Note [lazyId magic]
......
......@@ -421,7 +421,8 @@ idUnfoldingVars :: Id -> VarSet
-- we might get out-of-scope variables
idUnfoldingVars id
= case realIdUnfolding id of
CoreUnfolding { uf_tmpl = rhs, uf_guidance = InlineRule {} }
CoreUnfolding { uf_tmpl = rhs, uf_src = src }
| isInlineRuleSource src
-> exprFreeVars rhs
DFunUnfolding _ args -> exprsFreeVars args
_ -> emptyVarSet
......
......@@ -13,7 +13,7 @@ module CoreSubst (
-- ** Substituting into expressions and related types
deShadowBinds, substSpec, substRulesForImportedIds,
substTy, substExpr, substBind, substUnfolding,
substInlineRuleInfo, lookupIdSubst, lookupTvSubst, substIdOcc,
substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc,
-- ** Operations on substitutions
emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
......@@ -507,28 +507,39 @@ substUnfolding :: Subst -> Unfolding -> Unfolding
substUnfolding subst (DFunUnfolding con args)
= DFunUnfolding con (map (substExpr subst) args)
substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_guidance = guide@(InlineRule {}) })
substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
-- Retain an InlineRule!
| not (isInlineRuleSource src) -- Always zap a CoreUnfolding, to save substitution work
= NoUnfolding
| otherwise -- But keep an InlineRule!
= seqExpr new_tmpl `seq`
new_info `seq`
unf { uf_tmpl = new_tmpl, uf_guidance = guide { ir_info = new_info } }
new_src `seq`
unf { uf_tmpl = new_tmpl, uf_src = new_src }
where
new_tmpl = substExpr subst tmpl
new_info = substInlineRuleInfo subst (ir_info guide)
substUnfolding _ (CoreUnfolding {}) = NoUnfolding -- Discard
-- Always zap a CoreUnfolding, to save substitution work
new_src = substUnfoldingSource subst src
substUnfolding _ unf = unf -- NoUnfolding, OtherCon
-------------------
substInlineRuleInfo :: Subst -> InlineRuleInfo -> InlineRuleInfo
substInlineRuleInfo (Subst in_scope ids _) (InlWrapper wkr)
| Just (Var w1) <- lookupVarEnv ids wkr = InlWrapper w1
| Just w1 <- lookupInScope in_scope wkr = InlWrapper w1
| otherwise = WARN( True, text "Interesting! CoreSubst.substWorker:" <+> ppr wkr )
InlVanilla -- Note [Worker inlining]
substInlineRuleInfo _ info = info
substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource
substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
| Just wkr_expr <- lookupVarEnv ids wkr
= case wkr_expr of
Var w1 -> InlineWrapper w1
_other -> WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr
<+> equals <+> ppr wkr_expr ) -- Note [Worker inlining]
InlineRule -- It's not a wrapper any more, but still inline it!
| Just w1 <- lookupInScope in_scope wkr = InlineWrapper w1
| otherwise = WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
-- This can legitimately happen. The worker has been inlined and
-- dropped as dead code, because we don't treat the UnfoldingSource
-- as an "occurrence".
-- Note [Worker inlining]
InlineRule
substUnfoldingSource _ src = src
------------------
substIdOcc :: Subst -> Id -> Id
......
......@@ -35,19 +35,20 @@ module CoreSyn (
isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
-- * Unfolding data types
Unfolding(..), UnfoldingGuidance(..), InlineRuleInfo(..), InlSatFlag(..),
Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
-- Abstract everywhere but in CoreUnfold.lhs
-- ** Constructing 'Unfolding's
noUnfolding, evaldUnfolding, mkOtherCon,
unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
-- ** Predicates and deconstruction on 'Unfolding'
unfoldingTemplate, setUnfoldingTemplate,
maybeUnfoldingTemplate, otherCons, unfoldingArity,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding,
isStableUnfolding, canUnfold, neverUnfoldGuidance,
isStableUnfolding, canUnfold, neverUnfoldGuidance, isInlineRuleSource,
-- * Strictness
seqExpr, seqExprs, seqUnfolding,
......@@ -60,7 +61,7 @@ module CoreSyn (
-- * Core rule data types
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
RuleName,
RuleName, IdUnfoldingFun,
-- ** Operations on 'CoreRule's
seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
......@@ -333,13 +334,18 @@ data CoreRule
ru_fn :: Name, -- ^ As above
ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes,
-- if it fires, including type arguments
ru_try :: [CoreExpr] -> Maybe CoreExpr
ru_try :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- ^ This function does the rewrite. It given too many
-- arguments, it simply discards them; the returned 'CoreExpr'
-- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
}
-- See Note [Extra args in rule matching] in Rules.lhs
type IdUnfoldingFun = Id -> Unfolding
-- A function that embodies how to unfold an Id if you need
-- to do that in the Rule. The reason we need to pass this info in
-- is that whether an Id is unfoldable depends on the simplifier phase
isBuiltinRule :: CoreRule -> Bool
isBuiltinRule (BuiltinRule {}) = True
isBuiltinRule _ = False
......@@ -408,9 +414,10 @@ data Unfolding
| CoreUnfolding { -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma
-- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.)
uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
uf_arity :: Arity, -- Number of value arguments expected
uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
uf_src :: UnfoldingSource, -- Where the unfolding came from
uf_is_top :: Bool, -- True <=> top level binding
uf_arity :: Arity, -- Number of value arguments expected
uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard a `seq` on
-- this variable
uf_is_conlike :: Bool, -- True <=> application of constructor or CONLIKE function
......@@ -438,18 +445,38 @@ data Unfolding
-- uf_guidance: Tells us about the /size/ of the unfolding template
------------------------------------------------
data UnfoldingSource
= InlineCompulsory -- Something that *has* no binding, so you *must* inline it
-- Only a few primop-like things have this property
-- (see MkId.lhs, calls to mkCompulsoryUnfolding).
-- Inline absolutely always, however boring the context.
| InlineRule -- From an {-# INLINE #-} pragma; See Note [InlineRules]
| InlineWrapper Id -- This unfolding is a the wrapper in a
-- worker/wrapper split from the strictness analyser
-- The Id is the worker-id
-- Used to abbreviate the uf_tmpl in interface files
-- which don't need to contain the RHS;
-- it can be derived from the strictness info
| InlineRhs -- The current rhs of the function
-- For InlineRhs, the uf_tmpl is replaced each time around
-- For all the others we leave uf_tmpl alone
-- | 'UnfoldingGuidance' says when unfolding should take place
data UnfoldingGuidance
= InlineRule { -- Be very keen to inline this; See Note [InlineRules]
-- The uf_tmpl is the *original* RHS; do *not* replace it on
-- each simlifier run. Hence, the *actual* RHS of the function
-- may be different by now, because it may have been optimised.
ir_sat :: InlSatFlag,
ir_info :: InlineRuleInfo
= UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl
-- Used (a) for small *and* cheap unfoldings
-- (b) for INLINE functions
-- See Note [INLINE for small functions] in CoreUnfold
ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated
ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring
}
| UnfoldIfGoodArgs { -- Arose from a normal Id; the info here is the
| UnfIfGoodArgs { -- Arose from a normal Id; the info here is the
-- result of a simple analysis of the RHS
ug_args :: [Int], -- Discount if the argument is evaluated.
......@@ -462,30 +489,16 @@ data UnfoldingGuidance
} -- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
| UnfoldNever -- A variant of UnfoldIfGoodArgs, used for big RHSs
data InlineRuleInfo
= InlAlways -- Inline absolutely always, however boring the context.
-- There is /no original definition/. Only a few primop-like things
-- have this property (see MkId.lhs, calls to mkCompulsoryUnfolding).
| UnfNever -- The RHS is big, so don't inline it
| InlSmall -- The RHS is very small (eg no bigger than a call), so inline any
-- /saturated/ application, regardless of context
-- See Note [INLINE for small functions] in CoreUnfold
-- Constants for the UnfWhen constructor
needSaturated, unSaturatedOk :: Bool
needSaturated = False
unSaturatedOk = True
| InlVanilla
| InlWrapper Id -- This unfolding is a the wrapper in a
-- worker/wrapper split from the strictness analyser
-- The Id is the worker-id
-- Used to abbreviate the uf_tmpl in interface files
-- which don't need to contain the RHS;
-- it can be derived from the strictness info
-- [In principle this is orthogonal to the InlSmall/InVanilla thing,
-- but it's convenient to have it here.]
data InlSatFlag = InlSat | InlUnSat
-- Specifies whether to INLINE only if the thing is applied to 'arity' args
boringCxtNotOk, boringCxtOk :: Bool
boringCxtOk = True
boringCxtNotOk = False
------------------------------------------------
noUnfolding :: Unfolding
......@@ -509,11 +522,17 @@ seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
seqUnfolding _ = ()
seqGuidance :: UnfoldingGuidance -> ()
seqGuidance (UnfoldIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
seqGuidance _ = ()
seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
seqGuidance _ = ()
\end{code}
\begin{code}
isInlineRuleSource :: UnfoldingSource -> Bool
isInlineRuleSource InlineCompulsory = True
isInlineRuleSource InlineRule = True
isInlineRuleSource (InlineWrapper {}) = True
isInlineRuleSource InlineRhs = False
-- | Retrieves the template of an unfolding: panics if none is known
unfoldingTemplate :: Unfolding -> CoreExpr
unfoldingTemplate = uf_tmpl
......@@ -565,20 +584,29 @@ isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expabl
isExpandableUnfolding _ = False
isInlineRule :: Unfolding -> Bool
isInlineRule (CoreUnfolding { uf_guidance = InlineRule {}}) = True
isInlineRule _ = False
isInlineRule_maybe :: Unfolding -> Maybe (InlineRuleInfo, InlSatFlag)
isInlineRule_maybe (CoreUnfolding { uf_guidance =
InlineRule { ir_info = inl, ir_sat = sat } }) = Just (inl,sat)
isInlineRule_maybe _ = Nothing
isInlineRule (CoreUnfolding { uf_src = src }) = isInlineRuleSource src
isInlineRule _ = False
isInlineRule_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool)
isInlineRule_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide })
| isInlineRuleSource src
= Just (src, unsat_ok)
where
unsat_ok = case guide of
UnfWhen unsat_ok _ -> unsat_ok
_ -> needSaturated
isInlineRule_maybe _ = Nothing
isCompulsoryUnfolding :: Unfolding -> Bool
isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
isCompulsoryUnfolding _ = False
isStableUnfolding :: Unfolding -> Bool
-- True of unfoldings that should not be overwritten
-- by a CoreUnfolding for the RHS of a let-binding
isStableUnfolding (CoreUnfolding { uf_guidance = InlineRule {} }) = True
isStableUnfolding (DFunUnfolding {}) = True
isStableUnfolding _ = False
isStableUnfolding (CoreUnfolding { uf_src = src }) = isInlineRuleSource src
isStableUnfolding (DFunUnfolding {}) = True
isStableUnfolding _ = False
unfoldingArity :: Unfolding -> Arity
unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity
......@@ -594,15 +622,15 @@ hasSomeUnfolding NoUnfolding = False
hasSomeUnfolding _ = True
neverUnfoldGuidance :: UnfoldingGuidance -> Bool
neverUnfoldGuidance UnfoldNever = True
neverUnfoldGuidance _ = False
neverUnfoldGuidance UnfNever = True
neverUnfoldGuidance _ = False
canUnfold :: Unfolding -> Bool
canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
canUnfold _ = False
\end{code}
Note [InlineRule]
Note [InlineRules]
~~~~~~~~~~~~~~~~~
When you say
{-# INLINE f #-}
......
%
calcU%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1994-1998
%
......@@ -87,9 +87,18 @@ mkImplicitUnfolding expr = mkTopUnfolding (simpleOptExpr expr)
mkUnfolding :: Bool -> CoreExpr -> Unfolding
mkUnfolding top_lvl expr
= mkCoreUnfolding top_lvl expr arity guidance
= CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
uf_src = InlineRhs,
uf_arity = arity,
uf_is_top = top_lvl,
uf_is_value = exprIsHNF expr,
uf_is_conlike = exprIsConLike expr,
uf_expandable = exprIsExpandable expr,
uf_is_cheap = is_cheap,
uf_guidance = guidance }
where
(arity, guidance) = calcUnfoldingGuidance opt_UF_CreationThreshold expr
is_cheap = exprIsCheap expr
(arity, guidance) = calcUnfoldingGuidance is_cheap opt_UF_CreationThreshold expr
-- Sometimes during simplification, there's a large let-bound thing
-- which has been substituted, and so is now dead; so 'expr' contains
-- two copies of the thing while the occurrence-analysed expression doesn't
......@@ -100,10 +109,12 @@ mkUnfolding top_lvl expr
-- it gets fixed up next round. And it should be rare, because large
-- let-bound things that are dead are usually caught by preInlineUnconditionally
mkCoreUnfolding :: Bool -> CoreExpr -> Arity -> UnfoldingGuidance -> Unfolding
mkCoreUnfolding :: Bool -> UnfoldingSource -> CoreExpr
-> Arity -> UnfoldingGuidance -> Unfolding
-- Occurrence-analyses the expression before capturing it
mkCoreUnfolding top_lvl expr arity guidance
mkCoreUnfolding top_lvl src expr arity guidance
= CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
uf_src = src,
uf_arity = arity,
uf_is_top = top_lvl,
uf_is_value = exprIsHNF expr,
......@@ -117,27 +128,28 @@ mkDFunUnfolding con ops = DFunUnfolding con (map Var ops)
mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
mkWwInlineRule id expr arity
= mkCoreUnfolding True (simpleOptExpr expr) arity
(InlineRule { ir_sat = InlUnSat, ir_info = InlWrapper id })
= mkCoreUnfolding True (InlineWrapper id)
(simpleOptExpr expr) arity
(UnfWhen unSaturatedOk boringCxtNotOk)
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
= mkCoreUnfolding True expr
0 -- Arity of unfolding doesn't matter
(InlineRule { ir_info = InlAlways, ir_sat = InlUnSat })
= mkCoreUnfolding True InlineCompulsory
expr 0 -- Arity of unfolding doesn't matter
(UnfWhen unSaturatedOk boringCxtOk)
mkInlineRule :: InlSatFlag -> CoreExpr -> Arity -> Unfolding
mkInlineRule sat expr arity
= mkCoreUnfolding True -- Note [Top-level flag on inline rules]
mkInlineRule :: Bool -> CoreExpr -> Arity -> Unfolding
mkInlineRule unsat_ok expr arity
= mkCoreUnfolding True InlineRule -- Note [Top-level flag on inline rules]
expr' arity
(InlineRule { ir_sat = sat, ir_info = info })
(UnfWhen unsat_ok boring_ok)
where
expr' = simpleOptExpr expr
info = if small then InlSmall else InlVanilla
small = case calcUnfoldingGuidance (arity+1) expr' of
(arity_e, UnfoldIfGoodArgs { ug_size = size_e })
-> uncondInline arity_e size_e
_other {- actually UnfoldNever -} -> False
boring_ok = case calcUnfoldingGuidance True -- Treat as cheap
(arity+1) expr' of
(_, UnfWhen _ boring_ok) -> boring_ok
_other -> boringCxtNotOk
-- See Note [INLINE for small functions]
\end{code}
......@@ -149,25 +161,34 @@ mkInlineRule sat expr arity
\begin{code}
calcUnfoldingGuidance
:: Int -- bomb out if size gets bigger than this
-> CoreExpr -- expression to look at
:: Bool -- True <=> the rhs is cheap, or we want to treat it
-- as cheap (INLINE things)
-> Int -- Bomb out if size gets bigger than this
-> CoreExpr -- Expression to look at
-> (Arity, UnfoldingGuidance)
calcUnfoldingGuidance bOMB_OUT_SIZE expr
= case collectBinders expr of { (binders, body) ->
calcUnfoldingGuidance expr_is_cheap bOMB_OUT_SIZE expr
= case collectBinders expr of { (bndrs, body) ->
let
val_binders = filter isId binders
n_val_binders = length val_binders
val_bndrs = filter isId bndrs
n_val_bndrs = length val_bndrs
guidance
= case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_bndrs body) of
TooBig -> UnfNever
SizeIs size cased_bndrs scrut_discount
| uncondInline n_val_bndrs (iBox size) && expr_is_cheap
-> UnfWhen needSaturated boringCxtOk
| otherwise
-> UnfIfGoodArgs { ug_args = map (discount cased_bndrs) val_bndrs
, ug_size = iBox size
, ug_res = iBox scrut_discount }
discount cbs bndr
= foldlBag (\acc (b',n) -> if bndr==b' then acc+n else acc)
0 cbs
in
case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_binders body) of
TooBig -> (n_val_binders, UnfoldNever)
SizeIs size cased_args scrut_discount
-> (n_val_binders, UnfoldIfGoodArgs { ug_args = map discount_for val_binders
, ug_size = iBox size
, ug_res = iBox scrut_discount })
where
discount_for b = foldlBag (\acc (b',n) -> if b==b' then acc+n else acc)
0 cased_args
}
(n_val_bndrs, guidance) }
\end{code}
Note [Computing the size of an expression]
......@@ -267,7 +288,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
size_up (Case (Var v) _ _ alts)
| v `elem` top_args -- We are scrutinising an argument variable
= alts_size (foldr addSize sizeOne alt_sizes) -- The 1 is for the case itself
= alts_size (foldr1 addSize alt_sizes) -- The 1 is for the case itself
(foldr1 maxSize alt_sizes)
-- Good to inline if an arg is scrutinised, because
-- that may eliminate allocation in the caller
......@@ -279,7 +300,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
-- the case when we are scrutinising an argument variable
alts_size (SizeIs tot tot_disc _tot_scrut) -- Size of all alternatives
(SizeIs max _max_disc max_scrut) -- Size of biggest alternative
= SizeIs tot (unitBag (v, iBox (_ILIT(1) +# tot -# max)) `unionBags` tot_disc) max_scrut
= SizeIs tot (unitBag (v, iBox (_ILIT(2) +# tot -# max)) `unionBags` tot_disc) max_scrut
-- If the variable is known, we produce a discount that
-- will take us back to 'max', the size of the largest alternative
-- The 1+ is a little discount for reduced allocation in the caller
......@@ -292,12 +313,13 @@ sizeExpr bOMB_OUT_SIZE top_args expr
size_up (Case e _ _ alts) = foldr (addSize . size_up_alt)
(nukeScrutDiscount (size_up e))
alts
`addSizeN` 1 -- Add 1 for the case itself
-- We don't charge for the case itself
-- It's a strict thing, and the price of the call
-- is paid by scrut. Also consider
-- case f x of DEFAULT -> e
-- This is just ';'! Don't charge for it.
--
-- Moreover, we charge one per alternative.
------------
-- size_up_app is used when there's ONE OR MORE value args
......@@ -522,17 +544,14 @@ maxSize _ TooBig = TooBig
maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1
| otherwise = s2
sizeZero, sizeOne :: ExprSize
sizeZero :: ExprSize
sizeN :: Int -> ExprSize
sizeZero = SizeIs (_ILIT(0)) emptyBag (_ILIT(0))
sizeOne = SizeIs (_ILIT(1)) emptyBag (_ILIT(0))
sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(0))
\end{code}
%************************************************************************
%* *
\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
......@@ -547,13 +566,13 @@ actual arguments.
\begin{code}
couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
couldBeSmallEnoughToInline threshold rhs
= case calcUnfoldingGuidance threshold rhs of
(_, UnfoldNever) -> False
_ -> True
= case calcUnfoldingGuidance False threshold rhs of
(_, UnfNever) -> False
_ -> True
----------------
smallEnoughToInline :: Unfolding -> Bool
smallEnoughToInline (CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_size = size}})
smallEnoughToInline (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}})
= size <= opt_UF_UseThreshold
smallEnoughToInline _
= False
......@@ -563,9 +582,9 @@ certainlyWillInline :: Unfolding -> Bool
-- Sees if the unfolding is pretty certain to inline
certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals, uf_guidance = guidance })
= case guidance of
UnfoldNever -> False
InlineRule {} -> True
UnfoldIfGoodArgs { ug_size = size}
UnfNever -> False
UnfWhen {} -> True
UnfIfGoodArgs { ug_size = size}
-> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
certainlyWillInline _
......@@ -596,8 +615,8 @@ StrictAnal.addStrictnessInfoToTopId
\begin{code}
callSiteInline :: DynFlags
-> Bool -- True <=> the Id can be inlined
-> Id -- The Id
-> Unfolding -- Its unfolding (if active)
-> Bool -- True if there are are no arguments at all (incl type args)
-> [ArgSummary] -- One for each value arg; True if it is interesting
-> CallCtxt -- True <=> continuation is interesting
......@@ -632,8 +651,8 @@ instance Outputable CallCtxt where
ppr CaseCtxt = ptext (sLit "CaseCtxt")
ppr ValAppCtxt = ptext (sLit "ValAppCtxt")
callSiteInline dflags active_inline id lone_variable arg_infos cont_info
= case idUnfolding id of {
callSiteInline dflags id unfolding lone_variable arg_infos cont_info
= case unfolding of {
NoUnfolding -> Nothing ;
OtherCon _ -> Nothing ;
DFunUnfolding {} -> Nothing ; -- Never unfold a DFun
......@@ -642,7 +661,8 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
-- uf_arity will typically be equal to (idArity id),
-- but may be less for InlineRules
let
n_val_args = length arg_infos
n_val_args = length arg_infos
saturated = n_val_args >= uf_arity
result | yes_or_no = Just unf_template
| otherwise = Nothing
......@@ -657,9 +677,12 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
-- arguments (ie n_val_args >= arity). But there must
-- be *something* interesting about some argument, or the
-- result context, to make it worth inlining
some_benefit = interesting_args
|| n_val_args > uf_arity -- Over-saturated
|| interesting_saturated_call -- Exactly saturated
some_benefit
| not saturated = interesting_args -- Under-saturated
-- Note [Unsaturated applications]
| n_val_args > uf_arity = True -- Over-saturated
| otherwise = interesting_args -- Saturated
|| interesting_saturated_call
interesting_saturated_call
= case cont_info of
......@@ -668,46 +691,35 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info
ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt]
ValAppCtxt -> True -- Note [Cast then apply]
yes_or_no
(yes_or_no, extra_doc)
= case guidance of
UnfoldNever -> False
InlineRule { ir_info = inl_info, ir_sat = sat }
| InlAlways <- inl_info -> True -- No top-level binding, so inline!
-- Ignore is_active because we want to
-- inline even if SimplGently is on.
| not active_inline -> False
| n_val_args < uf_arity -> yes_unsat -- Not enough value args
| InlSmall <- inl_info -> True -- Note [INLINE for small functions]
| otherwise -> some_benefit -- Saturated or over-saturated
where
-- See Note [Inlining an InlineRule]
yes_unsat = case sat of
InlSat -> False
InlUnSat -> interesting_args
UnfoldIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
| not active_inline -> False
| not is_cheap -> False
| n_val_args < uf_arity -> interesting_args && small_enough
-- Note [Unsaturated applications]
| uncondInline uf_arity size -> True
| otherwise -> some_benefit && small_enough
UnfNever -> (False, empty)
UnfWhen unsat_ok boring_ok -> ( (unsat_ok || saturated)
&& (boring_ok || some_benefit)
, empty )
-- For the boring_ok part see Note [INLINE for small functions]
UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
-> ( is_cheap && some_benefit && small_enough
, (text "discounted size =" <+> int discounted_size) )
where
small_enough = (size - discount) <= opt_UF_UseThreshold
discounted_size = size - discount
small_enough = discounted_size <= opt_UF_UseThreshold
discount = computeDiscount uf_arity arg_discounts
res_discount arg_infos cont_info
in
if dopt Opt_D_dump_inlinings dflags then
pprTrace ("Considering inlining: " ++ showSDoc (ppr id))
(vcat [text "active:" <+> ppr active_inline,
text "arg infos" <+> ppr arg_infos,
(vcat [text "arg infos" <+> ppr arg_infos,
text "uf arity" <+> ppr uf_arity,
text "interesting continuation" <+> ppr cont_info,
text "some_benefit" <+> ppr some_benefit,
text "is value:" <+> ppr is_value,
text "is cheap:" <+> ppr is_cheap,
text "guidance" <+> ppr guidance,
extra_doc,