summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Builtin/Names.hs9
-rw-r--r--compiler/GHC/Builtin/primops.txt.pp24
-rw-r--r--compiler/GHC/Core/Make.hs33
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs3
-rw-r--r--libraries/ghc-prim/GHC/Prim/Exception.hs22
-rw-r--r--rts/Prelude.h9
-rw-r--r--rts/RtsStartup.c6
7 files changed, 41 insertions, 65 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 7daba318ef..57e2fcdc75 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -532,7 +532,7 @@ genericTyConNames = [
pRELUDE :: Module
pRELUDE = mkBaseModule_ pRELUDE_NAME
-gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION,
+gHC_PRIM, gHC_PRIM_PANIC,
gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_MAGIC_DICT,
gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,
gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
@@ -552,7 +552,6 @@ gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION,
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
gHC_PRIM_PANIC = mkPrimModule (fsLit "GHC.Prim.Panic")
-gHC_PRIM_EXCEPTION = mkPrimModule (fsLit "GHC.Prim.Exception")
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic")
gHC_MAGIC_DICT = mkPrimModule (fsLit "GHC.Magic.Dict")
@@ -2259,8 +2258,7 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey,
unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey,
typeErrorIdKey, divIntIdKey, modIntIdKey,
- absentSumFieldErrorIdKey, cstringLengthIdKey,
- raiseOverflowIdKey, raiseUnderflowIdKey, raiseDivZeroIdKey
+ absentSumFieldErrorIdKey, cstringLengthIdKey
:: Unique
wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders]
@@ -2293,9 +2291,6 @@ typeErrorIdKey = mkPreludeMiscIdUnique 24
divIntIdKey = mkPreludeMiscIdUnique 25
modIntIdKey = mkPreludeMiscIdUnique 26
cstringLengthIdKey = mkPreludeMiscIdUnique 27
-raiseOverflowIdKey = mkPreludeMiscIdUnique 28
-raiseUnderflowIdKey = mkPreludeMiscIdUnique 29
-raiseDivZeroIdKey = mkPreludeMiscIdUnique 30
concatIdKey, filterIdKey, zipIdKey,
bindIOIdKey, returnIOIdKey, newStablePtrIdKey,
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 2deb2f48ef..1fc7bd5f23 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -2573,6 +2573,30 @@ primop RaiseOp "raise#" GenPrimOp
out_of_line = True
can_fail = True
+primop RaiseUnderflowOp "raiseUnderflow#" GenPrimOp
+ (# #) -> p
+ with
+ strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }
+ out_of_line = True
+ can_fail = True
+ code_size = { primOpCodeSizeForeignCall }
+
+primop RaiseOverflowOp "raiseOverflow#" GenPrimOp
+ (# #) -> p
+ with
+ strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }
+ out_of_line = True
+ can_fail = True
+ code_size = { primOpCodeSizeForeignCall }
+
+primop RaiseDivZeroOp "raiseDivZero#" GenPrimOp
+ (# #) -> p
+ with
+ strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }
+ out_of_line = True
+ can_fail = True
+ code_size = { primOpCodeSizeForeignCall }
+
primop RaiseIOOp "raiseIO#" GenPrimOp
v -> State# RealWorld -> (# State# RealWorld, p #)
with
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index 41757c0d30..9c3b8edfee 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -768,10 +768,7 @@ errorIds
rEC_SEL_ERROR_ID,
aBSENT_ERROR_ID,
aBSENT_SUM_FIELD_ERROR_ID,
- tYPE_ERROR_ID, -- Used with Opt_DeferTypeErrors, see #10284
- rAISE_OVERFLOW_ID,
- rAISE_UNDERFLOW_ID,
- rAISE_DIVZERO_ID
+ tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284
]
recSelErrorName, runtimeErrorName, absentErrorName :: Name
@@ -779,7 +776,6 @@ recConErrorName, patErrorName :: Name
nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
typeErrorName :: Name
absentSumFieldErrorName :: Name
-raiseOverflowName, raiseUnderflowName, raiseDivZeroName :: Name
recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID
runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID
@@ -798,7 +794,6 @@ err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id
pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
-rAISE_OVERFLOW_ID, rAISE_UNDERFLOW_ID, rAISE_DIVZERO_ID :: Id
rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
@@ -913,31 +908,7 @@ absentErrorName
absentErrorIdKey
aBSENT_ERROR_ID
-raiseOverflowName
- = mkWiredInIdName
- gHC_PRIM_EXCEPTION
- (fsLit "raiseOverflow")
- raiseOverflowIdKey
- rAISE_OVERFLOW_ID
-
-raiseUnderflowName
- = mkWiredInIdName
- gHC_PRIM_EXCEPTION
- (fsLit "raiseUnderflow")
- raiseUnderflowIdKey
- rAISE_UNDERFLOW_ID
-
-raiseDivZeroName
- = mkWiredInIdName
- gHC_PRIM_EXCEPTION
- (fsLit "raiseDivZero")
- raiseDivZeroIdKey
- rAISE_DIVZERO_ID
-
aBSENT_SUM_FIELD_ERROR_ID = mkExceptionId absentSumFieldErrorName
-rAISE_OVERFLOW_ID = mkExceptionId raiseOverflowName
-rAISE_UNDERFLOW_ID = mkExceptionId raiseUnderflowName
-rAISE_DIVZERO_ID = mkExceptionId raiseDivZeroName
-- | Exception with type \"forall a. a\"
--
@@ -974,7 +945,7 @@ runtimeErrorTy :: Type
runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
(mkVisFunTyMany addrPrimTy openAlphaTy)
--- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID' or 'raiseOverflow', that
+-- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID', that
-- throws an (imprecise) exception after being supplied one value arg for every
-- argument 'Demand' in the list. The demands end up in the demand signature.
--
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 518080797f..7366c529c8 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1563,6 +1563,9 @@ emitPrimOp cfg primop =
CasMutVarOp -> alwaysExternal
CatchOp -> alwaysExternal
RaiseOp -> alwaysExternal
+ RaiseUnderflowOp -> alwaysExternal
+ RaiseOverflowOp -> alwaysExternal
+ RaiseDivZeroOp -> alwaysExternal
RaiseIOOp -> alwaysExternal
MaskAsyncExceptionsOp -> alwaysExternal
MaskUninterruptibleOp -> alwaysExternal
diff --git a/libraries/ghc-prim/GHC/Prim/Exception.hs b/libraries/ghc-prim/GHC/Prim/Exception.hs
index 5984dab09c..71c17f96a4 100644
--- a/libraries/ghc-prim/GHC/Prim/Exception.hs
+++ b/libraries/ghc-prim/GHC/Prim/Exception.hs
@@ -1,9 +1,6 @@
-{-# LANGUAGE GHCForeignImportPrim #-}
-{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE EmptyCase #-}
-- | Primitive exceptions.
--
@@ -16,7 +13,7 @@ module GHC.Prim.Exception
where
import GHC.Prim
-import GHC.Magic
+import GHC.Types ()
default () -- Double and Integer aren't available yet
@@ -31,25 +28,14 @@ default () -- Double and Integer aren't available yet
--
-- See also: Note [Wired-in exceptions are not CAFfy] in GHC.Core.Make.
-foreign import prim "stg_raiseOverflowzh" raiseOverflow# :: State# RealWorld -> (# State# RealWorld, (# #) #)
-foreign import prim "stg_raiseUnderflowzh" raiseUnderflow# :: State# RealWorld -> (# State# RealWorld, (# #) #)
-foreign import prim "stg_raiseDivZZerozh" raiseDivZero# :: State# RealWorld -> (# State# RealWorld, (# #) #)
-
--- We give a bottoming demand signature to 'raiseOverflow', 'raiseUnderflow' and
--- 'raiseDivZero' in "GHC.Core.Make". NOINLINE pragmas are necessary because if
--- we ever inlined them we would lose that information.
-
-- | Raise 'GHC.Exception.Type.overflowException'
raiseOverflow :: a
-{-# NOINLINE raiseOverflow #-}
-raiseOverflow = runRW# (\s -> case raiseOverflow# s of (# _, _ #) -> let x = x in x)
+raiseOverflow = raiseOverflow# (# #)
-- | Raise 'GHC.Exception.Type.underflowException'
raiseUnderflow :: a
-{-# NOINLINE raiseUnderflow #-}
-raiseUnderflow = runRW# (\s -> case raiseUnderflow# s of (# _, _ #) -> let x = x in x)
+raiseUnderflow = raiseUnderflow# (# #)
-- | Raise 'GHC.Exception.Type.divZeroException'
raiseDivZero :: a
-{-# NOINLINE raiseDivZero #-}
-raiseDivZero = runRW# (\s -> case raiseDivZero# s of (# _, _ #) -> let x = x in x)
+raiseDivZero = raiseDivZero# (# #)
diff --git a/rts/Prelude.h b/rts/Prelude.h
index b52e1b38fd..a474771f5d 100644
--- a/rts/Prelude.h
+++ b/rts/Prelude.h
@@ -21,9 +21,6 @@
/* See Note [Wired-in exceptions are not CAFfy] in GHC.Core.Make. */
PRELUDE_CLOSURE(ghczmprim_GHCziPrimziPanic_absentSumFieldError_closure);
-PRELUDE_CLOSURE(ghczmprim_GHCziPrimziException_raiseUnderflow_closure);
-PRELUDE_CLOSURE(ghczmprim_GHCziPrimziException_raiseOverflow_closure);
-PRELUDE_CLOSURE(ghczmprim_GHCziPrimziException_raiseDivZZero_closure);
/* Define canonical names so we can abstract away from the actual
* modules these names are defined in.
@@ -121,9 +118,9 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
#define nestedAtomically_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nestedAtomically_closure)
#define doubleReadException DLL_IMPORT_DATA_REF(base_GHCziIOPort_doubleReadException_closure)
#define absentSumFieldError_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziPrimziPanic_absentSumFieldError_closure)
-#define raiseUnderflowException_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziPrimziException_raiseUnderflow_closure)
-#define raiseOverflowException_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziPrimziException_raiseOverflow_closure)
-#define raiseDivZeroException_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziPrimziException_raiseDivZZero_closure)
+#define underflowException_closure DLL_IMPORT_DATA_REF(base_GHCziExceptionziType_underflowException_closure)
+#define overflowException_closure DLL_IMPORT_DATA_REF(base_GHCziExceptionziType_overflowException_closure)
+#define divZeroException_closure DLL_IMPORT_DATA_REF(base_GHCziExceptionziType_divZZeroException_closure)
#define blockedOnBadFD_closure DLL_IMPORT_DATA_REF(base_GHCziEventziThread_blockedOnBadFD_closure)
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 8ec69f84ab..a80dfc2959 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -203,6 +203,9 @@ static void initBuiltinGcRoots(void)
getStablePtr((StgPtr)cannotCompactPinned_closure);
getStablePtr((StgPtr)cannotCompactMutable_closure);
getStablePtr((StgPtr)nestedAtomically_closure);
+ getStablePtr((StgPtr)underflowException_closure);
+ getStablePtr((StgPtr)overflowException_closure);
+ getStablePtr((StgPtr)divZeroException_closure);
getStablePtr((StgPtr)runSparks_closure);
getStablePtr((StgPtr)ensureIOManagerIsRunning_closure);
getStablePtr((StgPtr)interruptIOManager_closure);
@@ -220,9 +223,6 @@ static void initBuiltinGcRoots(void)
* GHC.Core.Make.mkExceptionId.
*/
getStablePtr((StgPtr)absentSumFieldError_closure);
- getStablePtr((StgPtr)raiseUnderflowException_closure);
- getStablePtr((StgPtr)raiseOverflowException_closure);
- getStablePtr((StgPtr)raiseDivZeroException_closure);
}
void
View Lorry Controller Status