X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FNewDemand.lhs;h=8e68fd87d23cd00495ee25ff460358cd903a8031;hb=10dd2a6d050e4779782800184014b8738fadc679;hp=532ad463a5e40ca62f63f53b4295f986ed7dfb23;hpb=9e93335020e64a811dbbb223e1727c76933a93ae;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs index 532ad46..8e68fd8 100644 --- a/ghc/compiler/basicTypes/NewDemand.lhs +++ b/ghc/compiler/basicTypes/NewDemand.lhs @@ -5,31 +5,140 @@ \begin{code} module NewDemand( - Demand(..), Keepity(..), - mkSeq, topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd, defer, + Demand(..), + topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd, + isTop, isAbsent, seqDemand, DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, - dmdTypeDepth, dmdTypeRes, + dmdTypeDepth, seqDmdType, DmdEnv, emptyDmdEnv, - DmdResult(..), isBotRes, returnsCPR, - - StrictSig(..), mkStrictSig, topSig, botSig, isTopSig, - splitStrictSig, strictSigResInfo, - pprIfaceStrictSig, appIsBottom, isBottomingSig + DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd, + + Demands(..), mapDmds, zipWithDmds, allTop, seqDemands, + + StrictSig(..), mkStrictSig, topSig, botSig, cprSig, + isTopSig, + splitStrictSig, + pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig, ) where #include "HsVersions.h" +import StaticFlags ( opt_CprOff ) import BasicTypes ( Arity ) import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv ) import UniqFM ( ufmToList ) -import Util ( listLengthCmp ) +import Util ( listLengthCmp, zipWithEqual ) import Outputable \end{code} %************************************************************************ %* * +\subsection{Demands} +%* * +%************************************************************************ + +\begin{code} +data Demand + = Top -- T; used for unlifted types too, so that + -- A `lub` T = T + | Abs -- A + + | Call Demand -- C(d) + + | Eval Demands -- U(ds) + + | Defer Demands -- D(ds) + + | Box Demand -- B(d) + + | Bot -- B + deriving( Eq ) + -- Equality needed for fixpoints in DmdAnal + +data Demands = Poly Demand -- Polymorphic case + | Prod [Demand] -- Product case + deriving( Eq ) + +allTop (Poly d) = isTop d +allTop (Prod ds) = all isTop ds + +isTop Top = True +isTop d = False + +isAbsent Abs = True +isAbsent d = False + +mapDmds :: (Demand -> Demand) -> Demands -> Demands +mapDmds f (Poly d) = Poly (f d) +mapDmds f (Prod ds) = Prod (map f ds) + +zipWithDmds :: (Demand -> Demand -> Demand) + -> Demands -> Demands -> Demands +zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2) +zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1] +zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2] +zipWithDmds f (Prod ds1) (Prod ds2) = Prod (zipWithEqual "zipWithDmds" f ds1 ds2) + +topDmd, lazyDmd, seqDmd :: Demand +topDmd = Top -- The most uninformative demand +lazyDmd = Box Abs +seqDmd = Eval (Poly Abs) -- Polymorphic seq demand +evalDmd = Box seqDmd -- Evaluate and return +errDmd = Box Bot -- This used to be called X + +isStrictDmd :: Demand -> Bool +isStrictDmd Bot = True +isStrictDmd (Eval _) = True +isStrictDmd (Call _) = True +isStrictDmd (Box d) = isStrictDmd d +isStrictDmd other = False + +seqDemand :: Demand -> () +seqDemand (Call d) = seqDemand d +seqDemand (Eval ds) = seqDemands ds +seqDemand (Defer ds) = seqDemands ds +seqDemand (Box d) = seqDemand d +seqDemand _ = () + +seqDemands :: Demands -> () +seqDemands (Poly d) = seqDemand d +seqDemands (Prod ds) = seqDemandList ds + +seqDemandList :: [Demand] -> () +seqDemandList [] = () +seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds + +instance Outputable Demand where + ppr Top = char 'T' + ppr Abs = char 'A' + ppr Bot = char 'B' + + ppr (Defer ds) = char 'D' <> ppr ds + ppr (Eval ds) = char 'U' <> ppr ds + + ppr (Box (Eval ds)) = char 'S' <> ppr ds + ppr (Box Abs) = char 'L' + ppr (Box Bot) = char 'X' + + ppr (Call d) = char 'C' <> parens (ppr d) + + +instance Outputable Demands where + ppr (Poly Abs) = empty + ppr (Poly d) = parens (ppr d <> char '*') + ppr (Prod ds) = parens (hcat (map ppr ds)) + -- At one time I printed U(AAA) as U, but that + -- confuses (Poly Abs) with (Prod AAA), and the + -- worker/wrapper generation differs slightly for these two + -- [Reason: in the latter case we can avoid passing the arg; + -- see notes with WwLib.mkWWstr_one.] +\end{code} + + +%************************************************************************ +%* * \subsection{Demand types} %* * %************************************************************************ @@ -48,10 +157,21 @@ data DmdType = DmdType -- ANOTHER IMPORTANT INVARIANT -- The Demands in the argument list are never - -- Bot, Err, Seq Defer ds + -- Bot, Defer d -- Handwavey reason: these don't correspond to calling conventions -- See DmdAnal.funArgDemand for details + +-- This guy lets us switch off CPR analysis +-- by making sure that everything uses TopRes instead of RetCPR +-- Assuming, of course, that they don't mention RetCPR by name. +-- They should onlyu use retCPR +retCPR | opt_CprOff = TopRes + | otherwise = RetCPR + +seqDmdType (DmdType env ds res) = + {- ??? env `seq` -} seqDemandList ds `seq` res `seq` () + type DmdEnv = VarEnv Demand data DmdResult = TopRes -- Nothing known @@ -84,8 +204,10 @@ instance Outputable DmdResult where -- without ambiguity emptyDmdEnv = emptyVarEnv + topDmdType = DmdType emptyDmdEnv [] TopRes botDmdType = DmdType emptyDmdEnv [] BotRes +cprDmdType = DmdType emptyVarEnv [] retCPR isTopDmdType :: DmdType -> Bool -- Only used on top-level types, hence the assert @@ -96,6 +218,18 @@ isBotRes :: DmdResult -> Bool isBotRes BotRes = True isBotRes other = False +resTypeArgDmd :: DmdResult -> Demand +-- TopRes and BotRes are polymorphic, so that +-- BotRes = Bot -> BotRes +-- TopRes = Top -> TopRes +-- This function makes that concrete +-- We can get a RetCPR, because of the way in which we are (now) +-- giving CPR info to strict arguments. On the first pass, when +-- nothing has demand info, we optimistically give CPR info or RetCPR to all args +resTypeArgDmd TopRes = Top +resTypeArgDmd RetCPR = Top +resTypeArgDmd BotRes = Bot + returnsCPR :: DmdResult -> Bool returnsCPR RetCPR = True returnsCPR other = False @@ -108,9 +242,6 @@ mkTopDmdType ds res = DmdType emptyDmdEnv ds res dmdTypeDepth :: DmdType -> Arity dmdTypeDepth (DmdType _ ds _) = length ds - -dmdTypeRes :: DmdType -> DmdResult -dmdTypeRes (DmdType _ _ res_ty) = res_ty \end{code} @@ -161,13 +292,13 @@ mkStrictSig dmd_ty = StrictSig dmd_ty splitStrictSig :: StrictSig -> ([Demand], DmdResult) splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) -strictSigResInfo :: StrictSig -> DmdResult -strictSigResInfo (StrictSig (DmdType _ _ res)) = res - isTopSig (StrictSig ty) = isTopDmdType ty +topSig, botSig, cprSig :: StrictSig topSig = StrictSig topDmdType botSig = StrictSig botDmdType +cprSig = StrictSig cprDmdType + -- appIsBottom returns true if an application to n args would diverge appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT @@ -176,6 +307,8 @@ appIsBottom _ _ = False isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True isBottomingSig _ = False +seqStrictSig (StrictSig ty) = seqDmdType ty + pprIfaceStrictSig :: StrictSig -> SDoc -- Used for printing top-level strictness pragmas in interface files pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) @@ -183,84 +316,3 @@ pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) \end{code} -%************************************************************************ -%* * -\subsection{Demands} -%* * -%************************************************************************ - -\begin{code} -data Demand - = Lazy -- L; used for unlifted types too, so that - -- A `lub` L = L - | Abs -- A - - | Call Demand -- C(d) - | Eval -- V - | Seq Keepity -- S/U/D(ds) - [Demand] -- S(ds) = L `both` U(ds) - -- D(ds) = A `lub` U(ds) - -- *** Invariant: these demands are never Bot or Abs - -- *** Invariant: if all demands are Abs, get [] - - | Err -- X - | Bot -- B - deriving( Eq ) - -- Equality needed for fixpoints in DmdAnal - -data Keepity = Keep -- Strict and I need the box - | Drop -- Strict, but I don't need the box - | Defer -- Lazy, if you *do* evaluate, I need - -- the components but not the box - deriving( Eq ) - -mkSeq :: Keepity -> [Demand] -> Demand -mkSeq k ds | all is_absent ds = Seq k [] - | otherwise = Seq k ds - where - is_absent Abs = True - is_absent d = False - -defer :: Demand -> Demand --- Computes (Abs `lub` d) --- For the Bot case consider --- f x y = if ... then x else error x --- Then for y we get Abs `lub` Bot, and we really --- want Abs overall -defer Bot = Abs -defer Abs = Abs -defer (Seq Keep ds) = Lazy -defer (Seq _ ds) = Seq Defer ds -defer d = Lazy - -topDmd, lazyDmd, seqDmd :: Demand -topDmd = Lazy -- The most uninformative demand -lazyDmd = Lazy -seqDmd = Seq Keep [] -- Polymorphic seq demand -evalDmd = Eval - -isStrictDmd :: Demand -> Bool -isStrictDmd Bot = True -isStrictDmd Err = True -isStrictDmd (Seq Drop _) = True -- But not Defer! -isStrictDmd (Seq Keep _) = True -isStrictDmd Eval = True -isStrictDmd (Call _) = True -isStrictDmd other = False - -instance Outputable Demand where - ppr Lazy = char 'L' - ppr Abs = char 'A' - ppr Eval = char 'V' - ppr Err = char 'X' - ppr Bot = char 'B' - ppr (Call d) = char 'C' <> parens (ppr d) - ppr (Seq k []) = ppr k - ppr (Seq k ds) = ppr k <> parens (hcat (map ppr ds)) - -instance Outputable Keepity where - ppr Keep = char 'S' - ppr Drop = char 'U' - ppr Defer = char 'D' -\end{code} -