Commit 059c3c9d authored by Sebastian Graf's avatar Sebastian Graf

Separate CPR analysis from the Demand analyser

The reasons for that can be found in the wiki:
https://gitlab.haskell.org/ghc/ghc/wikis/nested-cpr/split-off-cpr

We now run CPR after demand analysis (except for after the final demand
analysis run just before code gen). CPR got its own dump flags
(`-ddump-cpr-anal`, `-ddump-cpr-signatures`), but not its own flag to
activate/deactivate. It will run with `-fstrictness`/`-fworker-wrapper`.

As explained on the wiki page, this step is necessary for a sane Nested
CPR analysis. And it has quite positive impact on compiler performance:

Metric Decrease:
    T9233
    T9675
    T9961
    T15263
parent f0c0ee7d
......@@ -71,6 +71,7 @@ import VarSet
import TyCoRep
import TyCoTidy ( tidyCo )
import Demand ( isTopSig )
import Cpr ( topCprSig )
import Data.Maybe ( catMaybes )
......@@ -442,7 +443,7 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
= case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
= case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo,
inline_hsinfo, unfold_hsinfo, levity_hsinfo] of
[] -> NoInfo
infos -> HasInfo infos
......@@ -466,6 +467,10 @@ toIfaceIdInfo id_info
strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info)
| otherwise = Nothing
------------ CPR --------------
cpr_info = cprInfo id_info
cpr_hsinfo | cpr_info /= topCprSig = Just (HsCpr cpr_info)
| otherwise = Nothing
------------ Unfolding --------------
unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
loop_breaker = isStrongLoopBreaker (occInfo id_info)
......
......@@ -49,6 +49,7 @@ import BinFingerprint
import CoreSyn( IsOrphan, isOrphan )
import DynFlags( gopt, GeneralFlag (Opt_PrintAxiomIncomps) )
import Demand
import Cpr
import Class
import FieldLabel
import NameSet
......@@ -344,6 +345,7 @@ data IfaceIdInfo
data IfaceInfoItem
= HsArity Arity
| HsStrictness StrictSig
| HsCpr CprSig
| HsInline InlinePragma
| HsUnfold Bool -- True <=> isStrongLoopBreaker is true
IfaceUnfolding -- See Note [Expose recursive functions]
......@@ -1394,7 +1396,8 @@ instance Outputable IfaceInfoItem where
<> colon <+> ppr unf
ppr (HsInline prag) = text "Inline:" <+> ppr prag
ppr (HsArity arity) = text "Arity:" <+> int arity
ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str
ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str
ppr (HsCpr cpr) = text "CPR:" <+> ppr cpr
ppr HsNoCafRefs = text "HasNoCafRefs"
ppr HsLevity = text "Never levity-polymorphic"
......@@ -2168,6 +2171,7 @@ instance Binary IfaceInfoItem where
put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad
put_ bh HsNoCafRefs = putByte bh 4
put_ bh HsLevity = putByte bh 5
put_ bh (HsCpr cpr) = putByte bh 6 >> put_ bh cpr
get bh = do
h <- getByte bh
case h of
......@@ -2178,7 +2182,8 @@ instance Binary IfaceInfoItem where
return (HsUnfold lb ad)
3 -> liftM HsInline $ get bh
4 -> return HsNoCafRefs
_ -> return HsLevity
5 -> return HsLevity
_ -> HsCpr <$> get bh
instance Binary IfaceUnfolding where
put_ bh (IfCoreUnfold s e) = do
......@@ -2513,6 +2518,7 @@ instance NFData IfaceInfoItem where
HsUnfold b unf -> rnf b `seq` rnf unf
HsNoCafRefs -> ()
HsLevity -> ()
HsCpr cpr -> cpr `seq` ()
instance NFData IfaceUnfolding where
rnf = \case
......
......@@ -40,6 +40,7 @@ import IdInfo
import InstEnv
import Type ( tidyTopType )
import Demand ( appIsBottom, isTopSig, isBottomingSig )
import Cpr ( mkCprSig, botCpr )
import BasicTypes
import Name hiding (varName)
import NameSet
......@@ -1150,6 +1151,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
-- c.f. CoreTidy.tidyLetBndr
`setArityInfo` arity
`setStrictnessInfo` final_sig
`setCprInfo` final_cpr
`setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness]
-- in CoreTidy
......@@ -1157,6 +1159,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
= vanillaIdInfo
`setArityInfo` arity
`setStrictnessInfo` final_sig
`setCprInfo` final_cpr
`setOccInfo` robust_occ_info
`setInlinePragInfo` (inlinePragInfo idinfo)
`setUnfoldingInfo` unfold_info
......@@ -1180,6 +1183,12 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
| Just (_, nsig) <- mb_bot_str = nsig
| otherwise = sig
cpr = cprInfo idinfo
final_cpr | Just _ <- mb_bot_str
= mkCprSig arity botCpr
| otherwise
= cpr
_bottom_hidden id_sig = case mb_bot_str of
Nothing -> False
Just (arity, _) -> not (appIsBottom id_sig arity)
......
......@@ -1475,6 +1475,7 @@ tcIdInfo ignore_prags toplvl name ty info = do
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
tcPrag info (HsCpr cpr) = return (info `setCprInfo` cpr)
tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
tcPrag info HsLevity = return (info `setNeverLevPoly` ty)
......
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
-- | Types for the Constructed Product Result lattice. "CprAnal" and "WwLib"
-- are its primary customers via 'idCprInfo'.
module Cpr (
CprResult, topCpr, botCpr, conCpr, asConCpr,
CprType (..), topCprType, botCprType, conCprType,
lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy,
CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig
) where
import GhcPrelude
import BasicTypes
import Outputable
import Binary
--
-- * CprResult
--
-- | The constructed product result lattice.
--
-- @
-- NoCPR
-- |
-- ConCPR ConTag
-- |
-- BotCPR
-- @
data CprResult = NoCPR -- ^ Top of the lattice
| ConCPR !ConTag -- ^ Returns a constructor from a data type
| BotCPR -- ^ Bottom of the lattice
deriving( Eq, Show )
lubCpr :: CprResult -> CprResult -> CprResult
lubCpr (ConCPR t1) (ConCPR t2)
| t1 == t2 = ConCPR t1
lubCpr BotCPR cpr = cpr
lubCpr cpr BotCPR = cpr
lubCpr _ _ = NoCPR
topCpr :: CprResult
topCpr = NoCPR
botCpr :: CprResult
botCpr = BotCPR
conCpr :: ConTag -> CprResult
conCpr = ConCPR
trimCpr :: CprResult -> CprResult
trimCpr ConCPR{} = NoCPR
trimCpr cpr = cpr
asConCpr :: CprResult -> Maybe ConTag
asConCpr (ConCPR t) = Just t
asConCpr NoCPR = Nothing
asConCpr BotCPR = Nothing
--
-- * CprType
--
-- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper.
data CprType
= CprType
{ ct_arty :: !Arity -- ^ Number of value arguments the denoted expression
-- eats before returning the 'ct_cpr'
, ct_cpr :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to
-- 'ct_arty' arguments
}
instance Eq CprType where
a == b = ct_cpr a == ct_cpr b
&& (ct_arty a == ct_arty b || ct_cpr a == topCpr)
topCprType :: CprType
topCprType = CprType 0 topCpr
botCprType :: CprType
botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments
conCprType :: ConTag -> CprType
conCprType con_tag = CprType 0 (conCpr con_tag)
lubCprType :: CprType -> CprType -> CprType
lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2)
-- The arity of bottom CPR types can be extended arbitrarily.
| cpr1 == botCpr && n1 <= n2 = ty2
| cpr2 == botCpr && n2 <= n1 = ty1
-- There might be non-bottom CPR types with mismatching arities.
-- Consider test DmdAnalGADTs. We want to return top in these cases.
| n1 == n2 = CprType n1 (lubCpr cpr1 cpr2)
| otherwise = topCprType
applyCprTy :: CprType -> CprType
applyCprTy (CprType n res)
| n > 0 = CprType (n-1) res
| res == botCpr = botCprType
| otherwise = topCprType
abstractCprTy :: CprType -> CprType
abstractCprTy (CprType n res)
| res == topCpr = topCprType
| otherwise = CprType (n+1) res
ensureCprTyArity :: Arity -> CprType -> CprType
ensureCprTyArity n ty@(CprType m _)
| n == m = ty
| otherwise = topCprType
trimCprTy :: CprType -> CprType
trimCprTy (CprType arty res) = CprType arty (trimCpr res)
-- | The arity of the wrapped 'CprType' is the arity at which it is safe
-- to unleash. See Note [Understanding DmdType and StrictSig] in Demand
newtype CprSig = CprSig { getCprSig :: CprType }
deriving (Eq, Binary)
-- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig'
-- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in
-- Demand
mkCprSigForArity :: Arity -> CprType -> CprSig
mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty)
topCprSig :: CprSig
topCprSig = CprSig topCprType
mkCprSig :: Arity -> CprResult -> CprSig
mkCprSig arty cpr = CprSig (CprType arty cpr)
seqCprSig :: CprSig -> ()
seqCprSig sig = sig `seq` ()
instance Outputable CprResult where
ppr NoCPR = empty
ppr (ConCPR n) = char 'm' <> int n
ppr BotCPR = char 'b'
instance Outputable CprType where
ppr (CprType arty res) = ppr arty <> ppr res
-- | Only print the CPR result
instance Outputable CprSig where
ppr (CprSig ty) = ppr (ct_cpr ty)
instance Binary CprResult where
put_ bh (ConCPR n) = do { putByte bh 0; put_ bh n }
put_ bh NoCPR = putByte bh 1
put_ bh BotCPR = putByte bh 2
get bh = do
h <- getByte bh
case h of
0 -> do { n <- get bh; return (ConCPR n) }
1 -> return NoCPR
_ -> return BotCPR
instance Binary CprType where
put_ bh (CprType arty cpr) = do
put_ bh arty
put_ bh cpr
get bh = CprType <$> get bh <*> get bh
......@@ -29,12 +29,8 @@ module Demand (
DmdEnv, emptyDmdEnv,
peelFV, findIdDemand,
DmdResult, CPRResult,
isBotRes, isTopRes,
topRes, botRes, cprProdRes,
vanillaCprProdRes, cprSumRes,
Divergence(..), lubDivergence, isBotDiv, isTopDiv, topDiv, botDiv,
appIsBottom, isBottomingSig, pprIfaceStrictSig,
trimCPRInfo, returnsCPR_maybe,
StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,
nopSig, botSig, cprProdSig,
isTopSig, hasDemandEnvSig,
......@@ -146,9 +142,9 @@ Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712,
Ben opened #11222. Simon made the demand analyser "understand catch" in
9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call
its argument strictly, but also swallow any thrown exceptions in
'postProcessDmdResult'. This was realized by extending the 'Str' constructor of
'postProcessDivergence'. This was realized by extending the 'Str' constructor of
'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and
adding a 'ThrowsExn' constructor to the 'Termination' lattice as an element
adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element
between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330,
so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17).
......@@ -900,85 +896,41 @@ splitProdDmd_maybe (JD { sd = s, ud = u })
{-
************************************************************************
* *
Demand results
Termination
* *
************************************************************************
DmdResult: Dunno CPRResult
Divergence: Dunno
/
Diverges
CPRResult: NoCPR
/ \
RetProd RetSum ConTag
Product constructors return (Dunno (RetProd rs))
In a fixpoint iteration, start from Diverges
We have lubs, but not glbs; but that is ok.
-}
------------------------------------------------------------------------
-- Constructed Product Result
------------------------------------------------------------------------
data Termination r
data Divergence
= Diverges -- Definitely diverges
| Dunno r -- Might diverge or converge
| Dunno -- Might diverge or converge
deriving( Eq, Show )
-- At this point, Termination is just the 'Lifted' lattice over 'r'
-- (https://hackage.haskell.org/package/lattices/docs/Algebra-Lattice-Lifted.html)
type DmdResult = Termination CPRResult
data CPRResult = NoCPR -- Top of the lattice
| RetProd -- Returns a constructor from a product type
| RetSum ConTag -- Returns a constructor from a data type
deriving( Eq, Show )
lubCPR :: CPRResult -> CPRResult -> CPRResult
lubCPR (RetSum t1) (RetSum t2)
| t1 == t2 = RetSum t1
lubCPR RetProd RetProd = RetProd
lubCPR _ _ = NoCPR
lubDmdResult :: DmdResult -> DmdResult -> DmdResult
lubDmdResult Diverges r = r
lubDmdResult r Diverges = r
lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2)
lubDivergence :: Divergence -> Divergence ->Divergence
lubDivergence Diverges r = r
lubDivergence r Diverges = r
lubDivergence Dunno Dunno = Dunno
-- This needs to commute with defaultDmd, i.e.
-- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2
-- defaultDmd (r1 `lubDivergence` r2) = defaultDmd r1 `lubDmd` defaultDmd r2
-- (See Note [Default demand on free variables] for why)
bothDmdResult :: DmdResult -> Termination () -> DmdResult
-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
bothDmdResult _ Diverges = Diverges
bothDmdResult r (Dunno {}) = r
bothDivergence :: Divergence -> Divergence -> Divergence
-- See Note [Asymmetry of 'both' for DmdType and Divergence]
bothDivergence _ Diverges = Diverges
bothDivergence r Dunno = r
-- This needs to commute with defaultDmd, i.e.
-- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2
-- defaultDmd (r1 `bothDivergence` r2) = defaultDmd r1 `bothDmd` defaultDmd r2
-- (See Note [Default demand on free variables] for why)
instance Outputable r => Outputable (Termination r) where
instance Outputable Divergence where
ppr Diverges = char 'b'
ppr (Dunno c) = ppr c
instance Outputable CPRResult where
ppr NoCPR = empty
ppr (RetSum n) = char 'm' <> int n
ppr RetProd = char 'm'
seqDmdResult :: DmdResult -> ()
seqDmdResult Diverges = ()
seqDmdResult (Dunno c) = seqCPRResult c
seqCPRResult :: CPRResult -> ()
seqCPRResult NoCPR = ()
seqCPRResult (RetSum n) = n `seq` ()
seqCPRResult RetProd = ()
ppr Dunno = empty
------------------------------------------------------------------------
-- Combined demand result --
......@@ -986,64 +938,33 @@ seqCPRResult RetProd = ()
-- [cprRes] lets us switch off CPR analysis
-- by making sure that everything uses TopRes
topRes, botRes :: DmdResult
topRes = Dunno NoCPR
botRes = Diverges
topDiv, botDiv :: Divergence
topDiv = Dunno
botDiv = Diverges
cprSumRes :: ConTag -> DmdResult
cprSumRes tag = Dunno $ RetSum tag
cprProdRes :: [DmdType] -> DmdResult
cprProdRes _arg_tys = Dunno $ RetProd
vanillaCprProdRes :: Arity -> DmdResult
vanillaCprProdRes _arity = Dunno $ RetProd
isTopRes :: DmdResult -> Bool
isTopRes (Dunno NoCPR) = True
isTopRes _ = False
isTopDiv :: Divergence -> Bool
isTopDiv Dunno = True
isTopDiv _ = False
-- | True if the result diverges or throws an exception
isBotRes :: DmdResult -> Bool
isBotRes Diverges = True
isBotRes (Dunno {}) = False
trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult
trimCPRInfo trim_all trim_sums res
= trimR res
where
trimR (Dunno c) = Dunno (trimC c)
trimR res = res
trimC (RetSum n) | trim_all || trim_sums = NoCPR
| otherwise = RetSum n
trimC RetProd | trim_all = NoCPR
| otherwise = RetProd
trimC NoCPR = NoCPR
returnsCPR_maybe :: DmdResult -> Maybe ConTag
returnsCPR_maybe (Dunno c) = retCPR_maybe c
returnsCPR_maybe _ = Nothing
retCPR_maybe :: CPRResult -> Maybe ConTag
retCPR_maybe (RetSum t) = Just t
retCPR_maybe RetProd = Just fIRST_TAG
retCPR_maybe NoCPR = Nothing
isBotDiv :: Divergence -> Bool
isBotDiv Diverges = True
isBotDiv _ = False
-- See Notes [Default demand on free variables]
-- and [defaultDmd vs. resTypeArgDmd]
defaultDmd :: Termination r -> Demand
defaultDmd (Dunno {}) = absDmd
defaultDmd _ = botDmd -- Diverges
defaultDmd :: Divergence -> Demand
defaultDmd Dunno = absDmd
defaultDmd _ = botDmd -- Diverges
resTypeArgDmd :: Termination r -> Demand
resTypeArgDmd :: Divergence -> Demand
-- TopRes and BotRes are polymorphic, so that
-- BotRes === (Bot -> BotRes) === ...
-- TopRes === (Top -> TopRes) === ...
-- This function makes that concrete
-- Also see Note [defaultDmd vs. resTypeArgDmd]
resTypeArgDmd (Dunno _) = topDmd
resTypeArgDmd _ = botDmd -- Diverges
resTypeArgDmd Dunno = topDmd
resTypeArgDmd _ = botDmd -- Diverges
{-
Note [defaultDmd and resTypeArgDmd]
......@@ -1070,12 +991,12 @@ data DmdType = DmdType
DmdEnv -- Demand on explicitly-mentioned
-- free variables
[Demand] -- Demand on arguments
DmdResult -- See [Nature of result demand]
Divergence -- See [Nature of result demand]
{-
Note [Nature of result demand]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A DmdResult contains information about termination (currently distinguishing
A Divergence contains information about termination (currently distinguishing
definite divergence and no information; it is possible to include definite
convergence here), and CPR information about the result.
......@@ -1110,10 +1031,10 @@ Now consider a function h with signature "<C(S)>", and the expression
now h puts a demand of <C(S)> onto its argument, and the demand transformer
turns it into
<S>b
Now the DmdResult "b" does apply to us, even though "b1 `seq` ()" does not
Now the Divergence "b" does apply to us, even though "b1 `seq` ()" does not
diverge, and we do not anything being passed to b.
Note [Asymmetry of 'both' for DmdType and DmdResult]
Note [Asymmetry of 'both' for DmdType and Divergence]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'both' for DmdTypes is *asymmetrical*, because there is only one
result! For example, given (e1 e2), we get a DmdType dt1 for e1, use
......@@ -1129,21 +1050,21 @@ We
3. combine the termination results, but
4. take CPR info from the first argument.
3 and 4 are implemented in bothDmdResult.
3 and 4 are implemented in bothDivergence.
-}
-- Equality needed for fixpoints in DmdAnal
instance Eq DmdType where
(==) (DmdType fv1 ds1 res1)
(DmdType fv2 ds2 res2) = nonDetUFMToList fv1 == nonDetUFMToList fv2
(==) (DmdType fv1 ds1 div1)
(DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2
-- It's OK to use nonDetUFMToList here because we're testing for
-- equality and even though the lists will be in some arbitrary
-- Unique order, it is the same order for both
&& ds1 == ds2 && res1 == res2
&& ds1 == ds2 && div1 == div2
lubDmdType :: DmdType -> DmdType -> DmdType
lubDmdType d1 d2
= DmdType lub_fv lub_ds lub_res
= DmdType lub_fv lub_ds lub_div
where
n = max (dmdTypeDepth d1) (dmdTypeDepth d2)
(DmdType fv1 ds1 r1) = ensureArgs n d1
......@@ -1151,7 +1072,7 @@ lubDmdType d1 d2
lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2)
lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2
lub_res = lubDmdResult r1 r2
lub_div = lubDivergence r1 r2
{-
Note [The need for BothDmdArg]
......@@ -1163,25 +1084,25 @@ the demand put on arguments, nor cpr information. So we make that explicit by
only passing the relevant information.
-}
type BothDmdArg = (DmdEnv, Termination ())
type BothDmdArg = (DmdEnv, Divergence)
mkBothDmdArg :: DmdEnv -> BothDmdArg
mkBothDmdArg env = (env, Dunno ())
mkBothDmdArg env = (env, Dunno)
toBothDmdArg :: DmdType -> BothDmdArg
toBothDmdArg (DmdType fv _ r) = (fv, go r)
where
go (Dunno {}) = Dunno ()
go Diverges = Diverges
go Dunno = Dunno
go Diverges = Diverges
bothDmdType :: DmdType -> BothDmdArg -> DmdType
bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)
-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
-- See Note [Asymmetry of 'both' for DmdType and Divergence]
-- 'both' takes the argument/result info from its *first* arg,
-- using its second arg just for its free-var info.
= DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2))
ds1
(r1 `bothDmdResult` t2)
(r1 `bothDivergence` t2)
instance Outputable DmdType where
ppr (DmdType fv ds res)
......@@ -1202,19 +1123,15 @@ emptyDmdEnv = emptyVarEnv
-- Note that it is ''not'' the top of the lattice (which would be "may use everything"),
-- so it is (no longer) called topDmd
nopDmdType, botDmdType :: DmdType
nopDmdType = DmdType emptyDmdEnv [] topRes
botDmdType = DmdType emptyDmdEnv [] botRes
cprProdDmdType :: Arity -> DmdType
cprProdDmdType arity
= DmdType emptyDmdEnv [] (vanillaCprProdRes arity)
nopDmdType = DmdType emptyDmdEnv [] topDiv
botDmdType = DmdType emptyDmdEnv [] botDiv
isTopDmdType :: DmdType -> Bool
isTopDmdType (DmdType env [] res)
| isTopRes res && isEmptyVarEnv env = True
| isTopDiv res && isEmptyVarEnv env = True
isTopDmdType _ = False
mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType
mkDmdType fv ds res = DmdType fv ds res
dmdTypeDepth :: DmdType -> Arity
......@@ -1222,7 +1139,7 @@ dmdTypeDepth (DmdType _ ds _) = length ds
-- | This makes sure we can use the demand type with n arguments.
-- It extends the argument list with the correct resTypeArgDmd.
-- It also adjusts the DmdResult: Divergence survives additional arguments,
-- It also adjusts the Divergence: Divergence survives additional arguments,