Commit ef6b2833 authored by Sebastian Graf's avatar Sebastian Graf

Remove ExnStr and ThrowsExn business

parent d6d735c1
This diff is collapsed.
......@@ -153,9 +153,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) exnRes
-- For this purpose we can be very simple
-- exnRes is a bit less aggressive than botRes
sig ar = mkClosedStrictSig (replicate ar topDmd) botRes
{-
Note [exprArity invariant]
......
......@@ -758,7 +758,7 @@ tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName
aBSENT_SUM_FIELD_ERROR_ID
= mkVanillaGlobalWithInfo absentSumFieldErrorName
(mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a
(vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] exnRes
(vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botRes
`setArityInfo` 0
`setCafInfo` NoCafRefs) -- #15038
......@@ -785,8 +785,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
......
......@@ -2478,9 +2478,6 @@ section "Exceptions"
-- 0# -> maskAsynchExceptions# (\st -> case ma of MVar a -> ...)
-- The outer case just decides whether to mask exceptions, but we don't want
-- thereby to hide the strictness in 'ma'! Hence the use of strictApply1Dmd.
--
-- For catch, catchSTM, and catchRetry, we must be extra careful; see
-- Note [Exceptions and strictness] in Demand
primop CatchOp "catch#" GenPrimOp
(State# RealWorld -> (# State# RealWorld, a #) )
......@@ -2499,8 +2496,7 @@ primop RaiseOp "raise#" GenPrimOp
b -> o
-- NB: the type variable "o" is "a", but with OpenKind
with
strictness = { \ _arity -> mkClosedStrictSig [topDmd] exnRes }
-- NB: result is ThrowsExn
strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes }
out_of_line = True
has_side_effects = True
-- raise# certainly throws a Haskell exception and hence has_side_effects
......@@ -2528,7 +2524,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
......@@ -2579,7 +2575,7 @@ primop AtomicallyOp "atomically#" GenPrimOp
out_of_line = True
has_side_effects = True
-- NB: retry#'s strictness information specifies it to throw an exception
-- NB: retry#'s strictness information specifies it to diverge.
-- This lets the compiler perform some extra simplifications, since retry#
-- will technically never return.
--
......@@ -2589,13 +2585,10 @@ primop AtomicallyOp "atomically#" GenPrimOp
-- with:
-- retry# s1
-- where 'e' would be unreachable anyway. See Trac #8091.
--
-- Note that it *does not* return botRes as the "exception" that is thrown may be
-- "caught" by catchRetry#. This mistake caused #14171.
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
......
......@@ -40,7 +40,7 @@ import CoreUtils
import CoreOpt ( pushCoTyArg, pushCoValArg
, joinPointBinding_maybe, joinPointBindings_maybe )
import Rules ( mkRuleInfo, lookupRule, getRules )
import Demand ( mkClosedStrictSig, topDmd, exnRes )
import Demand ( mkClosedStrictSig, topDmd, botRes )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel,
RecFlag(..), Arity )
import MonadUtils ( mapAccumLM, liftIO )
......@@ -695,7 +695,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
......
......@@ -1167,7 +1167,7 @@ mk_absent_let dflags arg
= WARN( True, text "No absent value for" <+> ppr arg_ty )
Nothing -- Can happen for 'State#' and things of 'VecRep'
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)
......
......@@ -17,7 +17,7 @@ T2431.$WRefl
-- RHS size: {terms: 4, types: 8, coercions: 0, joins: 0/0}
absurd :: forall a. (Int :~: Bool) -> a
[GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>x, Unf=OtherCon []]
[GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>b, Unf=OtherCon []]
absurd = \ (@ a) (x :: Int :~: Bool) -> case x of { }
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
......
......@@ -54,7 +54,7 @@ lvl = "spec-inline.hs:(19,5)-(29,25)|function go"#
-- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0}
Roman.foo3 :: Int
[GblId, Str=x]
[GblId, Str=b]
Roman.foo3
= Control.Exception.Base.patError @ 'GHC.Types.LiftedRep @ Int lvl
......
module Main where
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
chkLoop :: TVar String -> STM ()
chkLoop v = do
val <- readTVar v
if (length val == 2) then retry else return ()
main :: IO ()
main = do
v <- newTVarIO "hi"
atomically $ do
chkLoop v `orElse` return ()
error "you're expected to see this"
......@@ -20,5 +20,6 @@ test('T11555a', normal, compile_and_run, [''])
test('T12368', exit_code(1), compile_and_run, [''])
test('T12368a', exit_code(1), compile_and_run, [''])
test('T13380', [expect_broken(13380), exit_code(1)], compile_and_run, [''])
test('T14171', [expect_broken(14171), exit_code(1)], compile_and_run, [''])
test('T14290', normal, compile_and_run, [''])
test('T14285', normal, multimod_compile_and_run, ['T14285', ''])
==================== Strictness signatures ====================
UnsatFun.$trModule: m
UnsatFun.f: <B,1*U(U)><B,A>x
UnsatFun.g: <B,1*U(U)>x
UnsatFun.f: <B,1*U(U)><B,A>b
UnsatFun.g: <B,1*U(U)>b
UnsatFun.g': <L,1*U(U)>
UnsatFun.g3: <L,U(U)>m
UnsatFun.h: <C(S),1*C1(U(U))>
......@@ -13,8 +13,8 @@ UnsatFun.h3: <C(S),1*C1(U)>m
==================== Strictness signatures ====================
UnsatFun.$trModule: m
UnsatFun.f: <B,1*U(U)><B,A>x
UnsatFun.g: <B,1*U(U)>x
UnsatFun.f: <B,1*U(U)><B,A>b
UnsatFun.g: <B,1*U(U)>b
UnsatFun.g': <L,1*U(U)>
UnsatFun.g3: <L,U(U)>m
UnsatFun.h: <C(S),1*C1(U(U))>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment