summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/Demand.hs150
-rw-r--r--compiler/coreSyn/CoreArity.hs3
-rw-r--r--compiler/coreSyn/MkCore.hs3
-rw-r--r--compiler/prelude/primops.txt.pp6
-rw-r--r--compiler/simplCore/Simplify.hs6
-rw-r--r--compiler/stranal/WwLib.hs2
6 files changed, 56 insertions, 114 deletions
diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index 0b0da1349a..4c6689d74a 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -31,12 +31,12 @@ module Demand (
DmdResult, CPRResult,
isBotRes, isTopRes,
- topRes, botRes, exnRes, cprProdRes,
+ topRes, botRes, cprProdRes,
vanillaCprProdRes, cprSumRes,
appIsBottom, isBottomingSig, pprIfaceStrictSig,
trimCPRInfo, returnsCPR_maybe,
StrictSig(..), mkStrictSig, mkClosedStrictSig,
- nopSig, botSig, exnSig, cprProdSig,
+ nopSig, botSig, cprProdSig,
isTopSig, hasDemandEnvSig,
splitStrictSig, strictSigDmdEnv,
increaseStrictSigArity,
@@ -114,10 +114,8 @@ mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as
* *
************************************************************************
- Lazy
- |
- ExnStr x -
- |
+ Lazy
+ |
HeadStr
/ \
SCall SProd
@@ -239,21 +237,12 @@ type ArgStr = Str StrDmd
-- | Strictness demand.
data Str s = Lazy -- ^ Lazy (top of the lattice)
- | Str ExnStr s -- ^ Strict
+ | Str s -- ^ Strict
deriving ( Eq, Show )
--- | How are exceptions handled for strict demands?
-data ExnStr -- See Note [Exceptions and strictness]
- = VanStr -- ^ "Vanilla" case, ordinary strictness
-
- | ExnStr -- ^ @Str ExnStr d@ means be strict like @d@ but then degrade
- -- the 'Termination' info 'ThrowsExn' to 'Dunno'.
- -- e.g. the first argument of @catch@ has this strictness.
- deriving( Eq, Show )
-
-- Well-formedness preserving constructors for the Strictness domain
strBot, strTop :: ArgStr
-strBot = Str VanStr HyperStr
+strBot = Str HyperStr
strTop = Lazy
mkSCall :: StrDmd -> StrDmd
@@ -271,7 +260,7 @@ isLazy Lazy = True
isLazy (Str {}) = False
isHyperStr :: ArgStr -> Bool
-isHyperStr (Str _ HyperStr) = True
+isHyperStr (Str HyperStr) = True
isHyperStr _ = False
-- Pretty-printing
@@ -282,18 +271,13 @@ instance Outputable StrDmd where
ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx))
instance Outputable ArgStr where
- ppr (Str x s) = (case x of VanStr -> empty; ExnStr -> char 'x')
- <> ppr s
+ ppr (Str s) = ppr s
ppr Lazy = char 'L'
lubArgStr :: ArgStr -> ArgStr -> ArgStr
lubArgStr Lazy _ = Lazy
lubArgStr _ Lazy = Lazy
-lubArgStr (Str x1 s1) (Str x2 s2) = Str (x1 `lubExnStr` x2) (s1 `lubStr` s2)
-
-lubExnStr :: ExnStr -> ExnStr -> ExnStr
-lubExnStr VanStr VanStr = VanStr
-lubExnStr _ _ = ExnStr -- ExnStr is lazier
+lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2)
lubStr :: StrDmd -> StrDmd -> StrDmd
lubStr HyperStr s = s
@@ -312,11 +296,7 @@ lubStr HeadStr _ = HeadStr
bothArgStr :: ArgStr -> ArgStr -> ArgStr
bothArgStr Lazy s = s
bothArgStr s Lazy = s
-bothArgStr (Str x1 s1) (Str x2 s2) = Str (x1 `bothExnStr` x2) (s1 `bothStr` s2)
-
-bothExnStr :: ExnStr -> ExnStr -> ExnStr
-bothExnStr ExnStr ExnStr = ExnStr
-bothExnStr _ _ = VanStr
+bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2)
bothStr :: StrDmd -> StrDmd -> StrDmd
bothStr HyperStr _ = HyperStr
@@ -344,13 +324,13 @@ seqStrDmdList [] = ()
seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds
seqArgStr :: ArgStr -> ()
-seqArgStr Lazy = ()
-seqArgStr (Str x s) = x `seq` seqStrDmd s
+seqArgStr Lazy = ()
+seqArgStr (Str s) = seqStrDmd s
-- Splitting polymorphic demands
splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr]
splitArgStrProdDmd n Lazy = Just (replicate n Lazy)
-splitArgStrProdDmd n (Str _ s) = splitStrProdDmd n s
+splitArgStrProdDmd n (Str s) = splitStrProdDmd n s
splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr]
splitStrProdDmd n HyperStr = Just (replicate n strBot)
@@ -706,12 +686,12 @@ mkHeadStrict :: CleanDemand -> CleanDemand
mkHeadStrict cd = cd { sd = HeadStr }
mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand
-mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use One a }
-mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use Many a }
+mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a }
+mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a }
evalDmd :: Demand
-- Evaluated strictly, and used arbitrarily deeply
-evalDmd = JD { sd = Str VanStr HeadStr, ud = useTop }
+evalDmd = JD { sd = Str HeadStr, ud = useTop }
mkProdDmd :: [Demand] -> CleanDemand
mkProdDmd dx
@@ -757,13 +737,12 @@ bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})
lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, catchArgDmd :: Demand
-strictApply1Dmd = JD { sd = Str VanStr (SCall HeadStr)
+strictApply1Dmd = JD { sd = Str (SCall HeadStr)
, ud = Use Many (UCall One Used) }
-- First argument of catchRetry# and catchSTM#:
-- uses its arg once, applies it once
--- and catches exceptions (the ExnStr) part
-catchArgDmd = JD { sd = Str ExnStr (SCall HeadStr)
+catchArgDmd = JD { sd = Str (SCall HeadStr)
, ud = Use One (UCall One Used) }
lazyApply1Dmd = JD { sd = Lazy
@@ -785,7 +764,7 @@ botDmd :: Demand
botDmd = JD { sd = strBot, ud = useBot }
seqDmd :: Demand
-seqDmd = JD { sd = Str VanStr HeadStr, ud = Use One UHead }
+seqDmd = JD { sd = Str HeadStr, ud = Use One UHead }
oneifyDmd :: Demand -> Demand
oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a }
@@ -801,7 +780,7 @@ isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr
isAbsDmd _ = False -- for a bottom demand
isSeqDmd :: Demand -> Bool
-isSeqDmd (JD {sd = Str VanStr HeadStr, ud = Use _ UHead}) = True
+isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True
isSeqDmd _ = False
isUsedOnce :: Demand -> Bool
@@ -860,7 +839,7 @@ trimToType (JD { sd = ms, ud = mu }) ts
where
go_ms :: ArgStr -> TypeShape -> ArgStr
go_ms Lazy _ = Lazy
- go_ms (Str x s) ts = Str x (go_s s ts)
+ go_ms (Str s) ts = Str (go_s s ts)
go_s :: StrDmd -> TypeShape -> StrDmd
go_s HyperStr _ = HyperStr
@@ -926,11 +905,11 @@ splitProdDmd_maybe :: Demand -> Maybe [Demand]
-- The demand is not necessarily strict!
splitProdDmd_maybe (JD { sd = s, ud = u })
= case (s,u) of
- (Str _ (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u
- -> Just (mkJointDmds sx ux)
- (Str _ s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s
- -> Just (mkJointDmds sx ux)
- (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
+ (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u
+ -> Just (mkJointDmds sx ux)
+ (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s
+ -> Just (mkJointDmds sx ux)
+ (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
_ -> Nothing
{-
@@ -943,9 +922,7 @@ splitProdDmd_maybe (JD { sd = s, ud = u })
DmdResult: Dunno CPRResult
/
- ThrowsExn
- /
- Diverges
+ Diverges
CPRResult: NoCPR
@@ -964,7 +941,6 @@ We have lubs, but not glbs; but that is ok.
data Termination r
= Diverges -- Definitely diverges
- | ThrowsExn -- Definitely throws an exception or diverges
| Dunno r -- Might diverge or converge
deriving( Eq, Show )
@@ -983,10 +959,7 @@ lubCPR _ _ = NoCPR
lubDmdResult :: DmdResult -> DmdResult -> DmdResult
lubDmdResult Diverges r = r
-lubDmdResult ThrowsExn Diverges = ThrowsExn
-lubDmdResult ThrowsExn r = r
lubDmdResult (Dunno c1) Diverges = Dunno c1
-lubDmdResult (Dunno c1) ThrowsExn = Dunno c1
lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2)
-- This needs to commute with defaultDmd, i.e.
-- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2
@@ -995,7 +968,6 @@ lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2)
bothDmdResult :: DmdResult -> Termination () -> DmdResult
-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
bothDmdResult _ Diverges = Diverges
-bothDmdResult r ThrowsExn = case r of { Diverges -> r; _ -> ThrowsExn }
bothDmdResult r (Dunno {}) = r
-- This needs to commute with defaultDmd, i.e.
-- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2
@@ -1003,7 +975,6 @@ bothDmdResult r (Dunno {}) = r
instance Outputable r => Outputable (Termination r) where
ppr Diverges = char 'b'
- ppr ThrowsExn = char 'x'
ppr (Dunno c) = ppr c
instance Outputable CPRResult where
@@ -1013,7 +984,6 @@ instance Outputable CPRResult where
seqDmdResult :: DmdResult -> ()
seqDmdResult Diverges = ()
-seqDmdResult ThrowsExn = ()
seqDmdResult (Dunno c) = seqCPRResult c
seqCPRResult :: CPRResult -> ()
@@ -1028,9 +998,8 @@ seqCPRResult RetProd = ()
-- [cprRes] lets us switch off CPR analysis
-- by making sure that everything uses TopRes
-topRes, exnRes, botRes :: DmdResult
+topRes, botRes :: DmdResult
topRes = Dunno NoCPR
-exnRes = ThrowsExn
botRes = Diverges
cprSumRes :: ConTag -> DmdResult
@@ -1049,7 +1018,6 @@ isTopRes _ = False
isBotRes :: DmdResult -> Bool
-- True if the result diverges or throws an exception
isBotRes Diverges = True
-isBotRes ThrowsExn = True
isBotRes (Dunno {}) = False
trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult
@@ -1078,7 +1046,7 @@ retCPR_maybe NoCPR = Nothing
-- and [defaultDmd vs. resTypeArgDmd]
defaultDmd :: Termination r -> Demand
defaultDmd (Dunno {}) = absDmd
-defaultDmd _ = botDmd -- Diverges or ThrowsExn
+defaultDmd _ = botDmd -- Diverges or throws exception
resTypeArgDmd :: Termination r -> Demand
-- TopRes and BotRes are polymorphic, so that
@@ -1087,7 +1055,7 @@ resTypeArgDmd :: Termination r -> Demand
-- This function makes that concrete
-- Also see Note [defaultDmd vs. resTypeArgDmd]
resTypeArgDmd (Dunno _) = topDmd
-resTypeArgDmd _ = botDmd -- Diverges or ThrowsExn
+resTypeArgDmd _ = botDmd -- Diverges or throws exception
{-
Note [defaultDmd and resTypeArgDmd]
@@ -1291,7 +1259,6 @@ toBothDmdArg :: DmdType -> BothDmdArg
toBothDmdArg (DmdType fv _ r) = (fv, go r)
where
go (Dunno {}) = Dunno ()
- go ThrowsExn = ThrowsExn
go Diverges = Diverges
bothDmdType :: DmdType -> BothDmdArg -> DmdType
@@ -1321,10 +1288,9 @@ emptyDmdEnv = emptyVarEnv
-- (lazy, absent, no CPR information, no termination information).
-- 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, exnDmdType :: DmdType
+nopDmdType, botDmdType :: DmdType
nopDmdType = DmdType emptyDmdEnv [] topRes
botDmdType = DmdType emptyDmdEnv [] botRes
-exnDmdType = DmdType emptyDmdEnv [] exnRes
cprProdDmdType :: Arity -> DmdType
cprProdDmdType arity
@@ -1389,14 +1355,14 @@ deferAfterIO d@(DmdType _ _ res) =
DmdType fv ds _ -> DmdType fv ds (defer_res res)
where
defer_res r@(Dunno {}) = r
- defer_res _ = topRes -- Diverges and ThrowsExn
+ defer_res _ = topRes -- Diverges or throws exception
strictenDmd :: Demand -> CleanDemand
strictenDmd (JD { sd = s, ud = u})
= JD { sd = poke_s s, ud = poke_u u }
where
poke_s Lazy = HeadStr
- poke_s (Str _ s) = s
+ poke_s (Str s) = s
poke_u Abs = UHead
poke_u (Use _ u) = u
@@ -1413,8 +1379,8 @@ toCleanDmd (JD { sd = s, ud = u }) expr_ty
-- See Note [Analyzing with lazy demand and lambdas]
where
(ss, s') = case s of
- Str x s' -> (Str x (), s')
- Lazy | is_unlifted -> (Str VanStr (), HeadStr)
+ Str s' -> (Str (), s')
+ Lazy | is_unlifted -> (Str (), HeadStr)
| otherwise -> (Lazy, HeadStr)
(us, u') = case u of
@@ -1436,13 +1402,10 @@ postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty)
where
term_info = case postProcessDmdResult ss res_ty of
Dunno _ -> Dunno ()
- ThrowsExn -> ThrowsExn
Diverges -> Diverges
postProcessDmdResult :: Str () -> DmdResult -> DmdResult
postProcessDmdResult Lazy _ = topRes
-postProcessDmdResult (Str ExnStr _) ThrowsExn = topRes -- Key point!
--- Note that only ThrowsExn results can be caught, not Diverges
postProcessDmdResult _ res = res
postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv
@@ -1451,7 +1414,7 @@ postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env
-- In this case (postProcessDmd ds) == id; avoid a redundant rebuild
-- of the environment. Be careful, bad things will happen if this doesn't
-- match postProcessDmd (see #13977).
- | Str VanStr _ <- ss
+ | Str _ <- ss
, Use One _ <- us = env
| otherwise = mapVarEnv (postProcessDmd ds) env
-- For the Absent case just discard all usage information
@@ -1460,7 +1423,7 @@ postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env
reuseEnv :: DmdEnv -> DmdEnv
reuseEnv = mapVarEnv (postProcessDmd
- (JD { sd = Str VanStr (), ud = Use Many () }))
+ (JD { sd = Str (), ud = Use Many () }))
postProcessUnsat :: DmdShell -> DmdType -> DmdType
postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty)
@@ -1474,17 +1437,12 @@ postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a})
where
s' = case ss of
Lazy -> Lazy
- Str ExnStr _ -> markExnStr s
- Str VanStr _ -> s
+ Str _ -> s
a' = case us of
Abs -> Abs
Use Many _ -> markReusedDmd a
Use One _ -> a
-markExnStr :: ArgStr -> ArgStr
-markExnStr (Str VanStr s) = Str ExnStr s
-markExnStr s = s
-
-- Peels one call level from the demand, and also returns
-- whether it was unsaturated (separately for strictness and usage)
peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell)
@@ -1495,8 +1453,8 @@ peelCallDmd (JD {sd = s, ud = u})
= (JD { sd = s', ud = u' }, JD { sd = ss, ud = us })
where
(s', ss) = case s of
- SCall s' -> (s', Str VanStr ())
- HyperStr -> (HyperStr, Str VanStr ())
+ SCall s' -> (s', Str ())
+ HyperStr -> (HyperStr, Str ())
_ -> (HeadStr, Lazy)
(u', us) = case u of
UCall c u' -> (u', Use c ())
@@ -1513,8 +1471,8 @@ peelManyCalls n (JD { sd = str, ud = abs })
= JD { sd = go_str n str, ud = go_abs n abs }
where
go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer
- go_str 0 _ = Str VanStr ()
- go_str _ HyperStr = Str VanStr () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr)
+ go_str 0 _ = Str ()
+ go_str _ HyperStr = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr)
go_str n (SCall d') = go_str (n-1) d'
go_str _ _ = Lazy
@@ -1753,10 +1711,9 @@ isBottomingSig :: StrictSig -> Bool
-- True if the signature diverges or throws an exception
isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res
-nopSig, botSig, exnSig :: StrictSig
+nopSig, botSig :: StrictSig
nopSig = StrictSig nopDmdType
botSig = StrictSig botDmdType
-exnSig = StrictSig exnDmdType
cprProdSig :: Arity -> StrictSig
cprProdSig arity = StrictSig (cprProdDmdType arity)
@@ -2013,7 +1970,7 @@ strictifyDictDmd ty dmd = case getUseDmd dmd of
--
-- TODO revisit this if we ever do boxity analysis
| otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of
- JD {sd = s,ud = a} -> JD (Str VanStr s) (Use n a)
+ JD {sd = s,ud = a} -> JD (Str s) (Use n a)
-- TODO could optimize with an aborting variant of zipWith since
-- the superclass dicts are always a prefix
_ -> dmd -- unused or not a dictionary
@@ -2057,30 +2014,19 @@ instance Binary StrDmd where
_ -> do sx <- get bh
return (SProd sx)
-instance Binary ExnStr where
- put_ bh VanStr = putByte bh 0
- put_ bh ExnStr = putByte bh 1
-
- get bh = do h <- getByte bh
- return (case h of
- 0 -> VanStr
- _ -> ExnStr)
-
instance Binary ArgStr where
put_ bh Lazy = do
putByte bh 0
- put_ bh (Str x s) = do
+ put_ bh (Str s) = do
putByte bh 1
- put_ bh x
put_ bh s
get bh = do
h <- getByte bh
case h of
0 -> return Lazy
- _ -> do x <- get bh
- s <- get bh
- return $ Str x s
+ _ -> do s <- get bh
+ return $ Str s
instance Binary Count where
put_ bh One = do putByte bh 0
@@ -2157,13 +2103,11 @@ instance Binary DmdType where
instance Binary DmdResult where
put_ bh (Dunno c) = do { putByte bh 0; put_ bh c }
- put_ bh ThrowsExn = putByte bh 1
put_ bh Diverges = putByte bh 2
get bh = do { h <- getByte bh
; case h of
0 -> do { c <- get bh; return (Dunno c) }
- 1 -> return ThrowsExn
_ -> return Diverges }
instance Binary CPRResult where
diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs
index 945cad6d4a..7ed55e8262 100644
--- a/compiler/coreSyn/CoreArity.hs
+++ b/compiler/coreSyn/CoreArity.hs
@@ -153,9 +153,8 @@ 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) exnRes
+ sig ar = mkClosedStrictSig (replicate ar topDmd) botRes
-- For this purpose we can be very simple
- -- exnRes is a bit less aggressive than botRes
{-
Note [exprArity invariant]
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index f2b940bfd1..17f6cb7ef0 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -758,8 +758,7 @@ mkRuntimeErrorId name
-- any pc_bottoming_Id will itself have CafRefs, which bloats
-- SRTs.
- strict_sig = mkClosedStrictSig [evalDmd] exnRes
- -- exnRes: these throw an exception, not just diverge
+ strict_sig = mkClosedStrictSig [evalDmd] botRes
runtimeErrorTy :: Type
-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 4098e80d47..e8971ac074 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -2272,7 +2272,7 @@ primop RaiseOp "raise#" GenPrimOp
b -> o
-- NB: the type variable "o" is "a", but with OpenKind
with
- strictness = { \ _arity -> mkClosedStrictSig [topDmd] exnRes }
+ strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes }
-- NB: result is ThrowsExn
out_of_line = True
has_side_effects = True
@@ -2301,7 +2301,7 @@ primop RaiseOp "raise#" GenPrimOp
primop RaiseIOOp "raiseIO#" GenPrimOp
a -> State# RealWorld -> (# State# RealWorld, b #)
with
- strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnRes }
+ strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes }
out_of_line = True
has_side_effects = True
@@ -2368,7 +2368,7 @@ primop AtomicallyOp "atomically#" GenPrimOp
primop RetryOp "retry#" GenPrimOp
State# RealWorld -> (# State# RealWorld, a #)
with
- strictness = { \ _arity -> mkClosedStrictSig [topDmd] exnRes }
+ strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes }
out_of_line = True
has_side_effects = True
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 6b0360cf5e..df23a550a6 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -31,14 +31,14 @@ import FamInstEnv ( topNormaliseType_maybe )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness, dataConRepArgTys )
import CoreMonad ( Tick(..), SimplMode(..) )
import CoreSyn
-import Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd )
+import Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd, botRes )
import PprCore ( pprCoreExpr )
import CoreUnfold
import CoreUtils
import CoreOpt ( pushCoTyArg, pushCoValArg
, joinPointBinding_maybe, joinPointBindings_maybe )
import Rules ( mkRuleInfo, lookupRule, getRules )
-import Demand ( mkClosedStrictSig, topDmd, exnRes )
+import Demand ( mkClosedStrictSig, topDmd )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel,
RecFlag(..), Arity )
import MonadUtils ( mapAccumLM, liftIO )
@@ -685,7 +685,7 @@ addLetBndrInfo new_bndr new_arity is_bot new_unf
-- Bottoming bindings: see Note [Bottoming bindings]
info4 | is_bot = info3 `setStrictnessInfo`
- mkClosedStrictSig (replicate new_arity topDmd) exnRes
+ mkClosedStrictSig (replicate new_arity topDmd) botRes
| otherwise = info3
-- Zap call arity info. We have used it by now (via
diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs
index 9d957c4251..8517eb1d82 100644
--- a/compiler/stranal/WwLib.hs
+++ b/compiler/stranal/WwLib.hs
@@ -928,7 +928,7 @@ mk_absent_let dflags arg
= WARN( True, text "No absent value for" <+> ppr arg_ty )
Nothing
where
- lifted_arg = arg `setIdStrictness` exnSig
+ lifted_arg = arg `setIdStrictness` botSig
-- Note in strictness signature that this is bottoming
-- (for the sake of the "empty case scrutinee not known to
-- diverge for sure lint" warning)
View Lorry Controller Status