X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FbasicTypes%2FIdInfo.lhs;h=27919e52057879b4918f03b8937401d7d248080d;hb=0fa26afe25a285f7d99cea8fd6e7c8258c81325d;hp=5ebfad2086c7e9224a2f2a5ecbbbc6bfdb10c992;hpb=7c8eb574b8a1a0558912426cbb225e20a3ced7ca;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 5ebfad2..27919e5 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -20,9 +20,13 @@ module IdInfo ( -- Arity ArityInfo(..), - exactArity, atLeastArity, unknownArity, hasArity, + exactArity, unknownArity, hasArity, arityInfo, setArityInfo, ppArityInfo, arityLowerBound, + -- New demand and strictness info + newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo, + newDemandInfo, setNewDemandInfo, newDemand, + -- Strictness; imported from Demand StrictnessInfo(..), mkStrictnessInfo, noStrictnessInfo, @@ -77,7 +81,7 @@ module IdInfo ( import CoreSyn -import Type ( Type, usOnce ) +import Type ( Type, usOnce, eqUsage ) import PrimOp ( PrimOp ) import NameEnv ( NameEnv, lookupNameEnv ) import Name ( Name ) @@ -88,11 +92,14 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea Arity ) import DataCon ( DataCon ) +import ForeignCall ( ForeignCall ) import FieldLabel ( FieldLabel ) import Type ( usOnce, usMany ) import Demand -- Lots of stuff +import qualified NewDemand import Outputable import Util ( seqList ) +import List ( replicate ) infixl 1 `setDemandInfo`, `setTyGenInfo`, @@ -107,12 +114,50 @@ infixl 1 `setDemandInfo`, `setOccInfo`, `setCgInfo`, `setCafInfo`, - `setCgArity` + `setCgArity`, + `setNewStrictnessInfo`, + `setNewDemandInfo` -- infixl so you can say (id `set` a `set` b) \end{code} %************************************************************************ %* * +\subsection{New strictness info} +%* * +%************************************************************************ + +To be removed later + +\begin{code} +mkNewStrictnessInfo :: Id -> Arity -> StrictnessInfo -> CprInfo -> NewDemand.StrictSig +mkNewStrictnessInfo id arity NoStrictnessInfo cpr + = NewDemand.mkStrictSig id + arity + (NewDemand.mkTopDmdType (replicate arity NewDemand.Lazy) (newRes False cpr)) + +mkNewStrictnessInfo id arity (StrictnessInfo ds res) cpr + = NewDemand.mkStrictSig id + arity + (NewDemand.mkTopDmdType (take arity (map newDemand ds)) (newRes res cpr)) + -- Sometimes the old strictness analyser has more + -- demands than the arity justifies + +newRes True _ = NewDemand.BotRes +newRes False ReturnsCPR = NewDemand.RetCPR +newRes False NoCPRInfo = NewDemand.TopRes + +newDemand :: Demand -> NewDemand.Demand +newDemand (WwLazy True) = NewDemand.Abs +newDemand (WwLazy False) = NewDemand.Lazy +newDemand WwStrict = NewDemand.Eval +newDemand (WwUnpack unpk ds) = NewDemand.Seq NewDemand.Drop NewDemand.Now (map newDemand ds) +newDemand WwPrim = NewDemand.Lazy +newDemand WwEnum = NewDemand.Eval +\end{code} + + +%************************************************************************ +%* * \subsection{GlobalIdDetails %* * %************************************************************************ @@ -134,6 +179,7 @@ data GlobalIdDetails -- Id back to the data con] | PrimOpId PrimOp -- The Id for a primitive operator + | FCallId ForeignCall -- The Id for a foreign call | NotGlobalId -- Used as a convenient extra return value from globalIdDetails @@ -145,6 +191,7 @@ instance Outputable GlobalIdDetails where ppr (DataConId _) = ptext SLIT("[DataCon]") ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]") ppr (PrimOpId _) = ptext SLIT("[PrimOp]") + ppr (FCallId _) = ptext SLIT("[ForeignCall]") ppr (RecordSelId _) = ptext SLIT("[RecSel]") \end{code} @@ -182,7 +229,10 @@ data IdInfo cprInfo :: CprInfo, -- Function always constructs a product result lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable inlinePragInfo :: InlinePragInfo, -- Inline pragma - occInfo :: OccInfo -- How it occurs + occInfo :: OccInfo, -- How it occurs + + newStrictnessInfo :: Maybe NewDemand.StrictSig, + newDemandInfo :: NewDemand.Demand } seqIdInfo :: IdInfo -> () @@ -239,10 +289,13 @@ setUnfoldingInfo info uf = info { unfoldingInfo = uf } setDemandInfo info dd = info { demandInfo = dd } -setArityInfo info ar = info { arityInfo = ar } +setArityInfo info ar = info { arityInfo = Just ar } setCgInfo info cg = info { cgInfo = cg } setCprInfo info cp = info { cprInfo = cp } setLBVarInfo info lb = info { lbvarInfo = lb } + +setNewDemandInfo info dd = info { newDemandInfo = dd } +setNewStrictnessInfo info dd = info { newStrictnessInfo = Just dd } \end{code} @@ -251,7 +304,7 @@ vanillaIdInfo :: IdInfo vanillaIdInfo = IdInfo { cgInfo = noCgInfo, - arityInfo = UnknownArity, + arityInfo = unknownArity, demandInfo = wwLazy, specInfo = emptyCoreRules, tyGenInfo = noTyGenInfo, @@ -261,7 +314,9 @@ vanillaIdInfo cprInfo = NoCPRInfo, lbvarInfo = NoLBVarInfo, inlinePragInfo = NoInlinePragInfo, - occInfo = NoOccInfo + occInfo = NoOccInfo, + newDemandInfo = NewDemand.topDmd, + newStrictnessInfo = Nothing } noCafNoTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever @@ -283,42 +338,31 @@ of their arities; so it should not be asking... (but other things besides the code-generator need arity info!) \begin{code} -data ArityInfo - = UnknownArity -- No idea +type ArityInfo = Maybe Arity + -- A partial application of this Id to up to n-1 value arguments + -- does essentially no work. That is not necessarily the + -- same as saying that it has n leading lambdas, because coerces + -- may get in the way. - | ArityExactly Arity -- Arity is exactly this. We use this when importing a - -- function; it's already been compiled and we know its - -- arity for sure. - - | ArityAtLeast Arity -- A partial application of this Id to up to n-1 value arguments - -- does essentially no work. That is not necessarily the - -- same as saying that it has n leading lambdas, because coerces - -- may get in the way. - - -- functions in the module being compiled. Their arity - -- might increase later in the compilation process, if - -- an extra lambda floats up to the binding site. - deriving( Eq ) + -- The arity might increase later in the compilation process, if + -- an extra lambda floats up to the binding site. seqArity :: ArityInfo -> () seqArity a = arityLowerBound a `seq` () -exactArity = ArityExactly -atLeastArity = ArityAtLeast -unknownArity = UnknownArity +exactArity = Just +unknownArity = Nothing arityLowerBound :: ArityInfo -> Arity -arityLowerBound UnknownArity = 0 -arityLowerBound (ArityAtLeast n) = n -arityLowerBound (ArityExactly n) = n +arityLowerBound Nothing = 0 +arityLowerBound (Just n) = n hasArity :: ArityInfo -> Bool -hasArity UnknownArity = False -hasArity other = True +hasArity Nothing = False +hasArity other = True -ppArityInfo UnknownArity = empty -ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("ArityExactly"), int arity] -ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("ArityAtLeast"), int arity] +ppArityInfo Nothing = empty +ppArityInfo (Just arity) = hsep [ptext SLIT("Arity"), int arity] \end{code} %************************************************************************ @@ -392,8 +436,6 @@ data TyGenInfo -- preserve specified usage annotations | TyGenNever -- never generalise the type of this Id - - deriving ( Eq ) \end{code} For TyGenUInfo, the list has one entry for each usage annotation on @@ -425,9 +467,9 @@ ppTyGenInfo (TyGenUInfo us) = ptext SLIT("__G") <+> text (tyGenInfoString us) ppTyGenInfo TyGenNever = ptext SLIT("__G N") tyGenInfoString us = map go us - where go Nothing = 'x' -- for legibility, choose - go (Just u) | u == usOnce = '1' -- chars with identity - | u == usMany = 'M' -- Z-encoding. + where go Nothing = 'x' -- for legibility, choose + go (Just u) | u `eqUsage` usOnce = '1' -- chars with identity + | u `eqUsage` usMany = 'M' -- Z-encoding. go other = pprPanic "IdInfo.tyGenInfoString: unexpected annotation" (ppr other) instance Outputable TyGenInfo where @@ -511,6 +553,15 @@ downstream, by the code generator. data CgInfo = CgInfo !Arity -- Exact arity for calling purposes !CafInfo +#ifdef DEBUG + | 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 +#else +noCgInfo = panic "NoCgInfo!" +#endif cgArity (CgInfo arity _) = arity cgCafInfo (CgInfo _ caf_info) = caf_info @@ -523,9 +574,6 @@ setCgArity info arity = case cgInfo info of { CgInfo _ caf_info -> info `setCgInfo` CgInfo arity caf_info } - -- Used for local Ids, which shouldn't need any CgInfo -noCgInfo = panic "noCgInfo!" - cgMayHaveCafRefs (CgInfo _ caf_info) = mayHaveCafRefs caf_info seqCg c = c `seq` () -- fields are strict anyhow @@ -661,7 +709,7 @@ noLBVarInfo = NoLBVarInfo -- not safe to print or parse LBVarInfo because it is not really a -- property of the definition, but a property of the context. pprLBVarInfo NoLBVarInfo = empty -pprLBVarInfo (LBVarInfo u) | u == usOnce +pprLBVarInfo (LBVarInfo u) | u `eqUsage` usOnce = getPprStyle $ \ sty -> if ifaceStyle sty then empty