X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUnfold.lhs;h=e54acc0f1038dd39651ffe381b9fea2b699baa12;hp=0a398d1bebcd4831f3caabc6c332a79e73c7c379;hb=e55d6fa8fcab24a7a072688a19b2e68e09c7f585;hpb=65d9413573466e789ba2b1c5c7c74339df0f16ed diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 0a398d1..e54acc0 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -19,8 +19,9 @@ module CoreUnfold ( Unfolding, UnfoldingGuidance, -- Abstract types noUnfolding, mkImplicitUnfolding, - mkTopUnfolding, mkUnfolding, mkCoreUnfolding, - mkInlineRule, mkWwInlineRule, + mkUnfolding, mkCoreUnfolding, + mkTopUnfolding, mkSimpleUnfolding, + mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule, mkCompulsoryUnfolding, mkDFunUnfolding, interestingArg, ArgSummary(..), @@ -44,7 +45,7 @@ import TcType ( tcSplitSigmaTy, tcSplitDFunHead ) import OccurAnal import CoreSubst hiding( substTy ) import CoreFVs ( exprFreeVars ) -import CoreArity ( manifestArity ) +import CoreArity ( manifestArity, exprBotStrictness_maybe ) import CoreUtils import Id import DataCon @@ -63,7 +64,7 @@ import Util import FastTypes import FastString import Outputable - +import Data.Maybe \end{code} @@ -75,8 +76,7 @@ import Outputable \begin{code} mkTopUnfolding :: Bool -> CoreExpr -> Unfolding -mkTopUnfolding is_bottoming expr - = mkUnfolding True {- Top level -} is_bottoming expr +mkTopUnfolding = mkUnfolding InlineRhs True {- Top level -} mkImplicitUnfolding :: CoreExpr -> Unfolding -- For implicit Ids, do a tiny bit of optimising first @@ -88,44 +88,8 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr) -- top-level flag to True. It gets set more accurately by the simplifier -- Simplify.simplUnfolding. -mkUnfolding :: Bool -> Bool -> CoreExpr -> Unfolding -mkUnfolding top_lvl is_bottoming expr - = 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 - is_cheap = exprIsCheap 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 - -- Nevertheless, we *don't* occ-analyse before computing the size because the - -- size computation bales out after a while, whereas occurrence analysis does not. - -- - -- This can occasionally mean that the guidance is very pessimistic; - -- 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 -> UnfoldingSource -> CoreExpr - -> Arity -> UnfoldingGuidance -> Unfolding --- Occurrence-analyses the expression before capturing it -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, - uf_is_conlike = exprIsConLike expr, - uf_is_cheap = exprIsCheap expr, - uf_expandable = exprIsExpandable expr, - uf_guidance = guidance } +mkSimpleUnfolding :: CoreExpr -> Unfolding +mkSimpleUnfolding = mkUnfolding InlineRhs False False mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding mkDFunUnfolding dfun_ty ops @@ -140,20 +104,21 @@ mkDFunUnfolding dfun_ty ops mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding mkWwInlineRule id expr arity - = mkCoreUnfolding True (InlineWrapper id) + = mkCoreUnfolding (InlineWrapper id) True (simpleOptExpr expr) arity (UnfWhen unSaturatedOk boringCxtNotOk) mkCompulsoryUnfolding :: CoreExpr -> Unfolding mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = mkCoreUnfolding True InlineCompulsory + = mkCoreUnfolding InlineCompulsory True expr 0 -- Arity of unfolding doesn't matter (UnfWhen unSaturatedOk boringCxtOk) -mkInlineRule :: CoreExpr -> Maybe Arity -> Unfolding -mkInlineRule expr mb_arity - = mkCoreUnfolding True InlineRule -- Note [Top-level flag on inline rules] - expr' arity +mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding +mkInlineUnfolding mb_arity expr + = mkCoreUnfolding InlineStable + True -- Note [Top-level flag on inline rules] + expr' arity (UnfWhen unsat_ok boring_ok) where expr' = simpleOptExpr expr @@ -167,8 +132,59 @@ mkInlineRule expr mb_arity (_, UnfWhen _ boring_ok) -> boring_ok _other -> boringCxtNotOk -- See Note [INLINE for small functions] + +mkInlinableUnfolding :: CoreExpr -> Unfolding +mkInlinableUnfolding expr + = mkUnfolding InlineStable True is_bot expr' + where + expr' = simpleOptExpr expr + is_bot = isJust (exprBotStrictness_maybe expr') \end{code} +Internal functions + +\begin{code} +mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr + -> Arity -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding src top_lvl expr arity guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + uf_src = src, + uf_arity = arity, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_is_cheap = exprIsCheap expr, + uf_expandable = exprIsExpandable expr, + uf_guidance = guidance } + +mkUnfolding :: UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding +-- Calculates unfolding guidance +-- Occurrence-analyses the expression before capturing it +mkUnfolding src top_lvl is_bottoming expr + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + uf_src = src, + 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 + is_cheap = exprIsCheap 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 + -- Nevertheless, we *don't* occ-analyse before computing the size because the + -- size computation bales out after a while, whereas occurrence analysis does not. + -- + -- This can occasionally mean that the guidance is very pessimistic; + -- it gets fixed up next round. And it should be rare, because large + -- let-bound things that are dead are usually caught by preInlineUnconditionally +\end{code} %************************************************************************ %* * @@ -855,7 +871,7 @@ But the defn of GHC.Classes.$dmmin is: {- Arity: 3, HasNoCafRefs, Strictness: SLL, Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> case @ a GHC.Classes.<= @ a $dOrd x y of wild { - GHC.Bool.False -> y GHC.Bool.True -> x }) -} + GHC.Types.False -> y GHC.Types.True -> x }) -} We *really* want to inline $dmmin, even though it has arity 3, in order to unravel the recursion. @@ -1112,7 +1128,7 @@ interestingArg e = go e 0 go (Note _ a) n = go a n go (Cast e _) n = go e n go (Lam v e) n - | isTyVar v = go e n + | isTyCoVar v = go e n | n>0 = go e (n-1) | otherwise = ValueArg go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg } @@ -1147,13 +1163,14 @@ However e might not *look* as if -- where t1..tk are the *universally-qantified* type args of 'dc' exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) -exprIsConApp_maybe id_unf (Note _ expr) +exprIsConApp_maybe id_unf (Note note expr) + | notSccNote note = exprIsConApp_maybe id_unf expr - -- We ignore all notes. For example, + -- We ignore all notes except SCCs. For example, -- case _scc_ "foo" (C a b) of -- C a b -> e - -- should be optimised away, but it will be only if we look - -- through the SCC note. + -- should not be optimised away, because we'll lose the + -- entry count on 'foo'; see Trac #4414 exprIsConApp_maybe id_unf (Cast expr co) = -- Here we do the KPush reduction rule as described in the FC paper @@ -1292,4 +1309,4 @@ Note [DFun arity check] ~~~~~~~~~~~~~~~~~~~~~~~ Here we check that the total number of supplied arguments (inclding type args) matches what the dfun is expecting. This may be *less* -than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn \ No newline at end of file +than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn