%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Demand]{@Demand@: the amount of demand on a value}
\begin{code}
module Demand(
Demand(..),
topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd,
isTop, isAbsent, seqDemand,
DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
dmdTypeDepth, seqDmdType,
DmdEnv, emptyDmdEnv,
DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd,
Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
isTopSig,
splitStrictSig, increaseStrictSigArity,
pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
) where
#include "HsVersions.h"
import StaticFlags
import BasicTypes
import VarEnv
import UniqFM
import Util
import Outputable
\end{code}
%************************************************************************
%* *
\subsection{Demands}
%* *
%************************************************************************
\begin{code}
data Demand
= Top
| Abs
| Call Demand
| Eval Demands
| Defer Demands
| Box Demand
| Bot
deriving( Eq )
data Demands = Poly Demand
| Prod [Demand]
deriving( Eq )
allTop :: Demands -> Bool
allTop (Poly d) = isTop d
allTop (Prod ds) = all isTop ds
isTop :: Demand -> Bool
isTop Top = True
isTop _ = False
isAbsent :: Demand -> Bool
isAbsent Abs = True
isAbsent _ = 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)
| length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
| otherwise = Poly topDmd
topDmd, lazyDmd, seqDmd, evalDmd, errDmd :: Demand
topDmd = Top
lazyDmd = Box Abs
seqDmd = Eval (Poly Abs)
evalDmd = Box seqDmd
errDmd = Box Bot
isStrictDmd :: Demand -> Bool
isStrictDmd Bot = True
isStrictDmd (Eval _) = True
isStrictDmd (Call _) = True
isStrictDmd (Box d) = isStrictDmd d
isStrictDmd _ = 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 d@(Box _) = pprPanic "ppr: Bad boxed demand" (ppr d)
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))
\end{code}
%************************************************************************
%* *
\subsection{Demand types}
%* *
%************************************************************************
\begin{code}
data DmdType = DmdType
DmdEnv
[Demand]
DmdResult
retCPR :: DmdResult
retCPR | opt_CprOff = TopRes
| otherwise = RetCPR
seqDmdType :: DmdType -> ()
seqDmdType (DmdType _env ds res) =
seqDemandList ds `seq` res `seq` ()
type DmdEnv = VarEnv Demand
data DmdResult = TopRes
| RetCPR
| BotRes
deriving( Eq, Show )
instance Eq DmdType where
(==) (DmdType fv1 ds1 res1)
(DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2
&& ds1 == ds2 && res1 == res2
instance Outputable DmdType where
ppr (DmdType fv ds res)
= hsep [text "DmdType",
hcat (map ppr ds) <> ppr res,
if null fv_elts then empty
else braces (fsep (map pp_elt fv_elts))]
where
pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
fv_elts = ufmToList fv
instance Outputable DmdResult where
ppr TopRes = empty
ppr RetCPR = char 'm'
ppr BotRes = char 'b'
emptyDmdEnv :: VarEnv Demand
emptyDmdEnv = emptyVarEnv
topDmdType, botDmdType, cprDmdType :: DmdType
topDmdType = DmdType emptyDmdEnv [] TopRes
botDmdType = DmdType emptyDmdEnv [] BotRes
cprDmdType = DmdType emptyVarEnv [] retCPR
isTopDmdType :: DmdType -> Bool
isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
isTopDmdType _ = False
isBotRes :: DmdResult -> Bool
isBotRes BotRes = True
isBotRes _ = False
resTypeArgDmd :: DmdResult -> Demand
resTypeArgDmd TopRes = Top
resTypeArgDmd RetCPR = Top
resTypeArgDmd BotRes = Bot
returnsCPR :: DmdResult -> Bool
returnsCPR RetCPR = True
returnsCPR _ = False
mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
mkDmdType fv ds res = DmdType fv ds res
mkTopDmdType :: [Demand] -> DmdResult -> DmdType
mkTopDmdType ds res = DmdType emptyDmdEnv ds res
dmdTypeDepth :: DmdType -> Arity
dmdTypeDepth (DmdType _ ds _) = length ds
\end{code}
%************************************************************************
%* *
\subsection{Strictness signature
%* *
%************************************************************************
In a let-bound Id we record its strictness info.
In principle, this strictness info is a demand transformer, mapping
a demand on the Id into a DmdType, which gives
a) the free vars of the Id's value
b) the Id's arguments
c) an indication of the result of applying
the Id to its arguments
However, in fact we store in the Id an extremely emascuated demand transfomer,
namely
a single DmdType
(Nevertheless we dignify StrictSig as a distinct type.)
This DmdType gives the demands unleashed by the Id when it is applied
to as many arguments as are given in by the arg demands in the DmdType.
For example, the demand transformer described by the DmdType
DmdType {x -> U(LL)} [V,A] Top
says that when the function is applied to two arguments, it
unleashes demand U(LL) on the free var x, V on the first arg,
and A on the second.
If this same function is applied to one arg, all we can say is
that it uses x with U*(LL), and its arg with demand L.
\begin{code}
newtype StrictSig = StrictSig DmdType
deriving( Eq )
instance Outputable StrictSig where
ppr (StrictSig ty) = ppr ty
instance Show StrictSig where
show (StrictSig ty) = showSDoc (ppr ty)
mkStrictSig :: DmdType -> StrictSig
mkStrictSig dmd_ty = StrictSig dmd_ty
splitStrictSig :: StrictSig -> ([Demand], DmdResult)
splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
increaseStrictSigArity :: Int -> StrictSig -> StrictSig
increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
= StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)
isTopSig :: StrictSig -> Bool
isTopSig (StrictSig ty) = isTopDmdType ty
topSig, botSig, cprSig :: StrictSig
topSig = StrictSig topDmdType
botSig = StrictSig botDmdType
cprSig = StrictSig cprDmdType
appIsBottom :: StrictSig -> Int -> Bool
appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
appIsBottom _ _ = False
isBottomingSig :: StrictSig -> Bool
isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
isBottomingSig _ = False
seqStrictSig :: StrictSig -> ()
seqStrictSig (StrictSig ty) = seqDmdType ty
pprIfaceStrictSig :: StrictSig -> SDoc
pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
= hcat (map ppr dmds) <> ppr res
\end{code}