X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FIdInfo.lhs;h=f4cb7062e18dfefd742f090415400756f8d08f6f;hb=13aca089b924f6ac3cd598e17b471ab38a1e3e78;hp=6e871ba2115ecd291960a3df03447bac934e9ba5;hpb=3355c9d53b220ccb110e5a3c81a1a8b2c9c41555;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 6e871ba..f4cb706 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -11,7 +11,7 @@ module IdInfo ( GlobalIdDetails(..), notGlobalId, -- Not abstract IdInfo, -- Abstract - vanillaIdInfo, noCafIdInfo, hasCafIdInfo, + vanillaIdInfo, noCafIdInfo, seqIdInfo, megaSeqIdInfo, -- Zapping @@ -26,12 +26,14 @@ module IdInfo ( -- New demand and strictness info newStrictnessInfo, setNewStrictnessInfo, newDemandInfo, setNewDemandInfo, pprNewStrictness, + setAllStrictnessInfo, +#ifdef OLD_STRICTNESS -- Strictness; imported from Demand StrictnessInfo(..), mkStrictnessInfo, noStrictnessInfo, ppStrictnessInfo,isBottomingStrictness, - setAllStrictnessInfo, +#endif -- Worker WorkerInfo(..), workerExists, wrapperArity, workerId, @@ -64,13 +66,8 @@ module IdInfo ( -- Specialisation specInfo, setSpecInfo, - -- CG info - CgInfo(..), cgInfo, setCgInfo, pprCgInfo, - cgCafInfo, vanillaCgInfo, - CgInfoEnv, lookupCgInfo, - -- CAF info - CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs, + CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs, -- Lambda-bound variable info LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo @@ -80,12 +77,8 @@ module IdInfo ( import CoreSyn -import Type ( Type ) -import TyCon ( TyCon ) import Class ( Class ) import PrimOp ( PrimOp ) -import NameEnv ( NameEnv, lookupNameEnv ) -import Name ( Name ) import Var ( Id ) import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker, InsideLam, insideLam, notInsideLam, @@ -96,12 +89,14 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea import DataCon ( DataCon ) import ForeignCall ( ForeignCall ) import FieldLabel ( FieldLabel ) -import Demand hiding( Demand, seqDemand ) -import qualified Demand import NewDemand import Outputable import Maybe ( isJust ) + #ifdef OLD_STRICTNESS +import Name ( Name ) +import Demand hiding( Demand, seqDemand ) +import qualified Demand import Util ( listLengthCmp ) import List ( replicate ) #endif @@ -114,7 +109,6 @@ infixl 1 `setSpecInfo`, `setWorkerInfo`, `setLBVarInfo`, `setOccInfo`, - `setCgInfo`, `setCafInfo`, `setNewStrictnessInfo`, `setAllStrictnessInfo`, @@ -236,7 +230,6 @@ an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported data GlobalIdDetails = VanillaGlobal -- Imported from elsewhere, a default method Id. - | GenericOpId TyCon -- The to/from operations of a | RecordSelId FieldLabel -- The Id for a record selector | DataConWorkId DataCon -- The Id for a data constructor *worker* | DataConWrapId DataCon -- The Id for a data constructor *wrapper* @@ -257,7 +250,6 @@ notGlobalId = NotGlobalId instance Outputable GlobalIdDetails where ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]") ppr VanillaGlobal = ptext SLIT("[GlobalId]") - ppr (GenericOpId _) = ptext SLIT("[GenericOp]") ppr (DataConWorkId _) = ptext SLIT("[DataCon]") ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]") ppr (ClassOpId _) = ptext SLIT("[ClassOp]") @@ -298,7 +290,7 @@ data IdInfo #endif workerInfo :: WorkerInfo, -- Pointer to Worker Function unfoldingInfo :: Unfolding, -- Its unfolding - cgInfo :: CgInfo, -- Code generator info (arity, CAF info) + cafInfo :: CafInfo, -- CAF info lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable inlinePragInfo :: InlinePragInfo, -- Inline pragma occInfo :: OccInfo, -- How it occurs @@ -334,10 +326,8 @@ megaSeqIdInfo info seqCpr (cprInfo info) `seq` #endif --- CgInfo is involved in a loop, so we have to be careful not to seq it --- too early. --- seqCg (cgInfo info) `seq` - seqLBVar (lbvarInfo info) `seq` + seqCaf (cafInfo info) `seq` + seqLBVar (lbvarInfo info) `seq` seqOccInfo (occInfo info) \end{code} @@ -358,19 +348,6 @@ setUnfoldingInfoLazily info uf -- Lazy variant to avoid looking at the info { unfoldingInfo = uf } -- (In this case the demand-zapping is redundant.) setUnfoldingInfo info uf - | isEvaldUnfolding uf - -- If the unfolding is a value, the demand info may - -- go pear-shaped, so we nuke it. Example: - -- let x = (a,b) in - -- case x of (p,q) -> h p q x - -- Here x is certainly demanded. But after we've nuked - -- the case, we'll get just - -- let x = (a,b) in h a b x - -- and now x is not demanded (I'm assuming h is lazy) - -- This really happens. The solution here is a bit ad hoc... - = info { unfoldingInfo = uf, newDemandInfo = Nothing } - - | otherwise -- We do *not* seq on the unfolding info, For some reason, doing so -- actually increases residency significantly. = info { unfoldingInfo = uf } @@ -380,8 +357,8 @@ setDemandInfo info dd = info { demandInfo = dd } setCprInfo info cp = info { cprInfo = cp } #endif -setArityInfo info ar = info { arityInfo = ar } -setCgInfo info cg = info { cgInfo = cg } +setArityInfo info ar = info { arityInfo = ar } +setCafInfo info caf = info { cafInfo = caf } setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb } @@ -394,7 +371,7 @@ setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd } vanillaIdInfo :: IdInfo vanillaIdInfo = IdInfo { - cgInfo = noCgInfo, + cafInfo = vanillaCafInfo, arityInfo = unknownArity, #ifdef OLD_STRICTNESS cprInfo = NoCPRInfo, @@ -411,11 +388,8 @@ vanillaIdInfo newStrictnessInfo = Nothing } -hasCafIdInfo = vanillaIdInfo `setCgInfo` CgInfo MayHaveCafRefs -noCafIdInfo = vanillaIdInfo `setCgInfo` CgInfo NoCafRefs +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs -- Used for built-in type Ids in MkId. - -- These must have a valid CgInfo set, so you can't - -- use vanillaIdInfo! \end{code} @@ -499,7 +473,7 @@ this to". data WorkerInfo = NoWorker | HasWorker Id Arity -- The Arity is the arity of the *wrapper* at the moment of the - -- w/w split. See comments in MkIface.ifaceId, with the 'Worker' code. + -- w/w split. See notes above. seqWorker :: WorkerInfo -> () seqWorker (HasWorker id a) = id `seq` a `seq` () @@ -526,31 +500,7 @@ wrapperArity (HasWorker _ a) = a %* * %************************************************************************ -CgInfo encapsulates calling-convention information produced by the code -generator. It is pasted into the IdInfo of each emitted Id by CoreTidy, -but only as a thunk --- the information is only actually produced further -downstream, by the code generator. - \begin{code} -#ifndef OLD_STRICTNESS -newtype CgInfo = CgInfo CafInfo -- We are back to only having CafRefs in CgInfo -noCgInfo = panic "NoCgInfo!" -#else -data CgInfo = CgInfo CafInfo - | NoCgInfo -- In debug mode we don't want a black hole here - -- See Id.idCgInfo - -- noCgInfo is used for local Ids, which shouldn't need any CgInfo -noCgInfo = NoCgInfo -#endif - -cgCafInfo (CgInfo caf_info) = caf_info - -setCafInfo info caf_info = info `setCgInfo` CgInfo caf_info - -seqCg c = c `seq` () -- fields are strict anyhow - -vanillaCgInfo = CgInfo MayHaveCafRefs -- Definitely safe - -- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs). data CafInfo @@ -562,30 +512,17 @@ data CafInfo | NoCafRefs -- A function or static constructor -- that refers to no CAFs. +vanillaCafInfo = MayHaveCafRefs -- Definitely safe + mayHaveCafRefs MayHaveCafRefs = True mayHaveCafRefs _ = False seqCaf c = c `seq` () -pprCgInfo (CgInfo caf_info) = ppCafInfo caf_info - -ppArity 0 = empty -ppArity n = hsep [ptext SLIT("__A"), int n] - -ppCafInfo NoCafRefs = ptext SLIT("__C") +ppCafInfo NoCafRefs = ptext SLIT("NoCafRefs") ppCafInfo MayHaveCafRefs = empty \end{code} -\begin{code} -type CgInfoEnv = NameEnv CgInfo - -lookupCgInfo :: NameEnv CgInfo -> Name -> CgInfo -lookupCgInfo env n = case lookupNameEnv env n of - Just info -> info - Nothing -> pprTrace "Urk! Not in CgInfo env" (ppr n) vanillaCgInfo -\end{code} - - %************************************************************************ %* * \subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@}