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
Pipeline #15731 failed with stages
in 414 minutes and 29 seconds
......@@ -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
This diff is collapsed.
......@@ -107,9 +107,11 @@ module Id (
setIdDemandInfo,
setIdStrictness,
setIdCprInfo,
idDemandInfo,
idStrictness,
idCprInfo,
) where
......@@ -137,6 +139,7 @@ import GHC.Types.RepType
import TysPrim
import DataCon
import Demand
import Cpr
import Name
import Module
import Class
......@@ -164,6 +167,7 @@ infixl 1 `setIdUnfolding`,
`setIdDemandInfo`,
`setIdStrictness`,
`setIdCprInfo`,
`asJoinId`,
`asJoinId_maybe`
......@@ -645,6 +649,12 @@ idStrictness id = strictnessInfo (idInfo id)
setIdStrictness :: Id -> StrictSig -> Id
setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id
idCprInfo :: Id -> CprSig
idCprInfo id = cprInfo (idInfo id)
setIdCprInfo :: Id -> CprSig -> Id
setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id
zapIdStrictness :: Id -> Id
zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id
......@@ -948,11 +958,13 @@ transferPolyIdInfo old_id abstract_wrt new_id
old_strictness = strictnessInfo old_info
new_strictness = increaseStrictSigArity arity_increase old_strictness
old_cpr = cprInfo old_info
transfer new_info = new_info `setArityInfo` new_arity
`setInlinePragInfo` old_inline_prag
`setOccInfo` new_occ_info
`setStrictnessInfo` new_strictness
`setCprInfo` old_cpr
isNeverLevPolyId :: Id -> Bool
isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo
......@@ -42,6 +42,7 @@ module IdInfo (
-- ** Demand and strictness Info
strictnessInfo, setStrictnessInfo,
cprInfo, setCprInfo,
demandInfo, setDemandInfo, pprStrictness,
-- ** Unfolding Info
......@@ -100,6 +101,7 @@ import ForeignCall
import Outputable
import Module
import Demand
import Cpr
import Util
-- infixl so you can say (id `set` a `set` b)
......@@ -111,6 +113,7 @@ infixl 1 `setRuleInfo`,
`setOccInfo`,
`setCafInfo`,
`setStrictnessInfo`,
`setCprInfo`,
`setDemandInfo`,
`setNeverLevPoly`,
`setLevityInfoWithType`
......@@ -258,6 +261,9 @@ data IdInfo
strictnessInfo :: StrictSig,
-- ^ A strictness signature. Digests how a function uses its arguments
-- if applied to at least 'arityInfo' arguments.
cprInfo :: CprSig,
-- ^ Information on whether the function will ultimately return a
-- freshly allocated constructor.
demandInfo :: Demand,
-- ^ ID demand information
callArityInfo :: !ArityInfo,
......@@ -302,6 +308,9 @@ setDemandInfo info dd = dd `seq` info { demandInfo = dd }
setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo
setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd }
setCprInfo :: IdInfo -> CprSig -> IdInfo
setCprInfo info cpr = cpr `seq` info { cprInfo = cpr }
-- | Basic 'IdInfo' that carries no useful information whatsoever
vanillaIdInfo :: IdInfo
vanillaIdInfo
......@@ -315,6 +324,7 @@ vanillaIdInfo
occInfo = noOccInfo,
demandInfo = topDmd,
strictnessInfo = nopSig,
cprInfo = topCprSig,
callArityInfo = unknownArity,
levityInfo = NoLevityInfo
}
......
......@@ -63,6 +63,7 @@ import DataCon
import Id
import IdInfo
import Demand
import Cpr
import CoreSyn
import Unique
import UniqSupply
......@@ -411,6 +412,7 @@ mkDictSelId name clas
base_info = noCafIdInfo
`setArityInfo` 1
`setStrictnessInfo` strict_sig
`setCprInfo` topCprSig
`setLevityInfoWithType` sel_ty
info | new_tycon
......@@ -439,7 +441,7 @@ mkDictSelId name clas
-- It's worth giving one, so that absence info etc is generated
-- even if the selector isn't inlined
strict_sig = mkClosedStrictSig [arg_dmd] topRes
strict_sig = mkClosedStrictSig [arg_dmd] topDiv
arg_dmd | new_tycon = evalDmd
| otherwise = mkManyUsedDmd $
mkProdDmd [ if name == sel_name then evalDmd else absDmd
......@@ -507,6 +509,7 @@ mkDataConWorkId wkr_name data_con
alg_wkr_info = noCafIdInfo
`setArityInfo` wkr_arity
`setStrictnessInfo` wkr_sig
`setCprInfo` mkCprSig wkr_arity (dataConCPR data_con)
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
`setLevityInfoWithType` wkr_ty
......@@ -514,7 +517,7 @@ mkDataConWorkId wkr_name data_con
-- setNeverLevPoly
wkr_arity = dataConRepArity data_con
wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) topDiv
-- Note [Data-con worker strictness]
-- Notice that we do *not* say the worker Id is strict
-- even if the data constructor is declared strict
......@@ -552,19 +555,17 @@ mkDataConWorkId wkr_name data_con
mkLams univ_tvs $ Lam id_arg1 $
wrapNewTypeBody tycon res_ty_args (Var id_arg1)
dataConCPR :: DataCon -> DmdResult
dataConCPR :: DataCon -> CprResult
dataConCPR con
| isDataTyCon tycon -- Real data types only; that is,
-- not unboxed tuples or newtypes
, null (dataConExTyCoVars con) -- No existentials
, wkr_arity > 0
, wkr_arity <= mAX_CPR_SIZE
= if is_prod then vanillaCprProdRes (dataConRepArity con)
else cprSumRes (dataConTag con)
= conCpr (dataConTag con)
| otherwise
= topRes
= topCpr
where
is_prod = isProductTyCon tycon
tycon = dataConTyCon con
wkr_arity = dataConRepArity con
......@@ -651,12 +652,13 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
`setInlinePragInfo` wrap_prag
`setUnfoldingInfo` wrap_unf
`setStrictnessInfo` wrap_sig
`setCprInfo` mkCprSig wrap_arity (dataConCPR data_con)
-- We need to get the CAF info right here because GHC.Iface.Tidy
-- does not tidy the IdInfo of implicit bindings (like the wrapper)
-- so it not make sure that the CAF info is sane
`setLevityInfoWithType` wrap_ty
wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv
wrap_arg_dmds =
replicate (length theta) topDmd ++ map mk_dmd arg_ibangs
......@@ -1218,10 +1220,16 @@ mkPrimOpId prim_op
(AnId id) UserSyntax
id = mkGlobalId (PrimOpId prim_op) name ty info
-- PrimOps don't ever construct a product, but we want to preserve bottoms
cpr
| isBotDiv (snd (splitStrictSig strict_sig)) = botCpr
| otherwise = topCpr
info = noCafIdInfo
`setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setStrictnessInfo` strict_sig
`setCprInfo` mkCprSig arity cpr
`setInlinePragInfo` neverInlinePragma
`setLevityInfoWithType` res_ty
-- We give PrimOps a NOINLINE pragma so that we don't
......@@ -1254,11 +1262,12 @@ mkFCallId dflags uniq fcall ty
info = noCafIdInfo
`setArityInfo` arity
`setStrictnessInfo` strict_sig
`setCprInfo` topCprSig
`setLevityInfoWithType` ty
(bndrs, _) = tcSplitPiTys ty
arity = count isAnonTyCoBinder bndrs
strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes
strict_sig = mkClosedStrictSig (replicate arity topDmd) topDiv
-- the call does not claim to be strict in its arguments, since they
-- may be lifted (foreign import prim) and the called code doesn't
-- necessarily force them. See #11076.
......
......@@ -155,7 +155,7 @@ exprBotStrictness_maybe e
Just ar -> Just (ar, sig ar)
where
env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }
sig ar = mkClosedStrictSig (replicate ar topDmd) botRes
sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv
{-
Note [exprArity invariant]
......@@ -758,7 +758,7 @@ arityType _ (Var v)
, not $ isTopSig strict_sig
, (ds, res) <- splitStrictSig strict_sig
, let arity = length ds
= if isBotRes res then ABot arity
= if isBotDiv res then ABot arity
else ATop (take arity one_shots)
| otherwise
= ATop (take (idArity v) one_shots)
......
......@@ -64,7 +64,7 @@ import Util
import InstEnv ( instanceDFunId )
import OptCoercion ( checkAxInstCo )
import CoreArity ( typeArity )
import Demand ( splitStrictSig, isBotRes )
import Demand ( splitStrictSig, isBotDiv )
import HscTypes
import DynFlags
......@@ -291,7 +291,8 @@ coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity
coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify
coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal
coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal
coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
......@@ -607,7 +608,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
ppr binder)
; case splitStrictSig (idStrictness binder) of
(demands, result_info) | isBotRes result_info ->
(demands, result_info) | isBotDiv result_info ->
checkL (demands `lengthAtLeast` idArity binder)
(text "idArity" <+> ppr (idArity binder) <+>
text "exceeds arity imposed by the strictness signature" <+>
......
......@@ -15,6 +15,7 @@ import GhcPrelude
import CoreSyn
import IdInfo
import Demand( seqDemand, seqStrictSig )
import Cpr( seqCprSig )
import BasicTypes( seqOccInfo )
import VarSet( seqDVarSet )
import Var( varType, tyVarKind )
......@@ -34,6 +35,7 @@ megaSeqIdInfo info
seqDemand (demandInfo info) `seq`
seqStrictSig (strictnessInfo info) `seq`
seqCprSig (cprInfo info) `seq`
seqCaf (cafInfo info) `seq`
seqOneShot (oneShotInfo info) `seq`
seqOccInfo (occInfo info)
......
......@@ -54,7 +54,10 @@ module CoreUtils (
collectMakeStaticArgs,
-- * Join points
isJoinBind
isJoinBind,
-- * Dumping stuff
dumpIdInfoOfProgram
) where
#include "HsVersions.h"
......@@ -2550,3 +2553,12 @@ isJoinBind :: CoreBind -> Bool
isJoinBind (NonRec b _) = isJoinId b
isJoinBind (Rec ((b, _) : _)) = isJoinId b
isJoinBind _ = False
dumpIdInfoOfProgram :: (IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram ppr_id_info binds = vcat (map printId ids)
where
ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)
getIds (NonRec i _) = [ i ]
getIds (Rec bs) = map fst bs
printId id | isExportedId id = ppr id <> colon <+> (ppr_id_info (idInfo id))
| otherwise = empty
......@@ -74,6 +74,7 @@ import TysPrim
import DataCon ( DataCon, dataConWorkId )
import IdInfo
import Demand
import Cpr
import Name hiding ( varName )
import Outputable
import FastString
......@@ -797,7 +798,8 @@ tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName
aBSENT_SUM_FIELD_ERROR_ID
= mkVanillaGlobalWithInfo absentSumFieldErrorName
(mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a
(vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botRes
(vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botDiv
`setCprInfo` mkCprSig 0 botCpr
`setArityInfo` 0
`setCafInfo` NoCafRefs) -- #15038
......@@ -812,6 +814,7 @@ mkRuntimeErrorId name
= mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info
where
bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
`setCprInfo` mkCprSig 1 botCpr
`setArityInfo` 1
-- Make arity and strictness agree
......@@ -824,7 +827,7 @@ mkRuntimeErrorId name
-- any pc_bottoming_Id will itself have CafRefs, which bloats
-- SRTs.
strict_sig = mkClosedStrictSig [evalDmd] botRes
strict_sig = mkClosedStrictSig [evalDmd] botDiv
runtimeErrorTy :: Type
-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
......
......@@ -25,6 +25,7 @@ import Var
import Id
import IdInfo
import Demand
import Cpr
import DataCon
import TyCon
import TyCoPpr
......@@ -477,6 +478,7 @@ ppIdInfo id info
, (has_called_arity, text "CallArity=" <> int called_arity)
, (has_caf_info, text "Caf=" <> ppr caf_info)
, (has_str_info, text "Str=" <> pprStrictness str_info)
, (has_cpr_info, text "Cpr=" <> ppr cpr_info)
, (has_unf, text "Unf=" <> ppr unf_info)
, (not (null rules), text "RULES:" <+> vcat (map pprRule rules))
] -- Inline pragma, occ, demand, one-shot info
......@@ -499,6 +501,9 @@ ppIdInfo id info
str_info = strictnessInfo info
has_str_info = not (isTopSig str_info)
cpr_info = cprInfo info
has_cpr_info = cpr_info /= topCprSig
unf_info = unfoldingInfo info
has_unf = hasSomeUnfolding unf_info
......@@ -617,4 +622,3 @@ instance Outputable id => Outputable (Tickish id) where
_ -> hcat [text "scc<", ppr cc, char '>']
ppr (SourceNote span _) =
hcat [ text "src<", pprUserRealSpan True span, char '>']
......@@ -202,6 +202,7 @@ Library
DataCon
PatSyn
Demand
Cpr
GHC.Cmm.DebugBlock
Exception
FieldLabel
......@@ -468,6 +469,7 @@ Library
Specialise
CallArity
DmdAnal
CprAnal
Exitify
WorkWrap
WwLib
......
......@@ -464,6 +464,8 @@ data DumpFlag
| Opt_D_dump_exitify
| Opt_D_dump_stranal
| Opt_D_dump_str_signatures
| Opt_D_dump_cpranal
| Opt_D_dump_cpr_signatures
| Opt_D_dump_tc
| Opt_D_dump_tc_ast
| Opt_D_dump_types
......@@ -3430,6 +3432,10 @@ dynamic_flags_deps = [
(setDumpFlag Opt_D_dump_stranal)
, make_ord_flag defGhcFlag "ddump-str-signatures"
(setDumpFlag Opt_D_dump_str_signatures)
, make_ord_flag defGhcFlag "ddump-cpranal"
(setDumpFlag Opt_D_dump_cpranal)
, make_ord_flag defGhcFlag "ddump-cpr-signatures"
(setDumpFlag Opt_D_dump_cpr_signatures)
, make_ord_flag defGhcFlag "ddump-tc"
(setDumpFlag Opt_D_dump_tc)
, make_ord_flag defGhcFlag "ddump-tc-ast"
......
......@@ -72,7 +72,7 @@ defaults
can_fail = False -- See Note [PrimOp can_fail and has_side_effects] in PrimOp
commutable = False
code_size = { primOpCodeSizeDefault }
strictness = { \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes }
strictness = { \ arity -> mkClosedStrictSig (replicate arity topDmd) topDiv }
fixity = Nothing
llvm_only = False
vector = []
......@@ -2584,7 +2584,7 @@ primop CatchOp "catch#" GenPrimOp
with
strictness = { \ _arity -> mkClosedStrictSig [ lazyApply1Dmd
, lazyApply2Dmd
, topDmd] topRes }
, topDmd] topDiv }
-- See Note [Strictness for mask/unmask/catch]
out_of_line = True
has_side_effects = True
......@@ -2593,7 +2593,7 @@ primop RaiseOp "raise#" GenPrimOp
b -> o
-- NB: the type variable "o" is "a", but with OpenKind
with
strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes }