summaryrefslogtreecommitdiff
path: root/compiler/coreSyn
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/coreSyn')
-rw-r--r--compiler/coreSyn/CoreArity.hs4
-rw-r--r--compiler/coreSyn/CoreLint.hs7
-rw-r--r--compiler/coreSyn/CoreSeq.hs2
-rw-r--r--compiler/coreSyn/CoreUtils.hs14
-rw-r--r--compiler/coreSyn/MkCore.hs7
-rw-r--r--compiler/coreSyn/PprCore.hs6
6 files changed, 31 insertions, 9 deletions
diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs
index 3c5d2e96c6..79ac6244aa 100644
--- a/compiler/coreSyn/CoreArity.hs
+++ b/compiler/coreSyn/CoreArity.hs
@@ -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)
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 21f4fd5c0e..c81d754131 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -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" <+>
diff --git a/compiler/coreSyn/CoreSeq.hs b/compiler/coreSyn/CoreSeq.hs
index 7de8923a71..aa94a24215 100644
--- a/compiler/coreSyn/CoreSeq.hs
+++ b/compiler/coreSyn/CoreSeq.hs
@@ -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)
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index e073078766..cde9dc0e45 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -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
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index a261a98451..e21d980775 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -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
diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
index 0bf188e6a8..44d7fac878 100644
--- a/compiler/coreSyn/PprCore.hs
+++ b/compiler/coreSyn/PprCore.hs
@@ -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 '>']
-
View Lorry Controller Status