The type @Unfolding@ sits ``above'' simply-Core-expressions
unfoldings, capturing ``higher-level'' things we know about a binding,
usually things that the simplifier found out (e.g., ``it's a
-literal''). In the corner of a @SimpleUnfolding@ unfolding, you will
+literal''). In the corner of a @CoreUnfolding@ unfolding, you will
find, unsurprisingly, a Core expression.
\begin{code}
-#include "HsVersions.h"
-
module CoreUnfold (
- SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
- UfExpr, RdrName, -- For closure (delete in 1.3)
+ Unfolding(..), UnfoldingGuidance(..), -- types
- FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup, exprIsTrivial,
+ FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
+ exprIsTrivial,
noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
- smallEnoughToInline, couldBeSmallEnoughToInline, certainlySmallEnoughToInline,
- okToInline,
+ smallEnoughToInline, couldBeSmallEnoughToInline,
+ certainlySmallEnoughToInline, inlineUnconditionally,
calcUnfoldingGuidance,
PragmaInfo(..) -- Re-export
) where
-IMP_Ubiq()
-#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(IdLoop) -- for paranoia checking;
- -- and also to get mkMagicUnfoldingFun
-IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
-IMPORT_DELOOPER(SmplLoop)
-#else
-import {-# SOURCE #-} MagicUFs
-#endif
+#include "HsVersions.h"
-import Bag ( emptyBag, unitBag, unionBags, Bag )
+import {-# SOURCE #-} MagicUFs ( MagicUnfoldingFun, mkMagicUnfoldingFun )
import CmdLineOpts ( opt_UnfoldingCreationThreshold,
opt_UnfoldingUseThreshold,
- opt_UnfoldingConDiscount
+ opt_UnfoldingConDiscount,
+ opt_UnfoldingKeenessFactor
)
import Constants ( uNFOLDING_CHEAP_OP_COST,
uNFOLDING_DEAR_OP_COST,
uNFOLDING_NOREP_LIT_COST
)
-import BinderInfo ( BinderInfo(..), FunOrArg, DuplicationDanger, InsideSCC, isDupDanger )
+import BinderInfo ( BinderInfo, isOneFunOcc, isOneSafeFunOcc
+ )
import PragmaInfo ( PragmaInfo(..) )
import CoreSyn
+import Literal ( Literal )
import CoreUtils ( unTagBinders )
-import HsCore ( UfExpr )
-import RdrHsSyn ( RdrName )
import OccurAnal ( occurAnalyseGlobalExpr )
import CoreUtils ( coreExprType )
---import CostCentre ( ccMentionsId )
-import Id ( SYN_IE(Id), idType, getIdArity, isBottomingId, isDataCon, --rm: isPrimitiveId_maybe,
- SYN_IE(IdSet), GenId{-instances-} )
-import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
-import IdInfo ( ArityInfo(..), bottomIsGuaranteed )
-import Literal ( isNoRepLit, isLitLitLit )
-import Pretty
+import Id ( Id, idType, getIdArity, isBottomingId, isDataCon,
+ idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
+ IdSet, GenId{-instances-} )
+import PrimOp ( fragilePrimOp, primOpCanTriggerGC )
+import IdInfo ( ArityInfo(..) )
+import Literal ( isNoRepLit )
import TyCon ( tyConFamilySize )
-import Type ( maybeAppDataTyConExpandingDicts )
+import Type ( splitAlgTyConApp_maybe )
import Unique ( Unique )
-import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
- addOneToUniqSet, unionUniqSets
- )
-import Usage ( SYN_IE(UVar) )
-import Maybes ( maybeToBool )
import Util ( isIn, panic, assertPanic )
-#if __GLASGOW_HASKELL__ >= 202
import Outputable
-
-#endif
\end{code}
%************************************************************************
data Unfolding
= NoUnfolding
- | CoreUnfolding SimpleUnfolding
-
- | MagicUnfolding
- Unique -- Unique of the Id whose magic unfolding this is
- MagicUnfoldingFun
-
+ | OtherLit [Literal] -- It ain't one of these
+ | OtherCon [Id] -- It ain't one of these
-data SimpleUnfolding
- = SimpleUnfolding -- An unfolding with redundant cached information
+ | CoreUnfolding -- An unfolding with redundant cached information
FormSummary -- Tells whether the template is a WHNF or bottom
UnfoldingGuidance -- Tells about the *size* of the template.
SimplifiableCoreExpr -- Template
+ | MagicUnfolding
+ Unique -- Unique of the Id whose magic unfolding this is
+ MagicUnfoldingFun
+\end{code}
+\begin{code}
noUnfolding = NoUnfolding
mkUnfolding inline_prag expr
-- strictness mangling (depends on there being no CSE)
ufg = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold expr
occ = occurAnalyseGlobalExpr expr
- cuf = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) ufg occ)
+ cuf = CoreUnfolding (mkFormSummary expr) ufg occ
cont = case occ of { Var _ -> cuf; _ -> cuf }
in
mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag)
getUnfoldingTemplate :: Unfolding -> CoreExpr
-getUnfoldingTemplate (CoreUnfolding (SimpleUnfolding _ _ expr))
+getUnfoldingTemplate (CoreUnfolding _ _ expr)
= unTagBinders expr
getUnfoldingTemplate other = panic "getUnfoldingTemplate"
\begin{code}
instance Outputable UnfoldingGuidance where
- ppr sty UnfoldAlways = ptext SLIT("_ALWAYS_")
- ppr sty (UnfoldIfGoodArgs t v cs size discount)
+ ppr UnfoldAlways = ptext SLIT("_ALWAYS_")
+ ppr (UnfoldIfGoodArgs t v cs size discount)
= hsep [ptext SLIT("_IF_ARGS_"), int t, int v,
if null cs -- always print *something*
then char 'X'
| OtherForm -- Anything else
instance Outputable FormSummary where
- ppr sty VarForm = ptext SLIT("Var")
- ppr sty ValueForm = ptext SLIT("Value")
- ppr sty BottomForm = ptext SLIT("Bot")
- ppr sty OtherForm = ptext SLIT("Other")
+ ppr VarForm = ptext SLIT("Var")
+ ppr ValueForm = ptext SLIT("Value")
+ ppr BottomForm = ptext SLIT("Bot")
+ ppr OtherForm = ptext SLIT("Other")
-mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary
+mkFormSummary ::GenCoreExpr bndr Id flexi -> FormSummary
mkFormSummary expr
= go (0::Int) expr -- The "n" is the number of (value) arguments so far
ArityAtLeast a | n < a -> ValueForm
other -> OtherForm
-whnfOrBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
-whnfOrBottom e = case mkFormSummary e of
- VarForm -> True
- ValueForm -> True
- BottomForm -> True
- OtherForm -> False
+whnfOrBottom :: FormSummary -> Bool
+whnfOrBottom VarForm = True
+whnfOrBottom ValueForm = True
+whnfOrBottom BottomForm = True
+whnfOrBottom OtherForm = False
\end{code}
@exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate;
exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
exprSmallEnoughToDup (Coerce _ _ e) = exprSmallEnoughToDup e
exprSmallEnoughToDup expr
- = case (collectArgs expr) of { (fun, _, _, vargs) ->
+ = case (collectArgs expr) of { (fun, _, vargs) ->
case fun of
Var v | length vargs <= 4 -> True
_ -> False
calcUnfoldingGuidance IMustNotBeINLINEd bOMB_OUT_SIZE expr = UnfoldNever -- ...and vice versa...
calcUnfoldingGuidance NoPragmaInfo bOMB_OUT_SIZE expr
- = case collectBinders expr of { (use_binders, ty_binders, val_binders, body) ->
+ = case collectBinders expr of { (ty_binders, val_binders, body) ->
case (sizeExpr bOMB_OUT_SIZE val_binders body) of
TooBig -> UnfoldNever
| otherwise = 0
where
(is_data, tycon)
- = case (maybeAppDataTyConExpandingDicts (idType b)) of
+ = case (splitAlgTyConApp_maybe (idType b)) of
Nothing -> (False, panic "discount")
Just (tc,_,_) -> (True, tc)
size_up expr@(Lam _ _)
= let
- (uvars, tyvars, args, body) = collectBinders expr
+ (tyvars, args, body) = collectBinders expr
in
size_up body `addSizeN` length args
= nukeScrutDiscount (size_up rhs)
`addSize`
size_up body
+ `addSizeN`
+ 1 -- For the allocation
size_up (Let (Rec pairs) body)
= nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs])
`addSize`
size_up body
+ `addSizeN`
+ length pairs -- For the allocation
size_up (Case scrut alts)
= nukeScrutDiscount (size_up scrut)
alt_cost :: Int
alt_cost
- = case (maybeAppDataTyConExpandingDicts scrut_ty) of
+ = case (splitAlgTyConApp_maybe scrut_ty) of
Nothing -> 1
Just (tc,_,_) -> tyConFamilySize tc
is computed).
\begin{code}
-smallEnoughToInline :: [Bool] -- Evaluated-ness of value arguments
+smallEnoughToInline :: Id -- The function (for trace msg only)
+ -> [Bool] -- Evaluated-ness of value arguments
-> Bool -- Result is scrutinised
-> UnfoldingGuidance
-> Bool -- True => unfold it
-smallEnoughToInline _ _ UnfoldAlways = True
-smallEnoughToInline _ _ UnfoldNever = False
-smallEnoughToInline arg_is_evald_s result_is_scruted
+smallEnoughToInline _ _ _ UnfoldAlways = True
+smallEnoughToInline _ _ _ UnfoldNever = False
+smallEnoughToInline id arg_is_evald_s result_is_scruted
(UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
- = enough_args n_vals_wanted arg_is_evald_s &&
- discounted_size <= opt_UnfoldingUseThreshold
+ = if enough_args n_vals_wanted arg_is_evald_s &&
+ size - discount <= opt_UnfoldingUseThreshold
+ then
+ -- pprTrace "small enough" (ppr id <+> int size <+> int discount)
+ True
+ else
+ False
where
enough_args n [] | n > 0 = False -- A function with no value args => don't unfold
enough_args _ _ = True -- Otherwise it's ok to try
- discounted_size = (size - args_discount) - result_discount
+ -- We multiple the raw discounts (args_discount and result_discount)
+ -- ty opt_UnfoldingKeenessFactor because the former have to do with
+ -- *size* whereas the discounts imply that there's some extra *efficiency*
+ -- to be gained (e.g. beta reductions, case reductions) by inlining.
+ discount :: Int
+ discount = round (
+ opt_UnfoldingKeenessFactor *
+ fromInt (args_discount + result_discount)
+ )
args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
result_discount | result_is_scruted = scrut_discount
| otherwise = 0
arg_discount no_of_constrs is_evald
- | is_evald = 1 + no_of_constrs * opt_UnfoldingConDiscount
- | otherwise = 1
+ | is_evald = no_of_constrs * opt_UnfoldingConDiscount
+ | otherwise = 0
\end{code}
We use this one to avoid exporting inlinings that we ``couldn't possibly
Just the same as smallEnoughToInline, except that it has no actual arguments.
\begin{code}
---UNUSED?
-couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
-couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) True guidance
+couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
+couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance
-certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
-certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) False guidance
+certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
+certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance
\end{code}
Predicates
~~~~~~~~~~
+@inlineUnconditionally@ decides whether a let-bound thing can
+*definitely* be inlined at each of its call sites. If so, then
+we can drop the binding right away. But remember, you have to be
+certain that every use can be inlined. So, notably, any ArgOccs
+rule this out. Since ManyOcc doesn't record FunOcc/ArgOcc
+
\begin{code}
-okToInline
- :: FormSummary -- What the thing to be inlined is like
- -> BinderInfo -- How the thing to be inlined occurs
- -> Bool -- True => it's small enough to inline
- -> Bool -- True => yes, inline it
-
--- If there's no danger of duplicating work, we can inline if it occurs once, or is small
-okToInline form occ_info small_enough
- | no_dup_danger form
- = small_enough || one_occ
- where
- one_occ = case occ_info of
- OneOcc _ _ _ n_alts _ -> n_alts <= 1
- other -> False
-
- no_dup_danger VarForm = True
- no_dup_danger ValueForm = True
- no_dup_danger BottomForm = True
- no_dup_danger other = False
-
--- A non-WHNF can be inlined if it doesn't occur inside a lambda,
--- and occurs exactly once or
--- occurs once in each branch of a case and is small
-okToInline OtherForm (OneOcc _ dup_danger _ n_alts _) small_enough
- = not (isDupDanger dup_danger) && (n_alts <= 1 || small_enough)
+inlineUnconditionally :: Bool -> (Id,BinderInfo) -> Bool
-okToInline form any_occ small_enough = False
-\end{code}
+inlineUnconditionally ok_to_dup (id, occ_info)
+ | idMustNotBeINLINEd id = False
+
+ | isOneFunOcc occ_info
+ && idMustBeINLINEd id = True
+ | isOneSafeFunOcc (ok_to_dup || idWantsToBeINLINEd id) occ_info
+ = True
+
+ | otherwise
+ = False
+\end{code}
projects / ghc-hetmet.git / blobdiff