module IdInfo (
IdInfo, -- Abstract
- vanillaIdInfo, mkIdInfo,
+ vanillaIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo,
-- Flavour
IdFlavour(..), flavourInfo,
-- Arity
ArityInfo(..),
- exactArity, atLeastArity, unknownArity,
+ exactArity, atLeastArity, unknownArity, hasArity,
arityInfo, setArityInfo, ppArityInfo, arityLowerBound,
-- Strictness
-- Worker
WorkerInfo, workerExists,
- workerInfo, setWorkerInfo,
+ workerInfo, setWorkerInfo, ppWorkerInfo,
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo,
-- Zapping
- zapLamIdInfo, zapFragileIdInfo,
+ zapLamIdInfo, zapFragileIdInfo, zapIdInfoForStg,
-- Lambda-bound variable info
LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo
#include "HsVersions.h"
-import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding, hasUnfolding )
-import {-# SOURCE #-} CoreSyn ( CoreExpr, CoreRules, emptyCoreRules, isEmptyCoreRules )
+import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding, hasUnfolding, seqUnfolding )
+import {-# SOURCE #-} CoreSyn ( CoreExpr, CoreRules, emptyCoreRules, isEmptyCoreRules, seqRules )
import {-# SOURCE #-} Const ( Con )
import Var ( Id )
import FieldLabel ( FieldLabel )
-import Demand ( Demand, isStrict, isLazy, wwLazy, pprDemands )
+import Demand ( Demand, isStrict, isLazy, wwLazy, pprDemands, seqDemand, seqDemands )
import Type ( UsageAnn )
import Outputable
import Maybe ( isJust )
cafInfo :: CafInfo,
cprInfo :: CprInfo, -- Function always constructs a product result
lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable
- inlinePragInfo :: !InlinePragInfo -- Inline pragmas
+ inlinePragInfo :: InlinePragInfo -- Inline pragmas
}
+
+seqIdInfo :: IdInfo -> ()
+seqIdInfo (IdInfo {}) = ()
+
+megaSeqIdInfo :: IdInfo -> ()
+megaSeqIdInfo info
+ = seqFlavour (flavourInfo info) `seq`
+ seqArity (arityInfo info) `seq`
+ seqDemand (demandInfo info) `seq`
+ seqRules (specInfo info) `seq`
+ seqStrictness (strictnessInfo info) `seq`
+ seqWorker (workerInfo info) `seq`
+
+-- seqUnfolding (unfoldingInfo info) `seq`
+-- Omitting this improves runtimes a little, presumably because
+-- some unfoldings are not calculated at all
+
+ seqCaf (cafInfo info) `seq`
+ seqCpr (cprInfo info) `seq`
+ seqLBVar (lbvarInfo info) `seq`
+ seqInlinePrag (inlinePragInfo info)
\end{code}
Setters
\begin{code}
+setWorkerInfo info wk = wk `seq` info { workerInfo = wk }
+setSpecInfo info sp = sp `seq` info { specInfo = sp }
+setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
+setStrictnessInfo info st = st `seq` info { strictnessInfo = st }
+ -- Try to avoid spack leaks by seq'ing
+
+setUnfoldingInfo info uf = info { unfoldingInfo = uf }
+ -- We do *not* seq on the unfolding info, For some reason, doing so
+ -- actually increases residency significantly.
+
setUpdateInfo info ud = info { updateInfo = ud }
setDemandInfo info dd = info { demandInfo = dd }
-setStrictnessInfo info st = info { strictnessInfo = st }
-setWorkerInfo info wk = info { workerInfo = wk }
-setSpecInfo info sp = info { specInfo = sp }
setArityInfo info ar = info { arityInfo = ar }
-setInlinePragInfo info pr = info { inlinePragInfo = pr }
-setUnfoldingInfo info uf = info { unfoldingInfo = uf }
setCafInfo info cf = info { cafInfo = cf }
setCprInfo info cp = info { cprInfo = cp }
setLBVarInfo info lb = info { lbvarInfo = lb }
ppFlavourInfo (RecordSelId _) = ptext SLIT("[RecSel]")
ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]")
ppFlavourInfo NoDiscardId = ptext SLIT("[NoDiscard]")
+
+seqFlavour :: IdFlavour -> ()
+seqFlavour f = f `seq` ()
\end{code}
The @SpecPragmaId@ exists only to make Ids that are
| ArityExactly Int -- Arity is exactly this
| ArityAtLeast Int -- Arity is this or greater
+seqArity :: ArityInfo -> ()
+seqArity a = arityLowerBound a `seq` ()
+
exactArity = ArityExactly
atLeastArity = ArityAtLeast
unknownArity = UnknownArity
arityLowerBound (ArityAtLeast n) = n
arityLowerBound (ArityExactly n) = n
+hasArity :: ArityInfo -> Bool
+hasArity UnknownArity = False
+hasArity other = True
ppArityInfo UnknownArity = empty
ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("__A"), int arity]
| IMustBeINLINEd -- Absolutely must inline; used for PrimOps and
-- constructors only.
+seqInlinePrag :: InlinePragInfo -> ()
+seqInlinePrag (ICanSafelyBeINLINEd occ alts)
+ = occ `seq` alts `seq` ()
+seqInlinePrag other
+ = ()
+
instance Outputable InlinePragInfo where
ppr NoInlinePragInfo = empty
ppr IMustBeINLINEd = ptext SLIT("__UU")
-- BUT NB: f = \x y. error "urk"
-- will have info SI [SS] True
-- but still (f) and (f 2) are not bot; only (f 3 2) is bot
+
+seqStrictness :: StrictnessInfo -> ()
+seqStrictness (StrictnessInfo ds b) = b `seq` seqDemands ds
+seqStrictness other = ()
\end{code}
\begin{code}
{- UNUSED:
mkWorkerInfo :: Id -> WorkerInfo
mkWorkerInfo wk_id = Just wk_id
+-}
+
+seqWorker :: WorkerInfo -> ()
+seqWorker (Just id) = id `seq` ()
+seqWorker Nothing = ()
ppWorkerInfo Nothing = empty
-ppWorkerInfo (Just wk_id) = ppr wk_id
--}
+ppWorkerInfo (Just wk_id) = ptext SLIT("__P") <+> ppr wk_id
noWorkerInfo = Nothing
-- | OneCafRef Id
+seqCaf c = c `seq` ()
+
ppCafInfo NoCafRefs = ptext SLIT("__C")
ppCafInfo MayHaveCafRefs = empty
\end{code}
\begin{code}
zapFragileIdInfo :: IdInfo -> Maybe IdInfo
zapFragileIdInfo info@(IdInfo {inlinePragInfo = inline_prag,
+ workerInfo = wrkr,
specInfo = rules,
unfoldingInfo = unfolding})
| not is_fragile_inline_prag
-- Specialisations would need substituting. They get pinned
-- back on separately.
+ && not (workerExists wrkr)
+
&& not (hasUnfolding unfolding)
-- This is very important; occasionally a let-bound binder is used
-- as a binder in some lambda, in which case its unfolding is utterly
| otherwise
= Just (info {inlinePragInfo = safe_inline_prag,
+ workerInfo = noWorkerInfo,
specInfo = emptyCoreRules,
unfoldingInfo = noUnfolding})
other -> inline_prag
\end{code}
+\begin{code}
+zapIdInfoForStg :: IdInfo -> IdInfo
+ -- Return only the info needed for STG stuff
+ -- Namely, nothing, I think
+zapIdInfoForStg info = vanillaIdInfo
+\end{code}
+
%************************************************************************
%* *
\end{code}
\begin{code}
+seqCpr :: CprInfo -> ()
+seqCpr (CPRInfo cs) = seqCprs cs
+seqCpr NoCPRInfo = ()
+
+seqCprs [] = ()
+seqCprs (c:cs) = seqCpr c `seq` seqCprs cs
+
noCprInfo = NoCPRInfo
-- HACK ALERT! placing this info here is a short-term hack,
-- but it minimises changes to the rest of the compiler.
-- Hack agreed by SLPJ/KSW 1999-04.
+
+seqLBVar l = l `seq` ()
\end{code}
\begin{code}
-- not safe to print or parse LBVarInfo because it is not really a
-- property of the definition, but a property of the context.
-ppLBVarInfo _ = empty
+pprLBVarInfo NoLBVarInfo = empty
+pprLBVarInfo IsOneShotLambda = getPprStyle $ \ sty ->
+ if ifaceStyle sty then empty
+ else ptext SLIT("OneShot")
instance Outputable LBVarInfo where
- ppr = ppLBVarInfo
+ ppr = pprLBVarInfo
instance Show LBVarInfo where
showsPrec p c = showsPrecSDoc p (ppr c)
projects / ghc-hetmet.git / blobdiff