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,
- inlineUnconditionally,
-
- calcUnfoldingGuidance,
+ smallEnoughToInline, couldBeSmallEnoughToInline,
+ certainlySmallEnoughToInline, inlineUnconditionally, okToInline,
- PragmaInfo(..) -- Re-export
+ calcUnfoldingGuidance
) 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,
uNFOLDING_DEAR_OP_COST,
uNFOLDING_NOREP_LIT_COST
)
-import BinderInfo ( BinderInfo, isOneFunOcc, isOneSafeFunOcc
+import BinderInfo ( BinderInfo, isOneSameSCCFunOcc, isDeadOcc,
+ isInlinableOcc, 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,
+import Id ( Id, idType, getIdArity, isBottomingId, isDataCon,
idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
- SYN_IE(IdSet), GenId{-instances-} )
-import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
-import IdInfo ( ArityInfo(..), bottomIsGuaranteed )
-import Literal ( isNoRepLit, isLitLitLit )
-import Pretty
+ IdSet )
+import PrimOp ( fragilePrimOp, primOpCanTriggerGC )
+import IdInfo ( ArityInfo(..), InlinePragInfo(..) )
+import Name ( isExported )
+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 UniqFM
import Outputable
-#endif
+import List ( maximumBy )
+import GlaExts --tmp
\end{code}
%************************************************************************
data Unfolding
= NoUnfolding
- | CoreUnfolding SimpleUnfolding
+ | OtherLit [Literal] -- It ain't one of these
+ | OtherCon [Id] -- It ain't one of these
- | MagicUnfolding
- Unique -- Unique of the Id whose magic unfolding this is
- MagicUnfoldingFun
-
-
-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
+mkUnfolding expr
= let
-- strictness mangling (depends on there being no CSE)
- ufg = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold expr
+ ufg = calcUnfoldingGuidance 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
go n (Lit _) = ASSERT(n==0) ValueForm
go n (Con _ _) = ASSERT(n==0) ValueForm
go n (Prim _ _) = OtherForm
- go n (SCC _ e) = go n e
- go n (Coerce _ _ e) = go n e
+ go n (Note _ e) = go n e
go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g)
-- should be treated as a value
exprIsTrivial (Var v) = True
exprIsTrivial (Lit lit) = not (isNoRepLit lit)
exprIsTrivial (App e (TyArg _)) = exprIsTrivial e
-exprIsTrivial (Coerce _ _ e) = exprIsTrivial e
+exprIsTrivial (Note _ e) = exprIsTrivial e
exprIsTrivial other = False
\end{code}
exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
-exprSmallEnoughToDup (Coerce _ _ e) = exprSmallEnoughToDup e
+exprSmallEnoughToDup (Note _ 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
\begin{code}
calcUnfoldingGuidance
- :: PragmaInfo -- INLINE pragma stuff
- -> Int -- bomb out if size gets bigger than this
+ :: Int -- bomb out if size gets bigger than this
-> CoreExpr -- expression to look at
-> UnfoldingGuidance
-calcUnfoldingGuidance IMustBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
-calcUnfoldingGuidance IWantToBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
-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) ->
+calcUnfoldingGuidance bOMB_OUT_SIZE expr
+ = case collectBinders expr of { (ty_binders, val_binders, body) ->
case (sizeExpr bOMB_OUT_SIZE val_binders body) of
TooBig -> UnfoldNever
SizeIs size cased_args scrut_discount
- -> UnfoldIfGoodArgs
+ -> {- trace ("calcUnfoldingGuidance: \n" ++ showSDoc (ppr expr) ++ "\n"
+ ++ show (I# size) ++ "\n" ++ show (map discount_for val_binders)) $ -}
+ UnfoldIfGoodArgs
(length ty_binders)
(length val_binders)
(map discount_for val_binders)
(I# scrut_discount)
where
discount_for b
- | is_data && b `is_elem` cased_args = tyConFamilySize tycon
+ | is_data = case lookupUFM cased_args b of
+ Nothing -> 0
+ Just d -> d
| 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)
-
- is_elem = isIn "calcUnfoldingGuidance" }
+ }
\end{code}
\begin{code}
size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
| otherwise = sizeZero
- size_up (SCC lbl body) = size_up body -- SCCs cost nothing
- size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing
+ size_up (Note _ body) = size_up body -- Notes cost nothing
size_up (App fun arg) = size_up fun `addSize` size_up_arg arg
-- NB Zero cost for for type applications;
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)
`addSize`
- arg_discount scrut
- `addSize`
- size_up_alts (coreExprType scrut) alts
+ size_up_alts scrut (coreExprType scrut) alts
-- We charge for the "case" itself in "size_up_alts"
------------
size_up_arg other = sizeOne
------------
- size_up_alts scrut_ty (AlgAlts alts deflt)
- = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts)
+ size_up_alts scrut scrut_ty (AlgAlts alts deflt)
+ = total_size
+ `addSize`
+ scrut_discount scrut
`addSizeN`
alt_cost
where
+ alts_sizes = size_up_deflt deflt : map size_alg_alt alts
+ total_size = foldr addSize sizeZero alts_sizes
+
+ biggest_alt = maximumBy (\a b -> if ltSize a b then b else a) alts_sizes
+
+ scrut_discount (Var v) | v `is_elem` args =
+ scrutArg v (minusSize total_size biggest_alt + alt_cost)
+ scrut_discount _ = sizeZero
+
+
size_alg_alt (con,args,rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
alt_cost :: Int
alt_cost
- = case (maybeAppDataTyConExpandingDicts scrut_ty) of
+ = case (splitAlgTyConApp_maybe scrut_ty) of
Nothing -> 1
Just (tc,_,_) -> tyConFamilySize tc
- size_up_alts _ (PrimAlts alts deflt)
+ size_up_alts _ _ (PrimAlts alts deflt)
= foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
-- *no charge* for a primitive "case"!
where
size_up_deflt (BindDefault binder rhs) = size_up rhs
------------
- -- We want to record if we're case'ing an argument
- arg_discount (Var v) | v `is_elem` args = scrutArg v
- arg_discount other = sizeZero
-
is_elem :: Id -> [Id] -> Bool
is_elem = isIn "size_up_scrut"
where
n_tot = n +# m
+ -- trying to find a reasonable discount for eliminating this case.
+ -- if the case is eliminated, in the worse case we end up with the
+ -- largest alternative, so subtract the size of the largest alternative
+ -- from the total size of the case to end up with the discount
+ minusSize TooBig _ = 0
+ minusSize _ TooBig = panic "CoreUnfold: minusSize" -- shouldn't happen
+ minusSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) = I# (n1 -# n2)
+
addSize TooBig _ = TooBig
addSize _ TooBig = TooBig
addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
where
n_tot = n1 +# n2
d_tot = d1 +# d2
- xys = xs ++ ys
+ xys = combineArgDiscounts xs ys
+
\end{code}
data ExprSize = TooBig
| SizeIs Int# -- Size found
- [Id] -- Arguments cased herein
+ (UniqFM Int) -- discount for each argument
Int# -- Size to subtract if result is scrutinised
-- by a case expression
-sizeZero = SizeIs 0# [] 0#
-sizeOne = SizeIs 1# [] 0#
-sizeN (I# n) = SizeIs n [] 0#
-conSizeN (I# n) = SizeIs n [] n
-scrutArg v = SizeIs 0# [v] 0#
+ltSize a TooBig = True
+ltSize TooBig a = False
+ltSize (SizeIs s1# _ _) (SizeIs s2# _ _) = s1# <=# s2#
+
+sizeZero = SizeIs 0# emptyUFM 0#
+sizeOne = SizeIs 1# emptyUFM 0#
+sizeN (I# n) = SizeIs n emptyUFM 0#
+conSizeN (I# n) = SizeIs n emptyUFM n
+scrutArg v d = SizeIs 0# (unitUFM v d) 0#
nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
nukeScrutDiscount TooBig = TooBig
+
+combineArgDiscounts :: UniqFM Int -> UniqFM Int -> UniqFM Int
+combineArgDiscounts = plusUFM_C (+)
\end{code}
%************************************************************************
is computed).
\begin{code}
-smallEnoughToInline :: [Bool] -- Evaluated-ness of value arguments
+smallEnoughToInline :: Id -- The function (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 &&
- size - discount <= 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
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
+ arg_discount discount is_evald
+ | is_evald = discount
+ | 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
rule this out. Since ManyOcc doesn't record FunOcc/ArgOcc
\begin{code}
-inlineUnconditionally :: Bool -> Id -> BinderInfo -> Bool
+inlineUnconditionally :: (Id,BinderInfo) -> Bool
-inlineUnconditionally ok_to_dup id occ_info
- | idMustNotBeINLINEd id = False
+inlineUnconditionally (id, occ_info)
+ | idMustNotBeINLINEd id
+ || isExported id
+ = False
- | isOneFunOcc occ_info
- && idMustBeINLINEd id = True
+ | isOneSameSCCFunOcc occ_info
+ && idWantsToBeINLINEd id = True
- | isOneSafeFunOcc (ok_to_dup || idWantsToBeINLINEd id) occ_info
+ | isOneSafeFunOcc occ_info
= True
| otherwise
= False
\end{code}
+
+okToInline is used at call sites, so it is a bit more generous
+
+\begin{code}
+okToInline :: Id -- The Id
+ -> Bool -- The thing is WHNF or bottom;
+ -> Bool -- It's small enough to duplicate the code
+ -> BinderInfo
+ -> Bool -- True <=> inline it
+
+okToInline id _ _ _ -- Check the Id first
+ | idWantsToBeINLINEd id = True
+ | idMustNotBeINLINEd id = False
+
+okToInline id whnf small binder_info
+#ifdef DEBUG
+ | isDeadOcc binder_info
+ = pprTrace "okToInline: dead" (ppr id) False
+ | otherwise
+#endif
+ = isInlinableOcc whnf small binder_info
+\end{code}
projects / ghc-hetmet.git / blobdiff