Haskell. [WDP 94/11])
\begin{code}
-{-# OPTIONS_GHC -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
--- for details
-
module IdInfo (
GlobalIdDetails(..), notGlobalId, -- Not abstract
-- Specialisation
SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo,
- specInfoFreeVars, specInfoRules, seqSpecInfo,
+ specInfoFreeVars, specInfoRules, seqSpecInfo, setSpecInfoHead,
-- CAF info
CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs,
TickBoxOp(..), TickBoxId,
) where
-#include "HsVersions.h"
-
-import CoreSyn
import Class
import PrimOp
+import Name
import Var
import VarSet
import BasicTypes
import NewDemand
import Outputable
import Module
+import FastString
import Data.Maybe
#ifdef OLD_STRICTNESS
-import Name
import Demand
import qualified Demand
import Util
To be removed later
\begin{code}
--- setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
-- Set old and new strictness info
+setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
setAllStrictnessInfo info Nothing
= info { newStrictnessInfo = Nothing
#ifdef OLD_STRICTNESS
#endif
}
+seqNewStrictnessInfo :: Maybe StrictSig -> ()
seqNewStrictnessInfo Nothing = ()
seqNewStrictnessInfo (Just ty) = seqStrictSig ty
+pprNewStrictness :: Maybe StrictSig -> SDoc
pprNewStrictness Nothing = empty
-pprNewStrictness (Just sig) = ftext FSLIT("Str:") <+> ppr sig
+pprNewStrictness (Just sig) = ftext (fsLit "Str:") <+> ppr sig
#ifdef OLD_STRICTNESS
oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
\begin{code}
+seqNewDemandInfo :: Maybe Demand -> ()
seqNewDemandInfo Nothing = ()
seqNewDemandInfo (Just dmd) = seqDemand dmd
\end{code}
| NotGlobalId -- Used as a convenient extra return value from globalIdDetails
+notGlobalId :: GlobalIdDetails
notGlobalId = NotGlobalId
instance Outputable GlobalIdDetails where
- ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]")
- ppr VanillaGlobal = ptext SLIT("[GlobalId]")
- ppr (DataConWorkId _) = ptext SLIT("[DataCon]")
- ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]")
- ppr (ClassOpId _) = ptext SLIT("[ClassOp]")
- ppr (PrimOpId _) = ptext SLIT("[PrimOp]")
- ppr (FCallId _) = ptext SLIT("[ForeignCall]")
- ppr (TickBoxOpId _) = ptext SLIT("[TickBoxOp]")
- ppr (RecordSelId {}) = ptext SLIT("[RecSel]")
+ ppr NotGlobalId = ptext (sLit "[***NotGlobalId***]")
+ ppr VanillaGlobal = ptext (sLit "[GlobalId]")
+ ppr (DataConWorkId _) = ptext (sLit "[DataCon]")
+ ppr (DataConWrapId _) = ptext (sLit "[DataConWrapper]")
+ ppr (ClassOpId _) = ptext (sLit "[ClassOp]")
+ ppr (PrimOpId _) = ptext (sLit "[PrimOp]")
+ ppr (FCallId _) = ptext (sLit "[ForeignCall]")
+ ppr (TickBoxOpId _) = ptext (sLit "[TickBoxOp]")
+ ppr (RecordSelId {}) = ptext (sLit "[RecSel]")
\end{code}
Setters
\begin{code}
+setWorkerInfo :: IdInfo -> WorkerInfo -> IdInfo
setWorkerInfo info wk = wk `seq` info { workerInfo = wk }
+setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
setSpecInfo info sp = sp `seq` info { specInfo = sp }
+setInlinePragInfo :: IdInfo -> InlinePragInfo -> IdInfo
setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
+setOccInfo :: IdInfo -> OccInfo -> IdInfo
setOccInfo info oc = oc `seq` info { occInfo = oc }
#ifdef OLD_STRICTNESS
setStrictnessInfo info st = st `seq` info { strictnessInfo = st }
#endif
-- Try to avoid spack leaks by seq'ing
+setUnfoldingInfoLazily :: IdInfo -> Unfolding -> IdInfo
setUnfoldingInfoLazily info uf -- Lazy variant to avoid looking at the
= -- unfolding of an imported Id unless necessary
info { unfoldingInfo = uf } -- (In this case the demand-zapping is redundant.)
+setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo info uf
-- We do *not* seq on the unfolding info, For some reason, doing so
-- actually increases residency significantly.
setCprInfo info cp = info { cprInfo = cp }
#endif
+setArityInfo :: IdInfo -> ArityInfo -> IdInfo
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 }
+setNewDemandInfo :: IdInfo -> Maybe Demand -> IdInfo
setNewDemandInfo info dd = dd `seq` info { newDemandInfo = dd }
+setNewStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd }
\end{code}
newStrictnessInfo = Nothing
}
+noCafIdInfo :: IdInfo
noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs
-- Used for built-in type Ids in MkId.
\end{code}
-- The arity might increase later in the compilation process, if
-- an extra lambda floats up to the binding site.
+unknownArity :: Arity
unknownArity = 0 :: Arity
+ppArityInfo :: Int -> SDoc
ppArityInfo 0 = empty
-ppArityInfo n = hsep [ptext SLIT("Arity"), int n]
+ppArityInfo n = hsep [ptext (sLit "Arity"), int n]
\end{code}
%************************************************************************
data SpecInfo
= SpecInfo
[CoreRule]
- VarSet -- Locally-defined free vars of *both* LHS and RHS of rules
- -- Note [Rule dependency info]
+ VarSet -- Locally-defined free vars of *both* LHS and RHS
+ -- of rules. I don't think it needs to include the
+ -- ru_fn though.
+ -- Note [Rule dependency info] in OccurAnal
emptySpecInfo :: SpecInfo
emptySpecInfo = SpecInfo [] emptyVarSet
specInfoRules :: SpecInfo -> [CoreRule]
specInfoRules (SpecInfo rules _) = rules
+setSpecInfoHead :: Name -> SpecInfo -> SpecInfo
+setSpecInfoHead fn (SpecInfo rules fvs)
+ = SpecInfo (map (setRuleIdName fn) rules) fvs
+
+seqSpecInfo :: SpecInfo -> ()
seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
\end{code}
-Note [Rule dependency info]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-THe VarSet in a SpecInfo is used for dependency analysis in the
-occurrence analyser. We must track free vars in *both* lhs and rhs. Why both?
-Consider
- x = y
- RULE f x = 4
-Then if we substitute y for x, we'd better do so in the
- rule's LHS too, so we'd better ensure the dependency is respsected
-
%************************************************************************
seqWorker (HasWorker id a) = id `seq` a `seq` ()
seqWorker NoWorker = ()
+ppWorkerInfo :: WorkerInfo -> SDoc
ppWorkerInfo NoWorker = empty
-ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("Worker") <+> ppr wk_id
+ppWorkerInfo (HasWorker wk_id _) = ptext (sLit "Worker") <+> ppr wk_id
workerExists :: WorkerInfo -> Bool
workerExists NoWorker = False
workerId :: WorkerInfo -> Id
workerId (HasWorker id _) = id
+workerId NoWorker = panic "workerId: NoWorker"
wrapperArity :: WorkerInfo -> Arity
wrapperArity (HasWorker _ a) = a
+wrapperArity NoWorker = panic "wrapperArity: NoWorker"
\end{code}
| NoCafRefs -- A function or static constructor
-- that refers to no CAFs.
+vanillaCafInfo :: CafInfo
vanillaCafInfo = MayHaveCafRefs -- Definitely safe
+mayHaveCafRefs :: CafInfo -> Bool
mayHaveCafRefs MayHaveCafRefs = True
mayHaveCafRefs _ = False
+seqCaf :: CafInfo -> ()
seqCaf c = c `seq` ()
-ppCafInfo NoCafRefs = ptext SLIT("NoCafRefs")
+ppCafInfo :: CafInfo -> SDoc
+ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs")
ppCafInfo MayHaveCafRefs = empty
\end{code}
noCprInfo = NoCPRInfo
ppCprInfo NoCPRInfo = empty
-ppCprInfo ReturnsCPR = ptext SLIT("__M")
+ppCprInfo ReturnsCPR = ptext (sLit "__M")
instance Outputable CprInfo where
ppr = ppCprInfo
data LBVarInfo = NoLBVarInfo
| IsOneShotLambda -- The lambda is applied at most once).
+seqLBVar :: LBVarInfo -> ()
seqLBVar l = l `seq` ()
\end{code}
\begin{code}
+hasNoLBVarInfo :: LBVarInfo -> Bool
hasNoLBVarInfo NoLBVarInfo = True
hasNoLBVarInfo IsOneShotLambda = False
+noLBVarInfo :: LBVarInfo
noLBVarInfo = NoLBVarInfo
+pprLBVarInfo :: LBVarInfo -> SDoc
pprLBVarInfo NoLBVarInfo = empty
-pprLBVarInfo IsOneShotLambda = ptext SLIT("OneShot")
+pprLBVarInfo IsOneShotLambda = ptext (sLit "OneShot")
instance Outputable LBVarInfo where
ppr = pprLBVarInfo
-- The "unsafe" occ info is the ones that say I'm not in a lambda
-- because that might not be true for an unsaturated lambda
is_safe_occ (OneOcc in_lam _ _) = in_lam
- is_safe_occ other = True
+ is_safe_occ _other = True
safe_occ = case occ of
OneOcc _ once int_cxt -> OneOcc insideLam once int_cxt
- other -> occ
+ _other -> occ
is_safe_dmd Nothing = True
is_safe_dmd (Just dmd) = not (isStrictDmd dmd)
\begin{code}
zapFragileInfo :: IdInfo -> Maybe IdInfo
-- Zap info that depends on free variables
-zapFragileInfo info = Just (info `setSpecInfo` emptySpecInfo
- `setWorkerInfo` NoWorker
- `setUnfoldingInfo` NoUnfolding)
+zapFragileInfo info
+ = Just (info `setSpecInfo` emptySpecInfo
+ `setWorkerInfo` NoWorker
+ `setUnfoldingInfo` noUnfolding
+ `setOccInfo` if isFragileOcc occ then NoOccInfo else occ)
+ where
+ occ = occInfo info
\end{code}
%************************************************************************
-- ^Tick box for Hpc-style coverage
instance Outputable TickBoxOp where
- ppr (TickBox mod n) = ptext SLIT("tick") <+> ppr (mod,n)
+ ppr (TickBox mod n) = ptext (sLit "tick") <+> ppr (mod,n)
\end{code}
projects / ghc-hetmet.git / blobdiff