From: simonpj@microsoft.com Date: Tue, 21 Dec 2010 16:19:31 +0000 (+0000) Subject: Miscellaneous tidying up and refactoring X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=62af0377c41ffcc76ae308e07e328106846f050c Miscellaneous tidying up and refactoring --- diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 519fb74..dfbb322 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -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 diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 7222703..6bc7e0b 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -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