\section[Demand]{@Demand@: the amount of demand on a value}
\begin{code}
-{-# OPTIONS_GHC -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
--- for details
-
module NewDemand(
Demand(..),
topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd,
StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
isTopSig,
- splitStrictSig,
+ splitStrictSig, increaseStrictSigArity,
pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
) where
| 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)
-- case f y of (a,b,c) -> ...
-- Here the two demands on f are C(LL) and C(LLL)!
-topDmd, lazyDmd, seqDmd :: Demand
+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