\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, 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}
%* *
%************************************************************************
-- 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
-- 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
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
dmdTypeDepth :: DmdType -> Arity
dmdTypeDepth (DmdType _ ds _) = length ds
-
-dmdTypeRes :: DmdType -> DmdResult
-dmdTypeRes (DmdType _ _ res_ty) = res_ty
\end{code}
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 = n >= length ds
+appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
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))
\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}
-
projects / ghc-hetmet.git / blobdiff