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}
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,
+ smallEnoughToInline, couldBeSmallEnoughToInline,
+ certainlySmallEnoughToInline, inlineUnconditionally, okToInline,
+ okToUnfoldInHiFile,
- calcUnfoldingGuidance,
-
- PragmaInfo(..) -- Re-export
+ calcUnfoldingGuidance
) where
#include "HsVersions.h"
import {-# SOURCE #-} MagicUFs ( MagicUnfoldingFun, mkMagicUnfoldingFun )
-import Bag ( emptyBag, unitBag, unionBags, Bag )
-
import CmdLineOpts ( opt_UnfoldingCreationThreshold,
opt_UnfoldingUseThreshold,
opt_UnfoldingConDiscount,
- opt_UnfoldingKeenessFactor
+ opt_UnfoldingKeenessFactor,
+ opt_UnfoldCasms
)
import Constants ( uNFOLDING_CHEAP_OP_COST,
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 Id ( Id, idType, getIdArity, isBottomingId, isDataCon,
idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
- IdSet, GenId{-instances-} )
-import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
-import IdInfo ( ArityInfo(..), bottomIsGuaranteed )
+ IdSet )
+import PrimOp ( fragilePrimOp, primOpCanTriggerGC, PrimOp(..) )
+import IdInfo ( ArityInfo(..), InlinePragInfo(..) )
+import Name ( isExported )
import Literal ( isNoRepLit, isLitLitLit )
import TyCon ( tyConFamilySize )
import Type ( splitAlgTyConApp_maybe )
import Unique ( Unique )
-import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
- addOneToUniqSet, unionUniqSets
- )
-import Maybes ( maybeToBool )
import Util ( isIn, panic, assertPanic )
import Outputable
\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
+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"
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 fun of
\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
+calcUnfoldingGuidance bOMB_OUT_SIZE expr
= case collectBinders expr of { (ty_binders, val_binders, body) ->
case (sizeExpr bOMB_OUT_SIZE val_binders body) of
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;
= 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)
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
| 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
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}
+
+@okToUnfoldInHifile@ is used when emitting unfolding info into an interface
+file to determine whether an unfolding candidate really should be unfolded.
+The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
+into interface files.
+
+The reason for inlining expressions containing _casm_s into interface files
+is that these fragments of C are likely to mention functions/#defines that
+will be out-of-scope when inlined into another module. This is not an
+unfixable problem for the user (just need to -#include the approp. header
+file), but turning it off seems to the simplest thing to do.
+
+\begin{code}
+okToUnfoldInHiFile :: CoreExpr -> Bool
+okToUnfoldInHiFile e = opt_UnfoldCasms || go e
+ where
+ -- Race over an expression looking for CCalls..
+ go (Var _) = True
+ go (Lit lit) = not (isLitLitLit lit)
+ go (Note _ body) = go body
+ go (App fun arg) = go fun
+ go (Con con args) = True
+ go (Prim op args) = okToUnfoldPrimOp op
+ go (Lam _ body) = go body
+ go (Let (NonRec binder rhs) body) = go rhs && go body
+ go (Let (Rec pairs) body) = and (map go (body:rhses))
+ where
+ rhses = [ rhs | (_, rhs) <- pairs ]
+ go (Case scrut alts) = and (map go (scrut:rhses))
+ where
+ rhses = getAltRhs alts
+
+ getAltRhs (PrimAlts alts deflt) =
+ let ls = map snd alts in
+ case deflt of
+ NoDefault -> ls
+ BindDefault _ rhs -> rhs:ls
+ getAltRhs (AlgAlts alts deflt) =
+ let ls = map (\ (_,_,r) -> r) alts in
+ case deflt of
+ NoDefault -> ls
+ BindDefault _ rhs -> rhs:ls
+
+ -- ok to unfold a PrimOp as long as it's not a _casm_
+ okToUnfoldPrimOp (CCallOp _ is_casm _ _ _ _) = not is_casm
+ okToUnfoldPrimOp _ = True
+
+\end{code}
projects / ghc-hetmet.git / blobdiff