X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FIdInfo.lhs;h=ad6d24763fc311bce03f48782aafe463753f8898;hb=08652e67c4d5d9a40687f93c286021a867c1bca0;hp=d53bf5627d99638a48f0f07e57eb846b4e0dc65a;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index d53bf56..ad6d247 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % \section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} @@ -15,7 +16,7 @@ module IdInfo ( seqIdInfo, megaSeqIdInfo, -- Zapping - zapLamInfo, zapDemandInfo, + zapLamInfo, zapDemandInfo, zapFragileInfo, -- Arity ArityInfo, @@ -64,42 +65,40 @@ module IdInfo ( -- Specialisation SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, - specInfoFreeVars, specInfoRules, seqSpecInfo, + specInfoFreeVars, specInfoRules, seqSpecInfo, setSpecInfoHead, -- CAF info CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs, -- Lambda-bound variable info - LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo - ) where - -#include "HsVersions.h" + LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo, + -- Tick-box info + TickBoxOp(..), TickBoxId, + ) where import CoreSyn -import Class ( Class ) -import PrimOp ( PrimOp ) -import Var ( Id ) -import VarSet ( VarSet, emptyVarSet, seqVarSet ) -import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker, - InsideLam, insideLam, notInsideLam, - OneBranch, oneBranch, notOneBranch, - Arity, - Activation(..) - ) -import DataCon ( DataCon ) -import TyCon ( TyCon, FieldLabel ) -import ForeignCall ( ForeignCall ) +import Class +import PrimOp +import Name +import Var +import VarSet +import BasicTypes +import DataCon +import TyCon +import ForeignCall import NewDemand import Outputable -import Maybe ( isJust ) +import Module +import FastString + +import Data.Maybe #ifdef OLD_STRICTNESS -import Name ( Name ) -import Demand hiding( Demand, seqDemand ) +import Demand import qualified Demand -import Util ( listLengthCmp ) -import List ( replicate ) +import Util +import Data.List #endif -- infixl so you can say (id `set` a `set` b) @@ -130,8 +129,8 @@ infixl 1 `setSpecInfo`, 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 @@ -148,11 +147,13 @@ setAllStrictnessInfo info (Just sig) #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 @@ -212,6 +213,7 @@ oldDemand (Call _) = WwStrict \begin{code} +seqNewDemandInfo :: Maybe Demand -> () seqNewDemandInfo Nothing = () seqNewDemandInfo (Just dmd) = seqDemand dmd \end{code} @@ -219,7 +221,7 @@ seqNewDemandInfo (Just dmd) = seqDemand dmd %************************************************************************ %* * -\subsection{GlobalIdDetails +\subsection{GlobalIdDetails} %* * %************************************************************************ @@ -232,7 +234,8 @@ data GlobalIdDetails = VanillaGlobal -- Imported from elsewhere, a default method Id. | RecordSelId -- The Id for a record selector - { sel_tycon :: TyCon + { sel_tycon :: TyCon -- For a data type family, this is the *instance* TyCon + -- not the family TyCon , sel_label :: FieldLabel , sel_naughty :: Bool -- True <=> naughty } -- See Note [Naughty record selectors] @@ -250,19 +253,23 @@ data GlobalIdDetails | PrimOpId PrimOp -- The Id for a primitive operator | FCallId ForeignCall -- The Id for a foreign call + | TickBoxOpId TickBoxOp -- The Id for a tick box (both traditional and binary) + | 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 (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} @@ -348,19 +355,25 @@ megaSeqIdInfo info 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. @@ -371,12 +384,17 @@ setDemandInfo info dd = info { demandInfo = dd } 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} @@ -402,6 +420,7 @@ vanillaIdInfo newStrictnessInfo = Nothing } +noCafIdInfo :: IdInfo noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs -- Used for built-in type Ids in MkId. \end{code} @@ -427,10 +446,12 @@ type ArityInfo = Arity -- 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} %************************************************************************ @@ -460,9 +481,13 @@ type InlinePragInfo = Activation %************************************************************************ \begin{code} --- CoreRules is used only in an idSpecialisation (move to IdInfo?) data SpecInfo - = SpecInfo [CoreRule] VarSet -- Locally-defined free vars of RHSs + = SpecInfo + [CoreRule] + 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 @@ -476,10 +501,18 @@ specInfoFreeVars (SpecInfo _ fvs) = fvs specInfoRules :: SpecInfo -> [CoreRule] specInfoRules (SpecInfo rules _) = rules +setSpecInfoHead :: Name -> SpecInfo -> SpecInfo +setSpecInfoHead fn (SpecInfo rules fvs) + = SpecInfo (map set_head rules) fvs + where + set_head rule = rule { ru_fn = fn } + +seqSpecInfo :: SpecInfo -> () seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs \end{code} + %************************************************************************ %* * \subsection[worker-IdInfo]{Worker info about an @Id@} @@ -523,8 +556,9 @@ seqWorker :: WorkerInfo -> () 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 @@ -532,9 +566,11 @@ workerExists (HasWorker _ _) = True 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} @@ -556,14 +592,18 @@ data CafInfo | 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} @@ -611,7 +651,7 @@ seqCpr NoCPRInfo = () noCprInfo = NoCPRInfo ppCprInfo NoCPRInfo = empty -ppCprInfo ReturnsCPR = ptext SLIT("__M") +ppCprInfo ReturnsCPR = ptext (sLit "__M") instance Outputable CprInfo where ppr = ppCprInfo @@ -640,17 +680,21 @@ work. 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 @@ -680,11 +724,11 @@ zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand}) -- 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) @@ -697,3 +741,31 @@ zapDemandInfo info@(IdInfo {newDemandInfo = dmd}) | otherwise = Nothing \end{code} +\begin{code} +zapFragileInfo :: IdInfo -> Maybe IdInfo +-- Zap info that depends on free variables +zapFragileInfo info + = Just (info `setSpecInfo` emptySpecInfo + `setWorkerInfo` NoWorker + `setUnfoldingInfo` NoUnfolding + `setOccInfo` if isFragileOcc occ then NoOccInfo else occ) + where + occ = occInfo info +\end{code} + +%************************************************************************ +%* * +\subsection{TickBoxOp} +%* * +%************************************************************************ + +\begin{code} +type TickBoxId = Int + +data TickBoxOp + = TickBox Module {-# UNPACK #-} !TickBoxId + -- ^Tick box for Hpc-style coverage + +instance Outputable TickBoxOp where + ppr (TickBox mod n) = ptext (sLit "tick") <+> ppr (mod,n) +\end{code}