%
+% (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}
StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
isTopSig,
- splitStrictSig,
+ splitStrictSig, increaseStrictSigArity,
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 StaticFlags
+import BasicTypes
+import VarEnv
+import UniqFM
+import Util
import Outputable
\end{code}
| Prod [Demand] -- Product case
deriving( Eq )
+allTop :: Demands -> Bool
allTop (Poly d) = isTop d
allTop (Prod ds) = all isTop ds
+isTop :: Demand -> Bool
isTop Top = True
-isTop d = False
+isTop _ = False
+isAbsent :: Demand -> Bool
isAbsent Abs = True
-isAbsent d = False
+isAbsent _ = False
mapDmds :: (Demand -> Demand) -> Demands -> Demands
mapDmds f (Poly d) = Poly (f d)
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
+zipWithDmds f (Prod ds1) (Prod ds2)
+ | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
+ | otherwise = Poly topDmd
+ -- This really can happen with polymorphism
+ -- \f. case f x of (a,b) -> ...
+ -- case f y of (a,b,c) -> ...
+ -- Here the two demands on f are C(LL) and C(LLL)!
+
+topDmd, lazyDmd, seqDmd, evalDmd, errDmd :: Demand
topDmd = Top -- The most uninformative demand
lazyDmd = Box Abs
seqDmd = Eval (Poly Abs) -- Polymorphic seq demand
isStrictDmd (Eval _) = True
isStrictDmd (Call _) = True
isStrictDmd (Box d) = isStrictDmd d
-isStrictDmd other = False
+isStrictDmd _ = False
seqDemand :: Demand -> ()
seqDemand (Call d) = seqDemand d
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)
-- 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 :: DmdResult
retCPR | opt_CprOff = TopRes
| otherwise = RetCPR
-seqDmdType (DmdType env ds res) =
+seqDmdType :: DmdType -> ()
+seqDmdType (DmdType _env ds res) =
{- ??? env `seq` -} seqDemandList ds `seq` res `seq` ()
type DmdEnv = VarEnv Demand
ppr BotRes = char 'b' -- dddr
-- without ambiguity
+emptyDmdEnv :: VarEnv Demand
emptyDmdEnv = emptyVarEnv
+topDmdType, botDmdType, cprDmdType :: DmdType
topDmdType = DmdType emptyDmdEnv [] TopRes
botDmdType = DmdType emptyDmdEnv [] BotRes
cprDmdType = DmdType emptyVarEnv [] retCPR
isTopDmdType :: DmdType -> Bool
-- Only used on top-level types, hence the assert
isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True
-isTopDmdType other = False
+isTopDmdType _ = False
isBotRes :: DmdResult -> Bool
isBotRes BotRes = True
-isBotRes other = False
+isBotRes _ = False
resTypeArgDmd :: DmdResult -> Demand
-- TopRes and BotRes are polymorphic, so that
returnsCPR :: DmdResult -> Bool
returnsCPR RetCPR = True
-returnsCPR other = False
+returnsCPR _ = False
mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
mkDmdType fv ds res = DmdType fv ds res
splitStrictSig :: StrictSig -> ([Demand], DmdResult)
splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
+increaseStrictSigArity :: Int -> StrictSig -> StrictSig
+-- Add extra arguments to a strictness signature
+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
-- appIsBottom returns true if an application to n args would diverge
+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