X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FIdInfo.lhs;h=708f4dfe5839c3864cf49f1768d07343230e14e8;hb=30c122df62ec75f9ed7f392f24c2925675bf1d06;hp=6b43c687800c482abc0ed24b5f2327792ea00405;hpb=5e04af6de2dd1d86f6bf0599420e32aaa776d055;p=ghc-hetmet.git diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 6b43c68..708f4df 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -8,13 +8,6 @@ Haskell. [WDP 94/11]) \begin{code} -{-# OPTIONS -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/Commentary/CodingStyle#Warnings --- for details - module IdInfo ( GlobalIdDetails(..), notGlobalId, -- Not abstract @@ -72,7 +65,7 @@ module IdInfo ( -- Specialisation SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, - specInfoFreeVars, specInfoRules, seqSpecInfo, + specInfoFreeVars, specInfoRules, seqSpecInfo, setSpecInfoHead, -- CAF info CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs, @@ -89,6 +82,7 @@ module IdInfo ( import CoreSyn import Class import PrimOp +import Name import Var import VarSet import BasicTypes @@ -98,11 +92,11 @@ import ForeignCall import NewDemand import Outputable import Module +import FastString import Data.Maybe #ifdef OLD_STRICTNESS -import Name import Demand import qualified Demand import Util @@ -137,8 +131,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 @@ -155,9 +149,11 @@ 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 @@ -219,6 +215,7 @@ oldDemand (Call _) = WwStrict \begin{code} +seqNewDemandInfo :: Maybe Demand -> () seqNewDemandInfo Nothing = () seqNewDemandInfo (Just dmd) = seqDemand dmd \end{code} @@ -262,6 +259,7 @@ data GlobalIdDetails | NotGlobalId -- Used as a convenient extra return value from globalIdDetails +notGlobalId :: GlobalIdDetails notGlobalId = NotGlobalId instance Outputable GlobalIdDetails where @@ -359,19 +357,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. @@ -382,12 +386,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} @@ -413,6 +422,7 @@ vanillaIdInfo newStrictnessInfo = Nothing } +noCafIdInfo :: IdInfo noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs -- Used for built-in type Ids in MkId. \end{code} @@ -438,8 +448,10 @@ 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] \end{code} @@ -474,8 +486,10 @@ type InlinePragInfo = Activation 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 @@ -489,19 +503,16 @@ 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} -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 - %************************************************************************ @@ -547,6 +558,7 @@ 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 @@ -556,9 +568,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} @@ -580,13 +594,17 @@ 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 :: CafInfo -> SDoc ppCafInfo NoCafRefs = ptext SLIT("NoCafRefs") ppCafInfo MayHaveCafRefs = empty \end{code} @@ -664,15 +682,19 @@ 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") @@ -724,9 +746,13 @@ zapDemandInfo info@(IdInfo {newDemandInfo = 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} %************************************************************************