Commit 80989de9 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Joachim Breitner
Browse files

Improve the handling of used-once stuff

Joachim and I are committing this onto a branch so that we can share it,
but we expect to do a bit more work before merging it onto head.

Nofib staus:
  - Most programs, no change
  - A few improve
  - A couple get worse (cacheprof, tak, rfib)
Investigating the "get worse" set is what's holding up putting this
on head.

The major issue is this.  Consider

    map (f g) ys

where f's demand signature looks like

   f :: <L,C1(C1(U))> -> <L,U> -> .

So 'f' is not saturated.  What demand do we place on g?
Answer
        C(C1(U))
That is, the inner C1 should stay, even though f is not saturated.

I found that this made a significant difference in the demand signatures
inferred in GHC.IO, which uses lots of higher-order exception handlers.

I also had to add used-once demand signatures for some of the
'catch' primops, so that we know their handlers are only called once.
parent 869f69fd
......@@ -47,6 +47,11 @@ module BasicTypes(
TupleSort(..), tupleSortBoxity, boxityNormalTupleSort,
tupleParens,
-- ** The OneShotInfo type
OneShotInfo(..),
noOneShotInfo, hasNoOneShotInfo, isOneShotInfo,
bestOneShot, worstOneShot,
OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc,
isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc,
strongLoopBreaker, weakLoopBreaker,
......@@ -134,6 +139,56 @@ fIRST_TAG = 1
type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
\end{code}
%************************************************************************
%* *
One-shot information
%* *
%************************************************************************
\begin{code}
-- | If the 'Id' is a lambda-bound variable then it may have lambda-bound
-- variable info. Sometimes we know whether the lambda binding this variable
-- is a \"one-shot\" lambda; that is, whether it is applied at most once.
--
-- This information may be useful in optimisation, as computations may
-- safely be floated inside such a lambda without risk of duplicating
-- work.
data OneShotInfo = NoOneShotInfo -- ^ No information
| ProbOneShot -- ^ The lambda is probably applied at most once
| OneShotLam -- ^ The lambda is applied at most once.
-- | It is always safe to assume that an 'Id' has no lambda-bound variable information
noOneShotInfo :: OneShotInfo
noOneShotInfo = NoOneShotInfo
isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool
isOneShotInfo OneShotLam = True
isOneShotInfo _ = False
hasNoOneShotInfo NoOneShotInfo = True
hasNoOneShotInfo _ = False
worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo
worstOneShot NoOneShotInfo _ = NoOneShotInfo
worstOneShot ProbOneShot NoOneShotInfo = NoOneShotInfo
worstOneShot ProbOneShot _ = ProbOneShot
worstOneShot OneShotLam os = os
bestOneShot NoOneShotInfo os = os
bestOneShot ProbOneShot OneShotLam = OneShotLam
bestOneShot ProbOneShot _ = ProbOneShot
bestOneShot OneShotLam _ = OneShotLam
pprOneShotInfo :: OneShotInfo -> SDoc
pprOneShotInfo NoOneShotInfo = empty
pprOneShotInfo ProbOneShot = ptext (sLit "ProbOneShot")
pprOneShotInfo OneShotLam = ptext (sLit "OneShot")
instance Outputable OneShotInfo where
ppr = pprOneShotInfo
\end{code}
%************************************************************************
%* *
Swap flag
......
......@@ -1268,27 +1268,28 @@ botSig = StrictSig botDmdType
cprProdSig :: StrictSig
cprProdSig = StrictSig cprProdDmdType
argsOneShots :: StrictSig -> Arity -> [[Bool]]
argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]
argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args
| arg_ds `lengthExceeds` n_val_args
= [] -- Too few arguments
| otherwise
= go arg_ds
where
good_one_shot
| arg_ds `lengthExceeds` n_val_args = ProbOneShot
| otherwise = OneShotLam
go [] = []
go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds
go (arg_d : arg_ds) = argOneShots good_one_shot arg_d `cons` go arg_ds
cons [] [] = []
cons a as = a:as
argOneShots :: JointDmd -> [Bool]
argOneShots (JD { absd = usg })
argOneShots :: OneShotInfo -> JointDmd -> [OneShotInfo]
argOneShots one_shot_info (JD { absd = usg })
= case usg of
Use _ arg_usg -> go arg_usg
_ -> []
where
go (UCall One u) = True : go u
go (UCall Many u) = False : go u
go (UCall One u) = one_shot_info : go u
go (UCall Many u) = NoOneShotInfo : go u
go _ = []
dmdTransformSig :: StrictSig -> CleanDemand -> DmdType
......@@ -1304,7 +1305,7 @@ dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd
-- a lazy demand for p!
dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType
-- Same as dmdTranformSig but for a data constructor (worker),
-- Same as dmdTransformSig but for a data constructor (worker),
-- which has a special kind of demand transformer.
-- If the constructor is saturated, we feed the demand on
-- the result into the constructor arguments.
......
......@@ -65,15 +65,17 @@ module Id (
idInlineActivation, setInlineActivation, idRuleMatchInfo,
-- ** One-shot lambdas
isOneShotBndr, isOneShotLambda, isStateHackType,
setOneShotLambda, clearOneShotLambda,
isOneShotBndr, isOneShotLambda, isProbablyOneShotLambda,
setOneShotLambda, clearOneShotLambda,
updOneShotInfo, setIdOneShotInfo,
isStateHackType, stateHackOneShot, typeOneShot,
-- ** Reading 'IdInfo' fields
idArity,
idUnfolding, realIdUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo,
idLBVarInfo,
idOneShotInfo,
idOccInfo,
-- ** Writing 'IdInfo' fields
......@@ -130,6 +132,7 @@ infixl 1 `setIdUnfoldingLazily`,
`setIdUnfolding`,
`setIdArity`,
`setIdOccInfo`,
`setIdOneShotInfo`,
`setIdSpecialisation`,
`setInlinePragma`,
......@@ -236,7 +239,8 @@ mkVanillaGlobalWithInfo = mkGlobalId VanillaId
-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"
mkLocalId :: Name -> Type -> Id
mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo
mkLocalId name ty = mkLocalIdWithInfo name ty
(vanillaIdInfo `setOneShotInfo` typeOneShot ty)
mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info
......@@ -587,18 +591,27 @@ isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id)
---------------------------------
-- ONE-SHOT LAMBDAS
\begin{code}
idLBVarInfo :: Id -> LBVarInfo
idLBVarInfo id = lbvarInfo (idInfo id)
idOneShotInfo :: Id -> OneShotInfo
idOneShotInfo id = oneShotInfo (idInfo id)
-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once
-- OR we are applying the \"state hack\" which makes it appear as if theis is the case for
-- lambdas used in @IO@. You should prefer using this over 'isOneShotLambda'
isOneShotBndr :: Id -> Bool
-- This one is the "business end", called externally.
-- It works on type variables as well as Ids, returning True
-- Its main purpose is to encapsulate the Horrible State Hack
isOneShotBndr id = isOneShotLambda id || isStateHackType (idType id)
isOneShotBndr :: Var -> Bool
isOneShotBndr var
| isTyVar var = True
| otherwise = isOneShotLambda var
-- | Should we apply the state hack to values of this 'Type'?
stateHackOneShot :: OneShotInfo
stateHackOneShot = OneShotLam -- Or maybe ProbOneShot?
typeOneShot :: Type -> OneShotInfo
typeOneShot ty
| isStateHackType ty = stateHackOneShot
| otherwise = NoOneShotInfo
isStateHackType :: Type -> Bool
isStateHackType ty
| opt_NoStateHack
......@@ -629,17 +642,36 @@ isStateHackType ty
-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once.
-- You probably want to use 'isOneShotBndr' instead
isOneShotLambda :: Id -> Bool
isOneShotLambda id = case idLBVarInfo id of
IsOneShotLambda -> True
NoLBVarInfo -> False
isOneShotLambda id = case idOneShotInfo id of
OneShotLam -> True
_ -> False
isProbablyOneShotLambda :: Id -> Bool
isProbablyOneShotLambda id = case idOneShotInfo id of
OneShotLam -> True
ProbOneShot -> True
NoOneShotInfo -> False
setOneShotLambda :: Id -> Id
setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id
clearOneShotLambda :: Id -> Id
clearOneShotLambda id
| isOneShotLambda id = modifyIdInfo (`setLBVarInfo` NoLBVarInfo) id
| otherwise = id
clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id
setIdOneShotInfo :: Id -> OneShotInfo -> Id
setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id
updOneShotInfo :: Id -> OneShotInfo -> Id
-- Combine the info in the Id with new info
updOneShotInfo id one_shot
| do_upd = setIdOneShotInfo id one_shot
| otherwise = id
where
do_upd = case (idOneShotInfo id, one_shot) of
(NoOneShotInfo, _) -> True
(OneShotLam, _) -> False
(_, NoOneShotInfo) -> False
_ -> True
-- The OneShotLambda functions simply fiddle with the IdInfo flag
-- But watch out: this may change the type of something else
......
......@@ -24,9 +24,13 @@ module IdInfo (
vanillaIdInfo, noCafIdInfo,
seqIdInfo, megaSeqIdInfo,
-- ** The OneShotInfo type
OneShotInfo(..),
oneShotInfo, noOneShotInfo, hasNoOneShotInfo,
setOneShotInfo,
-- ** Zapping various forms of Info
zapLamInfo, zapFragileInfo,
zapDemandInfo,
-- ** The ArityInfo type
......@@ -52,7 +56,7 @@ module IdInfo (
InsideLam, OneBranch,
insideLam, notInsideLam, oneBranch, notOneBranch,
-- ** The SpecInfo type
SpecInfo(..),
emptySpecInfo,
......@@ -65,11 +69,6 @@ module IdInfo (
ppCafInfo, mayHaveCafRefs,
cafInfo, setCafInfo,
-- ** The LBVarInfo type
LBVarInfo(..),
noLBVarInfo, hasNoLBVarInfo,
lbvarInfo, setLBVarInfo,
-- ** Tick-box Info
TickBoxOp(..), TickBoxId,
) where
......@@ -94,7 +93,7 @@ infixl 1 `setSpecInfo`,
`setArityInfo`,
`setInlinePragInfo`,
`setUnfoldingInfo`,
`setLBVarInfo`,
`setOneShotInfo`,
`setOccInfo`,
`setCafInfo`,
`setStrictnessInfo`,
......@@ -191,7 +190,7 @@ pprIdDetails other = brackets (pp other)
--
-- The 'IdInfo' gives information about the value, or definition, of the
-- 'Id'. It does not contain information about the 'Id''s usage,
-- except for 'demandInfo' and 'lbvarInfo'.
-- except for 'demandInfo' and 'oneShotInfo'.
data IdInfo
= IdInfo {
arityInfo :: !ArityInfo, -- ^ 'Id' arity
......@@ -199,7 +198,7 @@ data IdInfo
-- See Note [Specialisations and RULES in IdInfo]
unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding
cafInfo :: CafInfo, -- ^ 'Id' CAF info
lbvarInfo :: LBVarInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one
oneShotInfo :: OneShotInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one
inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id'
occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program
......@@ -223,12 +222,14 @@ megaSeqIdInfo info
-- some unfoldings are not calculated at all
-- seqUnfolding (unfoldingInfo info) `seq`
seqDemandInfo (demandInfo info) `seq`
seqStrictnessInfo (strictnessInfo info) `seq`
seqDemandInfo (demandInfo info) `seq`
seqStrictnessInfo (strictnessInfo info) `seq`
seqCaf (cafInfo info) `seq`
seqLBVar (lbvarInfo info) `seq`
seqOccInfo (occInfo info)
seqOneShot (oneShotInfo info) `seq`
seqOccInfo (occInfo info)
seqOneShot :: OneShotInfo -> ()
seqOneShot l = l `seq` ()
seqStrictnessInfo :: StrictSig -> ()
seqStrictnessInfo ty = seqStrictSig ty
......@@ -266,8 +267,8 @@ setArityInfo info ar = info { arityInfo = ar }
setCafInfo :: IdInfo -> CafInfo -> IdInfo
setCafInfo info caf = info { cafInfo = caf }
setLBVarInfo :: IdInfo -> LBVarInfo -> IdInfo
setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb }
setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo
setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb }
setDemandInfo :: IdInfo -> Demand -> IdInfo
setDemandInfo info dd = dd `seq` info { demandInfo = dd }
......@@ -286,7 +287,7 @@ vanillaIdInfo
arityInfo = unknownArity,
specInfo = emptySpecInfo,
unfoldingInfo = noUnfolding,
lbvarInfo = NoLBVarInfo,
oneShotInfo = NoOneShotInfo,
inlinePragInfo = defaultInlinePragma,
occInfo = NoOccInfo,
demandInfo = topDmd,
......@@ -463,43 +464,6 @@ ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs")
ppCafInfo MayHaveCafRefs = empty
\end{code}
%************************************************************************
%* *
\subsection[lbvar-IdInfo]{Lambda-bound var info about an @Id@}
%* *
%************************************************************************
\begin{code}
-- | If the 'Id' is a lambda-bound variable then it may have lambda-bound
-- variable info. Sometimes we know whether the lambda binding this variable
-- is a \"one-shot\" lambda; that is, whether it is applied at most once.
--
-- This information may be useful in optimisation, as computations may
-- safely be floated inside such a lambda without risk of duplicating
-- work.
data LBVarInfo = NoLBVarInfo -- ^ No information
| IsOneShotLambda -- ^ The lambda is applied at most once).
-- | It is always safe to assume that an 'Id' has no lambda-bound variable information
noLBVarInfo :: LBVarInfo
noLBVarInfo = NoLBVarInfo
hasNoLBVarInfo :: LBVarInfo -> Bool
hasNoLBVarInfo NoLBVarInfo = True
hasNoLBVarInfo IsOneShotLambda = False
seqLBVar :: LBVarInfo -> ()
seqLBVar l = l `seq` ()
pprLBVarInfo :: LBVarInfo -> SDoc
pprLBVarInfo NoLBVarInfo = empty
pprLBVarInfo IsOneShotLambda = ptext (sLit "OneShot")
instance Outputable LBVarInfo where
ppr = pprLBVarInfo
\end{code}
%************************************************************************
%* *
\subsection{Bulk operations on IdInfo}
......
......@@ -1319,7 +1319,8 @@ inlined.
\begin{code}
realWorldPrimId :: Id -- :: State# RealWorld
realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy
(noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings]
(noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings]
`setOneShotInfo` stateHackOneShot)
voidPrimId :: Id -- Global constant :: Void#
voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy
......
......@@ -102,7 +102,7 @@ exprArity e = go e
trim_arity arity ty = arity `min` length (typeArity ty)
---------------
typeArity :: Type -> [OneShot]
typeArity :: Type -> [OneShotInfo]
-- How many value arrows are visible in the type?
-- We look through foralls, and newtypes
-- See Note [exprArity invariant]
......@@ -114,8 +114,7 @@ typeArity ty
= go rec_nts ty'
| Just (arg,res) <- splitFunTy_maybe ty
= isStateHackType arg : go rec_nts res
= typeOneShot arg : go rec_nts res
| Just (tc,tys) <- splitTyConApp_maybe ty
, Just (ty', _) <- instNewTyCon_maybe tc tys
, Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes]
......@@ -476,16 +475,10 @@ Then f :: AT [False,False] ATop
-------------------- Main arity code ----------------------------
\begin{code}
-- See Note [ArityType]
data ArityType = ATop [OneShot] | ABot Arity
data ArityType = ATop [OneShotInfo] | ABot Arity
-- There is always an explicit lambda
-- to justify the [OneShot], or the Arity
type OneShot = Bool -- False <=> Know nothing
-- True <=> Can definitely float inside this lambda
-- The 'True' case can arise either because a binder
-- is marked one-shot, or because it's a state lambda
-- and we have the state hack on
vanillaArityType :: ArityType
vanillaArityType = ATop [] -- Totally uninformative
......@@ -543,7 +536,7 @@ findRhsArity dflags bndr rhs old_arity
#ifdef DEBUG
pprTrace "Exciting arity"
(vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
, ppr rhs])
, ppr rhs])
#endif
go new_arity
where
......@@ -562,8 +555,9 @@ rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity
rhsEtaExpandArity dflags cheap_app e
= case (arityType env e) of
ATop (os:oss)
| os || has_lam e -> 1 + length oss -- Don't expand PAPs/thunks
-- Note [Eta expanding thunks]
| isOneShotInfo os || has_lam e -> 1 + length oss
-- Don't expand PAPs/thunks
-- Note [Eta expanding thunks]
| otherwise -> 0
ATop [] -> 0
ABot n -> n
......@@ -647,15 +641,15 @@ when saturated" so we don't want to be too gung-ho about saturating!
\begin{code}
arityLam :: Id -> ArityType -> ArityType
arityLam id (ATop as) = ATop (isOneShotBndr id : as)
arityLam id (ATop as) = ATop (idOneShotInfo id : as)
arityLam _ (ABot n) = ABot (n+1)
floatIn :: Bool -> ArityType -> ArityType
-- We have something like (let x = E in b),
-- where b has the given arity type.
-- We have something like (let x = E in b),
-- where b has the given arity type.
floatIn _ (ABot n) = ABot n
floatIn True (ATop as) = ATop as
floatIn False (ATop as) = ATop (takeWhile id as)
floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as)
-- If E is not cheap, keep arity only for one-shots
arityApp :: ArityType -> Bool -> ArityType
......@@ -667,37 +661,34 @@ arityApp (ATop []) _ = ATop []
arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as)
andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case'
andArityType (ABot n1) (ABot n2)
andArityType (ABot n1) (ABot n2)
= ABot (n1 `min` n2)
andArityType (ATop as) (ABot _) = ATop as
andArityType (ABot _) (ATop bs) = ATop bs
andArityType (ATop as) (ATop bs) = ATop (as `combine` bs)
where -- See Note [Combining case branches]
combine (a:as) (b:bs) = (a && b) : combine as bs
combine [] bs = take_one_shots bs
combine as [] = take_one_shots as
take_one_shots [] = []
take_one_shots (one_shot : as)
| one_shot = True : take_one_shots as
| otherwise = []
combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs
combine [] bs = takeWhile isOneShotInfo bs
combine as [] = takeWhile isOneShotInfo as
\end{code}
Note [Combining case branches]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
Consider
go = \x. let z = go e0
go2 = \x. case x of
True -> z
False -> \s(one-shot). e1
in go2 x
We *really* want to eta-expand go and go2.
We *really* want to eta-expand go and go2.
When combining the barnches of the case we have
ATop [] `andAT` ATop [True]
and we want to get ATop [True]. But if the inner
ATop [] `andAT` ATop [OneShotLam]
and we want to get ATop [OneShotLam]. But if the inner
lambda wasn't one-shot we don't want to do this.
(We need a proper arity analysis to justify that.)
So we combine the best of the two branches, on the (slightly dodgy)
basis that if we know one branch is one-shot, then they all must be.
\begin{code}
---------------------------
......@@ -738,7 +729,7 @@ arityType _ (Var v)
| otherwise
= ATop (take (idArity v) one_shots)
where
one_shots :: [Bool] -- One-shot-ness derived from the type
one_shots :: [OneShotInfo] -- One-shot-ness derived from the type
one_shots = typeArity (idType v)
-- Lambdas; increase arity
......@@ -778,7 +769,7 @@ arityType env (Case scrut _ _ alts)
ATop as | not (ae_ped_bot env) -- Check -fpedantic-bottoms
, is_under scrut -> ATop as
| exprOkForSpeculation scrut -> ATop as
| otherwise -> ATop (takeWhile id as)
| otherwise -> ATop (takeWhile isOneShotInfo as)
where
-- is_under implements Note [Dealing with bottom (3)]
is_under (Var f) = f `elem` ae_bndrs env
......
......@@ -296,16 +296,23 @@ pprTypedLamBinder bind_site debug_on var
= sdocWithDynFlags $ \dflags ->
case () of
_
| not debug_on && isDeadBinder var -> char '_'
| not debug_on, CaseBind <- bind_site -> -- No parens, no kind info
pprUntypedBinder var
| gopt Opt_SuppressTypeSignatures dflags -> -- Suppress the signature
pprUntypedBinder var
| isTyVar var -> parens (pprKindedTyVarBndr var)
| otherwise ->
parens (hang (pprIdBndr var)
2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
| not debug_on -- Even dead binders can be one-shot
, isDeadBinder var -> char '_' <+> ppWhen (isId var)
(pprIdBndrInfo (idInfo var))
| not debug_on -- No parens, no kind info
, CaseBind <- bind_site -> pprUntypedBinder var
| suppress_sigs dflags -> pprUntypedBinder var
| isTyVar var -> parens (pprKindedTyVarBndr var)
| otherwise -> parens (hang (pprIdBndr var)
2 (vcat [ dcolon <+> pprType (idType var)
, pp_unf]))
where
suppress_sigs = gopt Opt_SuppressTypeSignatures
unf_info = unfoldingInfo (idInfo var)
pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
| otherwise = empty
......@@ -340,18 +347,18 @@ pprIdBndrInfo info
prag_info = inlinePragInfo info
occ_info = occInfo info
dmd_info = demandInfo info
lbv_info = lbvarInfo info
lbv_info = oneShotInfo info
has_prag = not (isDefaultInlinePragma prag_info)
has_occ = not (isNoOcc occ_info)
has_dmd = not $ isTopDmd dmd_info
has_lbv = not (hasNoLBVarInfo lbv_info)
has_lbv = not (hasNoOneShotInfo lbv_info)
doc = showAttributes
[ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
, (has_occ, ptext (sLit "Occ=") <> ppr occ_info)
, (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info)
, (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info)
, (has_lbv , ptext (sLit "OS=") <> ppr lbv_info)
]
\end{code}
......@@ -374,7 +381,7 @@ ppIdInfo id info
, (True, ptext (sLit "Str=") <> pprStrictness str_info)
, (has_unf, ptext (sLit "Unf=") <> ppr unf_info)
, (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
] -- Inline pragma, occ, demand, lbvar info
] -- Inline pragma, occ, demand, one-shot info
-- printed out with all binders (when debug is on);
-- see PprCore.pprIdBndr
where
......
......@@ -1084,7 +1084,7 @@ occAnalNonRecRhs env bndr rhs
= occAnal rhs_env rhs
where
-- See Note [Use one-shot info]
env1 = env { occ_one_shots = argOneShots dmd }
env1 = env { occ_one_shots = argOneShots OneShotLam dmd }
-- See Note [Cascading inlines]
rhs_env | certainly_inline = env1
......@@ -1234,13 +1234,14 @@ occAnal env expr@(Lam _ _)
(final_usage, tagged_binders) = tagLamBinders body_usage binders'
-- Use binders' to put one-shot info on the lambdas
really_final_usage | linear = final_usage
| otherwise = mapVarEnv markInsideLam final_usage
really_final_usage
| all isOneShotBndr binders' = final_usage
| otherwise = mapVarEnv markInsideLam final_usage
in
(really_final_usage, mkLams tagged_binders body') }
where
(binders, body) = collectBinders expr
(env_body, binders', linear) = oneShotGroup env binders
(binders, body) = collectBinders expr
(env_body, binders') = oneShotGroup env binders
occAnal env (Case scrut bndr ty alts)
= case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
......@@ -1332,15 +1333,16 @@ occAnalApp env (Var fun, args)
in
(fun_uds +++ final_args_uds, mkApps (Var fun) args') }
where
fun_uds = mkOneOcc env fun (valArgCount args > 0)
is_exp = isExpandableApp fun (valArgCount args)
n_val_args = valArgCount args
fun_uds = mkOneOcc env fun (n_val_args > 0)
is_exp = isExpandableApp fun n_val_args
-- See Note [CONLIKE pragma] in BasicTypes
-- The definition of is_exp should match that in
-- Simplify.prepareRhs
one_shots = argsOneShots (idStrictness fun) (valArgCount args)
one_shots = argsOneShots (idStrictness fun) n_val_args
-- See Note [Use one-shot info]
args_stuff = occAnalArgs env args one_shots
-- (foldr k z xs) may call k many times, but it never
......@@ -1466,15 +1468,11 @@ instance Outputable OccEncl where
ppr OccRhs = ptext (sLit "occRhs")
ppr OccVanilla = ptext (sLit "occVanilla")
type OneShots = [Bool]
type OneShots = [OneShotInfo]
-- [] No info
--