-calcU%
+%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1994-1998
%
%************************************************************************
\begin{code}
-mkTopUnfolding :: CoreExpr -> Unfolding
-mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
+mkTopUnfolding :: Bool -> CoreExpr -> Unfolding
+mkTopUnfolding is_bottoming expr
+ = mkUnfolding True {- Top level -} is_bottoming expr
mkImplicitUnfolding :: CoreExpr -> Unfolding
-- For implicit Ids, do a tiny bit of optimising first
-mkImplicitUnfolding expr = mkTopUnfolding (simpleOptExpr expr)
+mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr)
-- Note [Top-level flag on inline rules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- top-level flag to True. It gets set more accurately by the simplifier
-- Simplify.simplUnfolding.
-mkUnfolding :: Bool -> CoreExpr -> Unfolding
-mkUnfolding top_lvl expr
+mkUnfolding :: Bool -> Bool -> CoreExpr -> Unfolding
+mkUnfolding top_lvl is_bottoming expr
= CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
uf_src = InlineRhs,
uf_arity = arity,
uf_guidance = guidance }
where
is_cheap = exprIsCheap expr
- (arity, guidance) = calcUnfoldingGuidance is_cheap opt_UF_CreationThreshold expr
+ (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming)
+ 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
where
expr' = simpleOptExpr expr
boring_ok = case calcUnfoldingGuidance True -- Treat as cheap
+ False -- But not bottoming
(arity+1) expr' of
(_, UnfWhen _ boring_ok) -> boring_ok
_other -> boringCxtNotOk
calcUnfoldingGuidance
:: Bool -- True <=> the rhs is cheap, or we want to treat it
-- as cheap (INLINE things)
+ -> Bool -- True <=> this is a top-level unfolding for a
+ -- diverging function; don't inline this
-> Int -- Bomb out if size gets bigger than this
-> CoreExpr -- Expression to look at
-> (Arity, UnfoldingGuidance)
-calcUnfoldingGuidance expr_is_cheap bOMB_OUT_SIZE expr
+calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr
= case collectBinders expr of { (bndrs, body) ->
let
val_bndrs = filter isId bndrs
| uncondInline n_val_bndrs (iBox size) && expr_is_cheap
-> UnfWhen needSaturated boringCxtOk
+ | top_bot -- See Note [Do not inline top-level bottoming functions]
+ -> UnfNever
+
| otherwise
-> UnfIfGoodArgs { ug_args = map (discount cased_bndrs) val_bndrs
, ug_size = iBox size
a function call to account for. Notice also that constructor applications
are very cheap, because exposing them to a caller is so valuable.
+
+Note [Do not inline top-level bottoming functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The FloatOut pass has gone to some trouble to float out calls to 'error'
+and similar friends. See Note [Bottoming floats] in SetLevels.
+Do not re-inline them! But we *do* still inline if they are very small
+(the uncondInline stuff).
+
+
Note [Unconditional inlining]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We inline *unconditionally* if inlined thing is smaller (using sizeExpr)
-- discounts even on nullary constructors
size_up (App fun (Type _)) = size_up fun
- size_up (App fun arg) = size_up_app fun [arg]
- `addSize` nukeScrutDiscount (size_up arg)
+ size_up (App fun arg) = size_up arg `addSizeNSD`
+ size_up_app fun [arg]
size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 1)
| otherwise = size_up e
size_up (Let (NonRec binder rhs) body)
- = nukeScrutDiscount (size_up rhs) `addSize`
- size_up body `addSizeN`
+ = size_up rhs `addSizeNSD`
+ size_up body `addSizeN`
(if isUnLiftedType (idType binder) then 0 else 1)
-- For the allocation
-- If the binder has an unlifted type there is no allocation
size_up (Let (Rec pairs) body)
- = nukeScrutDiscount rhs_size `addSize`
- size_up body `addSizeN`
- length pairs -- For the allocation
- where
- rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
+ = foldr (addSizeNSD . size_up . snd)
+ (size_up body `addSizeN` length pairs) -- (length pairs) for the allocation
+ pairs
size_up (Case (Var v) _ _ alts)
| v `elem` top_args -- We are scrutinising an argument variable
- = alts_size (foldr1 addSize alt_sizes) -- The 1 is for the case itself
+ = alts_size (foldr1 addAltSize alt_sizes)
(foldr1 maxSize alt_sizes)
-- Good to inline if an arg is scrutinised, because
-- that may eliminate allocation in the caller
-- alts_size tries to compute a good discount for
-- 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(2) +# tot -# max)) `unionBags` tot_disc) max_scrut
+ alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives
+ (SizeIs max _ _) -- Size of biggest alternative
+ = SizeIs tot (unitBag (v, iBox (_ILIT(2) +# tot -# max)) `unionBags` tot_disc) tot_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
alts_size tot_size _ = tot_size
- size_up (Case e _ _ alts) = foldr (addSize . size_up_alt)
- (nukeScrutDiscount (size_up e))
- alts
+ size_up (Case e _ _ alts) = size_up e `addSizeNSD`
+ foldr (addAltSize . size_up_alt) sizeZero alts
-- 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
-- size_up_app is used when there's ONE OR MORE value args
size_up_app (App fun arg) args
| isTypeArg arg = size_up_app fun args
- | otherwise = size_up_app fun (arg:args)
- `addSize` nukeScrutDiscount (size_up arg)
+ | otherwise = size_up arg `addSizeNSD`
+ size_up_app fun (arg:args)
size_up_app (Var fun) args = size_up_call fun args
size_up_app other args = size_up other `addSizeN` length args
addSizeN TooBig _ = TooBig
addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n +# iUnbox m) xs d
- addSize TooBig _ = TooBig
- addSize _ TooBig = TooBig
- addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
- = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) (xs `unionBags` ys) (d1 +# d2)
+ -- addAltSize is used to add the sizes of case alternatives
+ addAltSize TooBig _ = TooBig
+ addAltSize _ TooBig = TooBig
+ addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
+ = mkSizeIs bOMB_OUT_SIZE (n1 +# n2)
+ (xs `unionBags` ys)
+ (d1 +# d2) -- Note [addAltSize result discounts]
+
+ -- This variant ignores the result discount from its LEFT argument
+ -- It's used when the second argument isn't part of the result
+ addSizeNSD TooBig _ = TooBig
+ addSizeNSD _ TooBig = TooBig
+ addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2)
+ = mkSizeIs bOMB_OUT_SIZE (n1 +# n2)
+ (xs `unionBags` ys)
+ d2 -- Ignore d1
\end{code}
\begin{code}
-- Ditto (augment t (\cn -> e) ys) should cost only the cost of
-- e plus ys. The -2 accounts for the \cn
-nukeScrutDiscount :: ExprSize -> ExprSize
-nukeScrutDiscount (SizeIs n vs _) = SizeIs n vs (_ILIT(0))
-nukeScrutDiscount TooBig = TooBig
-
-- When we return a lambda, give a discount if it's used (applied)
lamScrutDiscount :: ExprSize -> ExprSize
lamScrutDiscount (SizeIs n vs _) = SizeIs n vs (iUnbox opt_UF_FunAppDiscount)
lamScrutDiscount TooBig = TooBig
\end{code}
+Note [addAltSize result discounts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When adding the size of alternatives, we *add* the result discounts
+too, rather than take the *maximum*. For a multi-branch case, this
+gives a discount for each branch that returns a constructor, making us
+keener to inline. I did try using 'max' instead, but it makes nofib
+'rewrite' and 'puzzle' allocate significantly more, and didn't make
+binary sizes shrink significantly either.
+
Note [Discounts and thresholds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Constants for discounts and thesholds are defined in main/StaticFlags,
\begin{code}
couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool
couldBeSmallEnoughToInline threshold rhs
- = case calcUnfoldingGuidance False threshold rhs of
+ = case calcUnfoldingGuidance False False threshold rhs of
(_, UnfNever) -> False
_ -> True
-- Look through unfoldings, but only cheap ones, because
-- we are effectively duplicating the unfolding
- | CoreUnfolding { uf_expandable = expand_me, uf_tmpl = rhs } <- unfolding
- , expand_me = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
- analyse rhs args
+ | Just rhs <- expandUnfolding_maybe unfolding
+ = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
+ analyse rhs args
where
is_saturated = count isValArg args == idArity fun
- unfolding = id_unf fun -- Does not look through loop breakers
- -- ToDo: we *may* look through variables that are NOINLINE
- -- in this phase, and that is really not right
+ unfolding = id_unf fun
analyse _ _ = Nothing
-----------
- in_scope = mkInScopeSet (exprFreeVars expr)
-
- -----------
beta (Lam v body) pairs (arg : args)
| isTypeArg arg
= beta body ((v,arg):pairs) args
Just ans -> -- pprTrace "Woo-hoo! exprIsConApp_maybe" doc $
Just ans
where
- subst = mkOpenSubst in_scope pairs
+ subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs
-- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]
projects / ghc-hetmet.git / blobdiff