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 ...@@ -71,6 +71,7 @@ import VarSet
import TyCoRep import TyCoRep
import TyCoTidy ( tidyCo ) import TyCoTidy ( tidyCo )
import Demand ( isTopSig ) import Demand ( isTopSig )
import Cpr ( topCprSig )
import Data.Maybe ( catMaybes ) import Data.Maybe ( catMaybes )
...@@ -442,7 +443,7 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) ...@@ -442,7 +443,7 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
toIfaceIdInfo :: IdInfo -> IfaceIdInfo toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info 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 inline_hsinfo, unfold_hsinfo, levity_hsinfo] of
[] -> NoInfo [] -> NoInfo
infos -> HasInfo infos infos -> HasInfo infos
...@@ -466,6 +467,10 @@ toIfaceIdInfo id_info ...@@ -466,6 +467,10 @@ toIfaceIdInfo id_info
strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info)
| otherwise = Nothing | otherwise = Nothing
------------ CPR --------------
cpr_info = cprInfo id_info
cpr_hsinfo | cpr_info /= topCprSig = Just (HsCpr cpr_info)
| otherwise = Nothing
------------ Unfolding -------------- ------------ Unfolding --------------
unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
loop_breaker = isStrongLoopBreaker (occInfo id_info) loop_breaker = isStrongLoopBreaker (occInfo id_info)
......
...@@ -49,6 +49,7 @@ import BinFingerprint ...@@ -49,6 +49,7 @@ import BinFingerprint
import CoreSyn( IsOrphan, isOrphan ) import CoreSyn( IsOrphan, isOrphan )
import DynFlags( gopt, GeneralFlag (Opt_PrintAxiomIncomps) ) import DynFlags( gopt, GeneralFlag (Opt_PrintAxiomIncomps) )
import Demand import Demand
import Cpr
import Class import Class
import FieldLabel import FieldLabel
import NameSet import NameSet
...@@ -344,6 +345,7 @@ data IfaceIdInfo ...@@ -344,6 +345,7 @@ data IfaceIdInfo
data IfaceInfoItem data IfaceInfoItem
= HsArity Arity = HsArity Arity
| HsStrictness StrictSig | HsStrictness StrictSig
| HsCpr CprSig
| HsInline InlinePragma | HsInline InlinePragma
| HsUnfold Bool -- True <=> isStrongLoopBreaker is true | HsUnfold Bool -- True <=> isStrongLoopBreaker is true
IfaceUnfolding -- See Note [Expose recursive functions] IfaceUnfolding -- See Note [Expose recursive functions]
...@@ -1394,7 +1396,8 @@ instance Outputable IfaceInfoItem where ...@@ -1394,7 +1396,8 @@ instance Outputable IfaceInfoItem where
<> colon <+> ppr unf <> colon <+> ppr unf
ppr (HsInline prag) = text "Inline:" <+> ppr prag ppr (HsInline prag) = text "Inline:" <+> ppr prag
ppr (HsArity arity) = text "Arity:" <+> int arity 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 HsNoCafRefs = text "HasNoCafRefs"
ppr HsLevity = text "Never levity-polymorphic" ppr HsLevity = text "Never levity-polymorphic"
...@@ -2168,6 +2171,7 @@ instance Binary IfaceInfoItem where ...@@ -2168,6 +2171,7 @@ instance Binary IfaceInfoItem where
put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad
put_ bh HsNoCafRefs = putByte bh 4 put_ bh HsNoCafRefs = putByte bh 4
put_ bh HsLevity = putByte bh 5 put_ bh HsLevity = putByte bh 5
put_ bh (HsCpr cpr) = putByte bh 6 >> put_ bh cpr
get bh = do get bh = do
h <- getByte bh h <- getByte bh
case h of case h of
...@@ -2178,7 +2182,8 @@ instance Binary IfaceInfoItem where ...@@ -2178,7 +2182,8 @@ instance Binary IfaceInfoItem where
return (HsUnfold lb ad) return (HsUnfold lb ad)
3 -> liftM HsInline $ get bh 3 -> liftM HsInline $ get bh
4 -> return HsNoCafRefs 4 -> return HsNoCafRefs
_ -> return HsLevity 5 -> return HsLevity
_ -> HsCpr <$> get bh
instance Binary IfaceUnfolding where instance Binary IfaceUnfolding where
put_ bh (IfCoreUnfold s e) = do put_ bh (IfCoreUnfold s e) = do
...@@ -2513,6 +2518,7 @@ instance NFData IfaceInfoItem where ...@@ -2513,6 +2518,7 @@ instance NFData IfaceInfoItem where
HsUnfold b unf -> rnf b `seq` rnf unf HsUnfold b unf -> rnf b `seq` rnf unf
HsNoCafRefs -> () HsNoCafRefs -> ()
HsLevity -> () HsLevity -> ()
HsCpr cpr -> cpr `seq` ()
instance NFData IfaceUnfolding where instance NFData IfaceUnfolding where
rnf = \case rnf = \case
......
...@@ -40,6 +40,7 @@ import IdInfo ...@@ -40,6 +40,7 @@ import IdInfo
import InstEnv import InstEnv
import Type ( tidyTopType ) import Type ( tidyTopType )
import Demand ( appIsBottom, isTopSig, isBottomingSig ) import Demand ( appIsBottom, isTopSig, isBottomingSig )
import Cpr ( mkCprSig, botCpr )
import BasicTypes import BasicTypes
import Name hiding (varName) import Name hiding (varName)
import NameSet import NameSet
...@@ -1150,6 +1151,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold ...@@ -1150,6 +1151,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
-- c.f. CoreTidy.tidyLetBndr -- c.f. CoreTidy.tidyLetBndr
`setArityInfo` arity `setArityInfo` arity
`setStrictnessInfo` final_sig `setStrictnessInfo` final_sig
`setCprInfo` final_cpr
`setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness]
-- in CoreTidy -- in CoreTidy
...@@ -1157,6 +1159,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold ...@@ -1157,6 +1159,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
= vanillaIdInfo = vanillaIdInfo
`setArityInfo` arity `setArityInfo` arity
`setStrictnessInfo` final_sig `setStrictnessInfo` final_sig
`setCprInfo` final_cpr
`setOccInfo` robust_occ_info `setOccInfo` robust_occ_info
`setInlinePragInfo` (inlinePragInfo idinfo) `setInlinePragInfo` (inlinePragInfo idinfo)
`setUnfoldingInfo` unfold_info `setUnfoldingInfo` unfold_info
...@@ -1180,6 +1183,12 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold ...@@ -1180,6 +1183,12 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
| Just (_, nsig) <- mb_bot_str = nsig | Just (_, nsig) <- mb_bot_str = nsig
| otherwise = sig | 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 _bottom_hidden id_sig = case mb_bot_str of
Nothing -> False Nothing -> False
Just (arity, _) -> not (appIsBottom id_sig arity) Just (arity, _) -> not (appIsBottom id_sig arity)
......
...@@ -1475,6 +1475,7 @@ tcIdInfo ignore_prags toplvl name ty info = do ...@@ -1475,6 +1475,7 @@ tcIdInfo ignore_prags toplvl name ty info = do
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity) tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str) 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 (HsInline prag) = return (info `setInlinePragInfo` prag)
tcPrag info HsLevity = return (info `setNeverLevPoly` ty) 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 ( ...@@ -29,12 +29,8 @@ module Demand (
DmdEnv, emptyDmdEnv, DmdEnv, emptyDmdEnv,
peelFV, findIdDemand, peelFV, findIdDemand,
DmdResult, CPRResult, Divergence(..), lubDivergence, isBotDiv, isTopDiv, topDiv, botDiv,
isBotRes, isTopRes,
topRes, botRes, cprProdRes,
vanillaCprProdRes, cprSumRes,
appIsBottom, isBottomingSig, pprIfaceStrictSig, appIsBottom, isBottomingSig, pprIfaceStrictSig,
trimCPRInfo, returnsCPR_maybe,
StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,
nopSig, botSig, cprProdSig, nopSig, botSig, cprProdSig,
isTopSig, hasDemandEnvSig, isTopSig, hasDemandEnvSig,
...@@ -146,9 +142,9 @@ Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, ...@@ -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 Ben opened #11222. Simon made the demand analyser "understand catch" in
9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call 9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call
its argument strictly, but also swallow any thrown exceptions in 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 '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, between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330,
so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17).
...@@ -900,85 +896,41 @@ splitProdDmd_maybe (JD { sd = s, ud = u }) ...@@ -900,85 +896,41 @@ splitProdDmd_maybe (JD { sd = s, ud = u })
{- {-
************************************************************************ ************************************************************************
* * * *
Demand results Termination
* * * *
************************************************************************ ************************************************************************
Divergence: Dunno
DmdResult: Dunno CPRResult
/ /
Diverges Diverges
CPRResult: NoCPR
/ \
RetProd RetSum ConTag
Product constructors return (Dunno (RetProd rs))
In a fixpoint iteration, start from Diverges In a fixpoint iteration, start from Diverges
We have lubs, but not glbs; but that is ok.
-} -}
------------------------------------------------------------------------ data Divergence
-- Constructed Product Result
------------------------------------------------------------------------
data Termination r
= Diverges -- Definitely diverges = Diverges -- Definitely diverges
| Dunno r -- Might diverge or converge | Dunno -- Might diverge or converge
deriving( Eq, Show ) deriving( Eq, Show )
-- At this point, Termination is just the 'Lifted' lattice over 'r' lubDivergence :: Divergence -> Divergence ->Divergence
-- (https://hackage.haskell.org/package/lattices/docs/Algebra-Lattice-Lifted.html) lubDivergence Diverges r = r
lubDivergence r Diverges = r
type DmdResult = Termination CPRResult lubDivergence Dunno Dunno = Dunno
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)
-- This needs to commute with defaultDmd, i.e. -- 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) -- (See Note [Default demand on free variables] for why)
bothDmdResult :: DmdResult -> Termination () -> DmdResult bothDivergence :: Divergence -> Divergence -> Divergence
-- See Note [Asymmetry of 'both' for DmdType and DmdResult] -- See Note [Asymmetry of 'both' for DmdType and Divergence]
bothDmdResult _ Diverges = Diverges bothDivergence _ Diverges = Diverges
bothDmdResult r (Dunno {}) = r bothDivergence r Dunno = r
-- This needs to commute with defaultDmd, i.e. -- 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) -- (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 Diverges = char 'b'
ppr (Dunno c) = ppr c ppr Dunno = empty
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 = ()
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- Combined demand result -- -- Combined demand result --
...@@ -986,64 +938,33 @@ seqCPRResult RetProd = () ...@@ -986,64 +938,33 @@ seqCPRResult RetProd = ()
-- [cprRes] lets us switch off CPR analysis -- [cprRes] lets us switch off CPR analysis
-- by making sure that everything uses TopRes -- by making sure that everything uses TopRes
topRes, botRes :: DmdResult topDiv, botDiv :: Divergence
topRes = Dunno NoCPR topDiv = Dunno
botRes = Diverges botDiv = Diverges
cprSumRes :: ConTag -> DmdResult isTopDiv :: Divergence -> Bool
cprSumRes tag = Dunno $ RetSum tag isTopDiv Dunno = True
isTopDiv _ = False
cprProdRes :: [DmdType] -> DmdResult
cprProdRes _arg_tys = Dunno $ RetProd
vanillaCprProdRes :: Arity -> DmdResult
vanillaCprProdRes _arity = Dunno $ RetProd
isTopRes :: DmdResult -> Bool
isTopRes (Dunno NoCPR) = True
isTopRes _ = False
-- | True if the result diverges or throws an exception -- | True if the result diverges or throws an exception
isBotRes :: DmdResult -> Bool isBotDiv :: Divergence -> Bool
isBotRes Diverges = True isBotDiv Diverges = True
isBotRes (Dunno {}) = False isBotDiv _ = 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
-- See Notes [Default demand on free variables] -- See Notes [Default demand on free variables]
-- and [defaultDmd vs. resTypeArgDmd] -- and [defaultDmd vs. resTypeArgDmd]
defaultDmd :: Termination r -> Demand defaultDmd :: Divergence -> Demand
defaultDmd (Dunno {}) = absDmd defaultDmd Dunno = absDmd
defaultDmd _ = botDmd -- Diverges defaultDmd _ = botDmd -- Diverges
resTypeArgDmd :: Termination r -> Demand resTypeArgDmd :: Divergence -> Demand
-- TopRes and BotRes are polymorphic, so that -- TopRes and BotRes are polymorphic, so that
-- BotRes === (Bot -> BotRes) === ... -- BotRes === (Bot -> BotRes) === ...
-- TopRes === (Top -> TopRes) === ... -- TopRes === (Top -> TopRes) === ...
-- This function makes that concrete -- This function makes that concrete
-- Also see Note [defaultDmd vs. resTypeArgDmd] -- Also see Note [defaultDmd vs. resTypeArgDmd]
resTypeArgDmd (Dunno _) = topDmd resTypeArgDmd Dunno = topDmd
resTypeArgDmd _ = botDmd -- Diverges resTypeArgDmd _ = botDmd -- Diverges
{- {-
Note [defaultDmd and resTypeArgDmd] Note [defaultDmd and resTypeArgDmd]
...@@ -1070,12 +991,12 @@ data DmdType = DmdType ...@@ -1070,12 +991,12 @@ data DmdType = DmdType
DmdEnv -- Demand on explicitly-mentioned DmdEnv -- Demand on explicitly-mentioned
-- free variables -- free variables
[Demand] -- Demand on arguments [Demand] -- Demand on arguments
DmdResult -- See [Nature of result demand] Divergence -- See [Nature of result demand]
{- {-
Note [Nature of result demand] Note [Nature of result demand]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~