X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FIdInfo.lhs;h=c106f5397c1684843af20aa615db478e059ecfca;hp=9b74a487f0e663191ceac67a15013808186a80b6;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=6a944ae7fe1e8e2e456c68717188463263f8978f diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 9b74a48..c106f53 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -10,7 +10,7 @@ Haskell. [WDP 94/11]) \begin{code} module IdInfo ( -- * The IdDetails type - IdDetails(..), pprIdDetails, + IdDetails(..), pprIdDetails, coVarDetails, -- * The IdInfo type IdInfo, -- Abstract @@ -26,28 +26,8 @@ module IdInfo ( arityInfo, setArityInfo, ppArityInfo, -- ** Demand and strictness Info - newStrictnessInfo, setNewStrictnessInfo, - newDemandInfo, setNewDemandInfo, pprNewStrictness, - setAllStrictnessInfo, - -#ifdef OLD_STRICTNESS - -- ** Old strictness Info - StrictnessInfo(..), - mkStrictnessInfo, noStrictnessInfo, - ppStrictnessInfo, isBottomingStrictness, - strictnessInfo, setStrictnessInfo, - - oldStrictnessFromNew, newStrictnessFromOld, - - -- ** Old demand Info - demandInfo, setDemandInfo, - oldDemand, newDemand, - - -- ** Old Constructed Product Result Info - CprInfo(..), - cprInfo, setCprInfo, ppCprInfo, noCprInfo, - cprInfoFromNewStrictness, -#endif + strictnessInfo, setStrictnessInfo, + demandInfo, setDemandInfo, pprStrictness, -- ** Unfolding Info unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily, @@ -66,6 +46,7 @@ module IdInfo ( -- ** The SpecInfo type SpecInfo(..), + emptySpecInfo, isEmptySpecInfo, specInfoFreeVars, specInfoRules, seqSpecInfo, setSpecInfoHead, specInfo, setSpecInfo, @@ -84,7 +65,7 @@ module IdInfo ( TickBoxOp(..), TickBoxId, ) where -import CoreSyn ( CoreRule, setRuleIdName, seqRules, Unfolding, noUnfolding ) +import CoreSyn import Class import PrimOp @@ -94,20 +75,13 @@ import BasicTypes import DataCon import TyCon import ForeignCall -import NewDemand +import Demand import Outputable import Module import FastString import Data.Maybe -#ifdef OLD_STRICTNESS -import Demand -import qualified Demand -import Util -import Data.List -#endif - -- infixl so you can say (id `set` a `set` b) infixl 1 `setSpecInfo`, `setArityInfo`, @@ -116,115 +90,10 @@ infixl 1 `setSpecInfo`, `setLBVarInfo`, `setOccInfo`, `setCafInfo`, - `setNewStrictnessInfo`, - `setAllStrictnessInfo`, - `setNewDemandInfo` -#ifdef OLD_STRICTNESS - , `setCprInfo` - , `setDemandInfo` - , `setStrictnessInfo` -#endif -\end{code} - -%************************************************************************ -%* * -\subsection{New strictness info} -%* * -%************************************************************************ - -To be removed later - -\begin{code} --- | Set old and new strictness information together -setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo -setAllStrictnessInfo info Nothing - = info { newStrictnessInfo = Nothing -#ifdef OLD_STRICTNESS - , strictnessInfo = NoStrictnessInfo - , cprInfo = NoCPRInfo -#endif - } - -setAllStrictnessInfo info (Just sig) - = info { newStrictnessInfo = Just sig -#ifdef OLD_STRICTNESS - , strictnessInfo = oldStrictnessFromNew sig - , cprInfo = cprInfoFromNewStrictness sig -#endif - } - -seqNewStrictnessInfo :: Maybe StrictSig -> () -seqNewStrictnessInfo Nothing = () -seqNewStrictnessInfo (Just ty) = seqStrictSig ty - -pprNewStrictness :: Maybe StrictSig -> SDoc -pprNewStrictness Nothing = empty -pprNewStrictness (Just sig) = ppr sig - -#ifdef OLD_STRICTNESS -oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo -oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) - where - (dmds, res_info) = splitStrictSig sig - -cprInfoFromNewStrictness :: StrictSig -> CprInfo -cprInfoFromNewStrictness sig = case strictSigResInfo sig of - RetCPR -> ReturnsCPR - other -> NoCPRInfo - -newStrictnessFromOld :: Name -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig -newStrictnessFromOld name arity (Demand.StrictnessInfo ds res) cpr - | listLengthCmp ds arity /= GT -- length ds <= arity - -- Sometimes the old strictness analyser has more - -- demands than the arity justifies - = mk_strict_sig name arity $ - mkTopDmdType (map newDemand ds) (newRes res cpr) - -newStrictnessFromOld name arity other cpr - = -- Either no strictness info, or arity is too small - -- In either case we can't say anything useful - mk_strict_sig name arity $ - mkTopDmdType (replicate arity lazyDmd) (newRes False cpr) - -mk_strict_sig name arity dmd_ty - = WARN( arity /= dmdTypeDepth dmd_ty, ppr name <+> (ppr arity $$ ppr dmd_ty) ) - mkStrictSig dmd_ty - -newRes True _ = BotRes -newRes False ReturnsCPR = retCPR -newRes False NoCPRInfo = TopRes - -newDemand :: Demand.Demand -> NewDemand.Demand -newDemand (WwLazy True) = Abs -newDemand (WwLazy False) = lazyDmd -newDemand WwStrict = evalDmd -newDemand (WwUnpack unpk ds) = Eval (Prod (map newDemand ds)) -newDemand WwPrim = lazyDmd -newDemand WwEnum = evalDmd - -oldDemand :: NewDemand.Demand -> Demand.Demand -oldDemand Abs = WwLazy True -oldDemand Top = WwLazy False -oldDemand Bot = WwStrict -oldDemand (Box Bot) = WwStrict -oldDemand (Box Abs) = WwLazy False -oldDemand (Box (Eval _)) = WwStrict -- Pass box only -oldDemand (Defer d) = WwLazy False -oldDemand (Eval (Prod ds)) = WwUnpack True (map oldDemand ds) -oldDemand (Eval (Poly _)) = WwStrict -oldDemand (Call _) = WwStrict - -#endif /* OLD_STRICTNESS */ -\end{code} - - -\begin{code} -seqNewDemandInfo :: Maybe Demand -> () -seqNewDemandInfo Nothing = () -seqNewDemandInfo (Just dmd) = seqDemand dmd + `setStrictnessInfo`, + `setDemandInfo` \end{code} - %************************************************************************ %* * IdDetails @@ -260,11 +129,20 @@ data IdDetails | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - | DFunId Bool -- ^ A dictionary function. - -- True <=> the class has only one method, so may be - -- implemented with a newtype, so it might be bad - -- to be strict on this dictionary - + | DFunId Int Bool -- ^ A dictionary function. + -- Int = the number of "silent" arguments to the dfun + -- e.g. class D a => C a where ... + -- instance C a => C [a] + -- has is_silent = 1, because the dfun + -- has type dfun :: (D a, C a) => C [a] + -- See the DFun Superclass Invariant in TcInstDcls + -- + -- Bool = True <=> the class has only one method, so may be + -- implemented with a newtype, so it might be bad + -- to be strict on this dictionary + +coVarDetails :: IdDetails +coVarDetails = VanillaId instance Outputable IdDetails where ppr = pprIdDetails @@ -280,8 +158,9 @@ pprIdDetails other = brackets (pp other) pp (PrimOpId _) = ptext (sLit "PrimOp") pp (FCallId _) = ptext (sLit "ForeignCall") pp (TickBoxOpId _) = ptext (sLit "TickBoxOp") - pp (DFunId b) = ptext (sLit "DFunId") <> - ppWhen b (ptext (sLit "(newtype)")) + pp (DFunId ns nt) = ptext (sLit "DFunId") + <> ppWhen (ns /= 0) (brackets (int ns)) + <> ppWhen nt (ptext (sLit "(nt)")) pp (RecSelId { sel_naughty = is_naughty }) = brackets $ ptext (sLit "RecSel") <> ppWhen is_naughty (ptext (sLit "(naughty)")) @@ -311,23 +190,18 @@ data IdInfo arityInfo :: !ArityInfo, -- ^ 'Id' arity specInfo :: SpecInfo, -- ^ Specialisations of the 'Id's function which exist -- See Note [Specialisations and RULES in IdInfo] -#ifdef OLD_STRICTNESS - cprInfo :: CprInfo, -- ^ If the 'Id's function always constructs a product result - demandInfo :: Demand.Demand, -- ^ Whether or not the 'Id' is definitely demanded - strictnessInfo :: StrictnessInfo, -- ^ 'Id' strictness properties -#endif unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding cafInfo :: CafInfo, -- ^ 'Id' CAF info lbvarInfo :: LBVarInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id' occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program - newStrictnessInfo :: Maybe StrictSig, -- ^ Id strictness information. Reason for Maybe: + strictnessInfo :: Maybe StrictSig, -- ^ Id strictness information. Reason for Maybe: -- the DmdAnal phase needs to know whether -- this is the first visit, so it can assign botSig. -- Other customers want topSig. So @Nothing@ is good. - newDemandInfo :: Maybe Demand -- ^ Id demand information. Similarly we want to know + demandInfo :: Maybe Demand -- ^ Id demand information. Similarly we want to know -- if there's no known demand yet, for when we are looking -- for CPR info } @@ -346,18 +220,20 @@ megaSeqIdInfo info -- some unfoldings are not calculated at all -- seqUnfolding (unfoldingInfo info) `seq` - seqNewDemandInfo (newDemandInfo info) `seq` - seqNewStrictnessInfo (newStrictnessInfo info) `seq` - -#ifdef OLD_STRICTNESS - Demand.seqDemand (demandInfo info) `seq` - seqStrictnessInfo (strictnessInfo info) `seq` - seqCpr (cprInfo info) `seq` -#endif + seqDemandInfo (demandInfo info) `seq` + seqStrictnessInfo (strictnessInfo info) `seq` seqCaf (cafInfo info) `seq` seqLBVar (lbvarInfo info) `seq` seqOccInfo (occInfo info) + +seqStrictnessInfo :: Maybe StrictSig -> () +seqStrictnessInfo Nothing = () +seqStrictnessInfo (Just ty) = seqStrictSig ty + +seqDemandInfo :: Maybe Demand -> () +seqDemandInfo Nothing = () +seqDemandInfo (Just dmd) = seqDemand dmd \end{code} Setters @@ -369,9 +245,6 @@ setInlinePragInfo :: IdInfo -> InlinePragma -> 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 @@ -381,14 +254,11 @@ setUnfoldingInfoLazily info uf -- Lazy variant to avoid looking at the setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo setUnfoldingInfo info uf - -- We do *not* seq on the unfolding info, For some reason, doing so - -- actually increases residency significantly. - = info { unfoldingInfo = uf } - -#ifdef OLD_STRICTNESS -setDemandInfo info dd = info { demandInfo = dd } -setCprInfo info cp = info { cprInfo = cp } -#endif + = -- We don't seq the unfolding, as we generate intermediate + -- unfoldings which are just thrown away, so evaluating them is a + -- waste of time. + -- seqUnfolding uf `seq` + info { unfoldingInfo = uf } setArityInfo :: IdInfo -> ArityInfo -> IdInfo setArityInfo info ar = info { arityInfo = ar } @@ -398,10 +268,11 @@ 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 } +setDemandInfo :: IdInfo -> Maybe Demand -> IdInfo +setDemandInfo info dd = dd `seq` info { demandInfo = dd } + +setStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo +setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } \end{code} @@ -412,18 +283,13 @@ vanillaIdInfo = IdInfo { cafInfo = vanillaCafInfo, arityInfo = unknownArity, -#ifdef OLD_STRICTNESS - cprInfo = NoCPRInfo, - demandInfo = wwLazy, - strictnessInfo = NoStrictnessInfo, -#endif specInfo = emptySpecInfo, unfoldingInfo = noUnfolding, lbvarInfo = NoLBVarInfo, inlinePragInfo = defaultInlinePragma, occInfo = NoOccInfo, - newDemandInfo = Nothing, - newStrictnessInfo = Nothing + demandInfo = Nothing, + strictnessInfo = Nothing } -- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references @@ -485,6 +351,19 @@ type InlinePragInfo = InlinePragma %************************************************************************ %* * + Strictness +%* * +%************************************************************************ + +\begin{code} +pprStrictness :: Maybe StrictSig -> SDoc +pprStrictness Nothing = empty +pprStrictness (Just sig) = ppr sig +\end{code} + + +%************************************************************************ +%* * SpecInfo %* * %************************************************************************ @@ -586,59 +465,6 @@ ppCafInfo MayHaveCafRefs = empty %************************************************************************ %* * -\subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@} -%* * -%************************************************************************ - -\begin{code} -#ifdef OLD_STRICTNESS --- | If the @Id@ is a function then it may have Constructed Product Result --- (CPR) info. A CPR analysis phase detects whether: --- --- 1. The function's return value has a product type, i.e. an algebraic type --- with a single constructor. Examples of such types are tuples and boxed --- primitive values. --- --- 2. The function always 'constructs' the value that it is returning. It --- must do this on every path through, and it's OK if it calls another --- function which constructs the result. --- --- If this is the case then we store a template which tells us the --- function has the CPR property and which components of the result are --- also CPRs. -data CprInfo - = NoCPRInfo -- ^ No, this function does not return a constructed product - | ReturnsCPR -- ^ Yes, this function returns a constructed product - - -- Implicitly, this means "after the function has been applied - -- to all its arguments", so the worker\/wrapper builder in - -- WwLib.mkWWcpr checks that that it is indeed saturated before - -- making use of the CPR info - - -- We used to keep nested info about sub-components, but - -- we never used it so I threw it away - --- | It's always safe to assume that an 'Id' does not have the CPR property -noCprInfo :: CprInt -noCprInfo = NoCPRInfo - -seqCpr :: CprInfo -> () -seqCpr ReturnsCPR = () -seqCpr NoCPRInfo = () - -ppCprInfo NoCPRInfo = empty -ppCprInfo ReturnsCPR = ptext (sLit "__M") - -instance Outputable CprInfo where - ppr = ppCprInfo - -instance Show CprInfo where - showsPrec p c = showsPrecSDoc p (ppr c) -#endif -\end{code} - -%************************************************************************ -%* * \subsection[lbvar-IdInfo]{Lambda-bound var info about an @Id@} %* * %************************************************************************ @@ -690,11 +516,11 @@ instance Show LBVarInfo where -- -- > (\x1. \x2. e) arg1 zapLamInfo :: IdInfo -> Maybe IdInfo -zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand}) +zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) | is_safe_occ occ && is_safe_dmd demand = Nothing | otherwise - = Just (info {occInfo = safe_occ, newDemandInfo = Nothing}) + = Just (info {occInfo = safe_occ, demandInfo = Nothing}) where -- 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 @@ -712,8 +538,8 @@ zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand}) \begin{code} -- | Remove demand info on the 'IdInfo' if it is present, otherwise return @Nothing@ zapDemandInfo :: IdInfo -> Maybe IdInfo -zapDemandInfo info@(IdInfo {newDemandInfo = dmd}) - | isJust dmd = Just (info {newDemandInfo = Nothing}) +zapDemandInfo info@(IdInfo {demandInfo = dmd}) + | isJust dmd = Just (info {demandInfo = Nothing}) | otherwise = Nothing \end{code}