Commit 62af0377 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Miscellaneous tidying up and refactoring

parent 05fecd15
......@@ -26,7 +26,7 @@ module CoreUnfold (
interestingArg, ArgSummary(..),
couldBeSmallEnoughToInline,
couldBeSmallEnoughToInline, inlineBoringOk,
certainlyWillInline, smallEnoughToInline,
callSiteInline, CallCtxt(..),
......@@ -126,12 +126,7 @@ mkInlineUnfolding mb_arity expr
Nothing -> (unSaturatedOk, manifestArity expr')
Just ar -> (needSaturated, ar)
boring_ok = case calcUnfoldingGuidance True -- Treat as cheap
False -- But not bottoming
(arity+1) expr' of
(_, UnfWhen _ boring_ok) -> boring_ok
_other -> boringCxtNotOk
-- See Note [INLINE for small functions]
boring_ok = inlineBoringOk expr'
mkInlinableUnfolding :: CoreExpr -> Unfolding
mkInlinableUnfolding expr
......@@ -162,6 +157,10 @@ mkUnfolding :: UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding
-- Calculates unfolding guidance
-- Occurrence-analyses the expression before capturing it
mkUnfolding src top_lvl is_bottoming expr
| top_lvl && is_bottoming
, not (exprIsTrivial expr)
= NoUnfolding -- See Note [Do not inline top-level bottoming functions]
| otherwise
= CoreUnfolding { uf_tmpl = occurAnalyseExpr expr,
uf_src = src,
uf_arity = arity,
......@@ -173,7 +172,7 @@ mkUnfolding src top_lvl is_bottoming expr
uf_guidance = guidance }
where
is_cheap = exprIsCheap expr
(arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming)
(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
......@@ -193,15 +192,35 @@ mkUnfolding src top_lvl is_bottoming expr
%************************************************************************
\begin{code}
inlineBoringOk :: CoreExpr -> Bool
-- See Note [INLINE for small functions]
-- True => the result of inlining the expression is
-- no bigger than the expression itself
-- eg (\x y -> f y x)
-- This is a quick and dirty version. It doesn't attempt
-- to deal with (\x y z -> x (y z))
-- The really important one is (x `cast` c)
inlineBoringOk e
= go 0 e
where
go :: Int -> CoreExpr -> Bool
go credit (Lam x e) | isId x = go (credit+1) e
| otherwise = go credit e
go credit (App f (Type {})) = go credit f
go credit (App f a) | credit > 0
, exprIsTrivial a = go (credit-1) f
go credit (Note _ e) = go credit e
go credit (Cast e _) = go credit e
go _ (Var {}) = boringCxtOk
go _ _ = 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 top_bot bOMB_OUT_SIZE expr
calcUnfoldingGuidance expr_is_cheap bOMB_OUT_SIZE expr
= case collectBinders expr of { (bndrs, body) ->
let
val_bndrs = filter isId bndrs
......@@ -214,9 +233,6 @@ calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr
| uncondInline n_val_bndrs (iBox size)
, expr_is_cheap
-> UnfWhen unSaturatedOk boringCxtOk -- Note [INLINE for small functions]
| 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
......
......@@ -28,9 +28,7 @@ import CoreMonad ( Tick(..), SimplifierMode(..) )
import CoreSyn
import Demand ( isStrictDmd )
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, mkCoreUnfolding
, mkInlineUnfolding, mkSimpleUnfolding
, exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
import CoreUnfold
import CoreUtils
import qualified CoreSubst
import CoreArity
......@@ -638,7 +636,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs
-- Simplify the unfolding
; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info final_rhs old_unf
; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf
; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding
-- Inline and discard the binding
......@@ -678,7 +676,7 @@ addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
-- opportunity to inline 'y' too.
addPolyBind top_lvl env (NonRec poly_id rhs)
= do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding
= do { unfolding <- simplUnfolding env top_lvl poly_id rhs noUnfolding
-- Assumes that poly_id did not have an INLINE prag
-- which is perhaps wrong. ToDo: think about this
; let final_id = setIdInfo poly_id $
......@@ -695,16 +693,16 @@ addPolyBind _ env bind@(Rec _)
------------------------------
simplUnfolding :: SimplEnv-> TopLevelFlag
-> Id
-> OccInfo -> OutExpr
-> InId
-> OutExpr
-> Unfolding -> SimplM Unfolding
-- Note [Setting the new unfolding]
simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
simplUnfolding env _ _ _ (DFunUnfolding ar con ops)
= return (DFunUnfolding ar con ops')
where
ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops
simplUnfolding env top_lvl id _ _
simplUnfolding env top_lvl id _
(CoreUnfolding { uf_tmpl = expr, uf_arity = arity
, uf_src = src, uf_guidance = guide })
| isStableSource src
......@@ -712,36 +710,46 @@ simplUnfolding env top_lvl id _ _
; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
is_top_lvl = isTopLevel top_lvl
; case guide of
UnfIfGoodArgs{} ->
-- We need to force bottoming, or the new unfolding holds
-- on to the old unfolding (which is part of the id).
let bottoming = isBottomingId id
in bottoming `seq` return (mkUnfolding src' is_top_lvl bottoming expr')
UnfWhen sat_ok _ -- Happens for INLINE things
-> let guide' = UnfWhen sat_ok (inlineBoringOk expr')
-- Refresh the boring-ok flag, in case expr'
-- has got small. This happens, notably in the inlinings
-- for dfuns for single-method classes; see
-- Note [Single-method classes] in TcInstDcls.
-- A test case is Trac #4138
in return (mkCoreUnfolding src' is_top_lvl expr' arity guide')
-- See Note [Top-level flag on inline rules] in CoreUnfold
_other -- Happens for INLINABLE things
-> let bottoming = isBottomingId id
in bottoming `seq` -- See Note [Force bottoming field]
return (mkUnfolding src' is_top_lvl bottoming expr')
-- If the guidance is UnfIfGoodArgs, this is an INLINABLE
-- unfolding, and we need to make sure the guidance is kept up
-- to date with respect to any changes in the unfolding.
_other ->
return (mkCoreUnfolding src' is_top_lvl expr' arity guide)
-- See Note [Top-level flag on inline rules] in CoreUnfold
}
where
act = idInlineActivation id
rule_env = updMode (updModeForInlineRules act) env
-- See Note [Simplifying inside InlineRules] in SimplUtils
simplUnfolding _ top_lvl id _occ_info new_rhs _
= -- We need to force bottoming, or the new unfolding holds
-- on to the old unfolding (which is part of the id).
let bottoming = isBottomingId id
in bottoming `seq` return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs)
-- We make an unfolding *even for loop-breakers*.
-- Reason: (a) It might be useful to know that they are WHNF
-- (b) In TidyPgm we currently assume that, if we want to
-- expose the unfolding then indeed we *have* an unfolding
-- to expose. (We could instead use the RHS, but currently
-- we don't.) The simple thing is always to have one.
simplUnfolding _ top_lvl id new_rhs _
= let bottoming = isBottomingId id
in bottoming `seq` -- See Note [Force bottoming field]
return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs)
-- We make an unfolding *even for loop-breakers*.
-- Reason: (a) It might be useful to know that they are WHNF
-- (b) In TidyPgm we currently assume that, if we want to
-- expose the unfolding then indeed we *have* an unfolding
-- to expose. (We could instead use the RHS, but currently
-- we don't.) The simple thing is always to have one.
\end{code}
Note [Force bottoming field]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to force bottoming, or the new unfolding holds
on to the old unfolding (which is part of the id).
Note [Arity decrease]
~~~~~~~~~~~~~~~~~~~~~
Generally speaking the arity of a binding should not decrease. But it *can*
......@@ -1052,6 +1060,19 @@ simplCast env body co0 cont0
%* *
%************************************************************************
Note [Zap unfolding when beta-reducing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Lambda-bound variables can have stable unfoldings, such as
$j = \x. \b{Unf=Just x}. e
See Note [Case binders and join points] below; the unfolding for lets
us optimise e better. However when we beta-reduce it we want to
revert to using the actual value, otherwise we can end up in the
stupid situation of
let x = blah in
let b{Unf=Just x} = y
in ...b...
Here it'd be far better to drop the unfolding and use the actual RHS.
\begin{code}
simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
-> SimplM (SimplEnv, OutExpr)
......@@ -1061,7 +1082,12 @@ simplLam env [] body cont = simplExprF env body cont
-- Beta reduction
simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
= do { tick (BetaReduction bndr)
; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont }
; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont }
where
zap_unfolding bndr -- See Note [Zap unfolding when beta-reducing]
| isId bndr, isStableUnfolding (realIdUnfolding bndr)
= setIdUnfolding bndr NoUnfolding
| otherwise = bndr
-- Not enough args, so there are real lambdas left to put in the result
simplLam env bndrs body cont
......
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