summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Builtin/Names.hs11
-rw-r--r--compiler/GHC/Builtin/primops.txt.pp45
-rw-r--r--compiler/GHC/Core/Make.hs39
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs3
4 files changed, 47 insertions, 51 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 21196c415d..02a10d4b35 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -533,7 +533,8 @@ genericTyConNames = [
pRELUDE :: Module
pRELUDE = mkBaseModule_ pRELUDE_NAME
-gHC_PRIM, gHC_PRIM_PANIC, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
+gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION,
+ gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,
gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE,
@@ -551,6 +552,7 @@ gHC_PRIM, gHC_PRIM_PANIC, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
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_CSTRING = mkPrimModule (fsLit "GHC.CString")
@@ -2190,7 +2192,9 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
unpackCStringFoldrIdKey, unpackCStringFoldrUtf8IdKey,
unpackCStringIdKey,
typeErrorIdKey, divIntIdKey, modIntIdKey,
- absentSumFieldErrorIdKey, cstringLengthIdKey :: Unique
+ absentSumFieldErrorIdKey, cstringLengthIdKey,
+ raiseOverflowIdKey, raiseUnderflowIdKey, raiseDivZeroIdKey
+ :: Unique
wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders]
absentErrorIdKey = mkPreludeMiscIdUnique 1
@@ -2220,6 +2224,9 @@ typeErrorIdKey = mkPreludeMiscIdUnique 23
divIntIdKey = mkPreludeMiscIdUnique 24
modIntIdKey = mkPreludeMiscIdUnique 25
cstringLengthIdKey = mkPreludeMiscIdUnique 26
+raiseOverflowIdKey = mkPreludeMiscIdUnique 27
+raiseUnderflowIdKey = mkPreludeMiscIdUnique 28
+raiseDivZeroIdKey = mkPreludeMiscIdUnique 29
concatIdKey, filterIdKey, zipIdKey,
bindIOIdKey, returnIOIdKey, newStablePtrIdKey,
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index a9ebb5645f..62391da8f8 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -2617,49 +2617,6 @@ primop RaiseOp "raise#" GenPrimOp
out_of_line = True
can_fail = True
--- Note [Arithmetic exception primops]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- The RTS provides several primops to raise specific exceptions (raiseDivZero#,
--- raiseUnderflow#, raiseOverflow#). These primops are meant to be used by the
--- package implementing arbitrary precision numbers (Natural,Integer). It can't
--- depend on `base` package to raise exceptions in a normal way because it would
--- create a package dependency circle (base <-> bignum package).
---
--- See #14664
-
-primtype Void#
-
-primop RaiseDivZeroOp "raiseDivZero#" GenPrimOp
- Void# -> o
- {Raise a 'DivideByZero' arithmetic exception.}
- -- NB: the type variable "o" is "a", but with OpenKind
- -- See Note [Arithmetic exception primops]
- with
- strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv }
- out_of_line = True
- has_side_effects = True
-
-primop RaiseUnderflowOp "raiseUnderflow#" GenPrimOp
- Void# -> o
- {Raise an 'Underflow' arithmetic exception.}
- -- NB: the type variable "o" is "a", but with OpenKind
- -- See Note [Arithmetic exception primops]
- with
- strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv }
- out_of_line = True
- has_side_effects = True
-
-primop RaiseOverflowOp "raiseOverflow#" GenPrimOp
- Void# -> o
- {Raise an 'Overflow' arithmetic exception.}
- -- NB: the type variable "o" is "a", but with OpenKind
- -- See Note [Arithmetic exception primops]
- with
- strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv }
- out_of_line = True
- has_side_effects = True
-
primop RaiseIOOp "raiseIO#" GenPrimOp
a -> State# RealWorld -> (# State# RealWorld, b #)
with
@@ -3359,6 +3316,8 @@ section "Misc"
{These aren't nearly as wired in as Etc...}
------------------------------------------------------------------------
+primtype Void#
+
primop GetCCSOfOp "getCCSOf#" GenPrimOp
a -> State# s -> (# State# s, Addr# #)
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index e586a92e44..7bc9c161a5 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -744,7 +744,10 @@ errorIds
rEC_SEL_ERROR_ID,
aBSENT_ERROR_ID,
aBSENT_SUM_FIELD_ERROR_ID,
- tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284
+ tYPE_ERROR_ID, -- Used with Opt_DeferTypeErrors, see #10284
+ rAISE_OVERFLOW_ID,
+ rAISE_UNDERFLOW_ID,
+ rAISE_DIVZERO_ID
]
recSelErrorName, runtimeErrorName, absentErrorName :: Name
@@ -752,6 +755,7 @@ recConErrorName, patErrorName :: Name
nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
typeErrorName :: Name
absentSumFieldErrorName :: Name
+raiseOverflowName, raiseUnderflowName, raiseDivZeroName :: Name
recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID
absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID
@@ -771,6 +775,7 @@ 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
@@ -844,8 +849,36 @@ absentSumFieldErrorName
absentSumFieldErrorIdKey
aBSENT_SUM_FIELD_ERROR_ID
-aBSENT_SUM_FIELD_ERROR_ID
- = mkVanillaGlobalWithInfo absentSumFieldErrorName
+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\"
+mkExceptionId :: Name -> Id
+mkExceptionId name
+ = mkVanillaGlobalWithInfo name
(mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a
(vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botDiv
`setCprInfo` mkCprSig 0 botCpr
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index fee96f31f8..38c5327570 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1459,9 +1459,6 @@ emitPrimOp dflags = \case
CasMutVarOp -> alwaysExternal
CatchOp -> alwaysExternal
RaiseOp -> alwaysExternal
- RaiseDivZeroOp -> alwaysExternal
- RaiseUnderflowOp -> alwaysExternal
- RaiseOverflowOp -> alwaysExternal
RaiseIOOp -> alwaysExternal
MaskAsyncExceptionsOp -> alwaysExternal
MaskUninterruptibleOp -> alwaysExternal
View Lorry Controller Status