isTop, isAbsent, seqDemand,
DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
- dmdTypeDepth, dmdTypeRes, seqDmdType,
+ dmdTypeDepth, seqDmdType,
DmdEnv, emptyDmdEnv,
- DmdResult(..), isBotRes, returnsCPR, resTypeArgDmd,
+ DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd,
Demands(..), mapDmds, zipWithDmds, allTop, seqDemands,
- StrictSig(..), mkStrictSig, topSig, botSig, isTopSig,
- splitStrictSig, strictSigResInfo,
+ 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 )
instance Outputable Demands where
ppr (Poly Abs) = empty
ppr (Poly d) = parens (ppr d <> char '*')
- ppr (Prod ds) | all isAbsent ds = empty
- | otherwise = parens (hcat (map ppr ds))
+ 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}
-- 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` ()
-- 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
-- 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
-resTypeArgDmd RetCPR = panic "resTypeArgDmd: RetCPR"
returnsCPR :: DmdResult -> Bool
returnsCPR RetCPR = True
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 = listLengthCmp ds n /= GT