summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs3
-rw-r--r--compiler/prelude/primops.txt.pp43
-rw-r--r--includes/stg/MiscClosures.h3
-rw-r--r--rts/Prelude.h3
-rw-r--r--rts/PrimOps.cmm19
-rw-r--r--rts/RtsSymbols.c3
-rw-r--r--rts/package.conf.in6
-rw-r--r--rts/win32/libHSbase.def3
-rw-r--r--testsuite/tests/primops/should_run/T14664.hs17
-rw-r--r--testsuite/tests/primops/should_run/T14664.stdout3
-rw-r--r--testsuite/tests/primops/should_run/all.T1
-rw-r--r--utils/genprimopcode/Main.hs1
12 files changed, 105 insertions, 0 deletions
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 4354814751..6c5a836d7b 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1453,6 +1453,9 @@ emitPrimOp dflags = \case
CasMutVarOp -> alwaysExternal
CatchOp -> alwaysExternal
RaiseOp -> alwaysExternal
+ RaiseDivZeroOp -> alwaysExternal
+ RaiseUnderflowOp -> alwaysExternal
+ RaiseOverflowOp -> alwaysExternal
RaiseIOOp -> alwaysExternal
MaskAsyncExceptionsOp -> alwaysExternal
MaskUninterruptibleOp -> alwaysExternal
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 4180152460..f86a222daa 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -2601,6 +2601,49 @@ primop RaiseOp "raise#" GenPrimOp
-- returns bottom independently ensures that we are careful not to discard
-- it. But still, it's better to say the Right Thing.
+-- 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] botRes }
+ 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] botRes }
+ 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] botRes }
+ out_of_line = True
+ has_side_effects = True
+
-- raiseIO# needs to be a primop, because exceptions in the IO monad
-- must be *precise* - we don't want the strictness analyser turning
-- one kind of bottom into another, as it is allowed to do in pure code.
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 34ec3e5f7b..0843b95b37 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -415,6 +415,9 @@ RTS_FUN_DECL(stg_asyncDoProczh);
RTS_FUN_DECL(stg_catchzh);
RTS_FUN_DECL(stg_raisezh);
+RTS_FUN_DECL(stg_raiseDivZZerozh);
+RTS_FUN_DECL(stg_raiseUnderflowzh);
+RTS_FUN_DECL(stg_raiseOverflowzh);
RTS_FUN_DECL(stg_raiseIOzh);
RTS_FUN_DECL(stg_makeStableNamezh);
diff --git a/rts/Prelude.h b/rts/Prelude.h
index 6e5bf03bd6..7bcb6292fa 100644
--- a/rts/Prelude.h
+++ b/rts/Prelude.h
@@ -47,6 +47,9 @@ PRELUDE_CLOSURE(base_ControlziExceptionziBase_nonTermination_closure);
PRELUDE_CLOSURE(base_ControlziExceptionziBase_nestedAtomically_closure);
PRELUDE_CLOSURE(base_ControlziExceptionziBase_absentSumFieldError_closure);
PRELUDE_CLOSURE(base_GHCziEventziThread_blockedOnBadFD_closure);
+PRELUDE_CLOSURE(base_GHCziExceptionziType_divZZeroException_closure);
+PRELUDE_CLOSURE(base_GHCziExceptionziType_underflowException_closure);
+PRELUDE_CLOSURE(base_GHCziExceptionziType_overflowException_closure);
PRELUDE_CLOSURE(base_GHCziConcziSync_runSparks_closure);
PRELUDE_CLOSURE(base_GHCziConcziIO_ensureIOManagerIsRunning_closure);
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 7f0b7d5d90..78a958d5ec 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -31,6 +31,9 @@ import pthread_mutex_unlock;
#endif
import CLOSURE base_ControlziExceptionziBase_nestedAtomically_closure;
import CLOSURE base_GHCziIOziException_heapOverflow_closure;
+import CLOSURE base_GHCziExceptionziType_divZZeroException_closure;
+import CLOSURE base_GHCziExceptionziType_underflowException_closure;
+import CLOSURE base_GHCziExceptionziType_overflowException_closure;
import EnterCriticalSection;
import LeaveCriticalSection;
import CLOSURE ghczmprim_GHCziTypes_False_closure;
@@ -2606,3 +2609,19 @@ stg_setThreadAllocationCounterzh ( I64 counter )
StgTSO_alloc_limit(CurrentTSO) = counter + TO_I64(offset);
return ();
}
+
+
+stg_raiseDivZZerozh ()
+{
+ jump stg_raisezh(base_GHCziExceptionziType_divZZeroException_closure);
+}
+
+stg_raiseUnderflowzh ()
+{
+ jump stg_raisezh(base_GHCziExceptionziType_underflowException_closure);
+}
+
+stg_raiseOverflowzh ()
+{
+ jump stg_raisezh(base_GHCziExceptionziType_overflowException_closure);
+}
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index aef49606b3..c62810b4d3 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -728,6 +728,9 @@
SymI_HasProto(prog_argv) \
SymI_HasProto(stg_putMVarzh) \
SymI_HasProto(stg_raisezh) \
+ SymI_HasProto(stg_raiseDivZZerozh) \
+ SymI_HasProto(stg_raiseUnderflowzh) \
+ SymI_HasProto(stg_raiseOverflowzh) \
SymI_HasProto(stg_raiseIOzh) \
SymI_HasProto(stg_readTVarzh) \
SymI_HasProto(stg_readTVarIOzh) \
diff --git a/rts/package.conf.in b/rts/package.conf.in
index e4cb159cb8..c13e20119a 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -101,6 +101,9 @@ ld-options:
, "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure"
, "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure"
, "-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure"
+ , "-Wl,-u,_base_GHCziExceptionziType_divZZeroException_closure"
+ , "-Wl,-u,_base_GHCziExceptionziType_underflowException_closure"
+ , "-Wl,-u,_base_GHCziExceptionziType_overflowException_closure"
, "-Wl,-u,_base_GHCziConcziSync_runSparks_closure"
, "-Wl,-u,_base_GHCziConcziIO_ensureIOManagerIsRunning_closure"
, "-Wl,-u,_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure"
@@ -204,6 +207,9 @@ ld-options:
, "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure"
, "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure"
, "-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure"
+ , "-Wl,-u,base_GHCziExceptionziType_divZZeroException_closure"
+ , "-Wl,-u,base_GHCziExceptionziType_underflowException_closure"
+ , "-Wl,-u,base_GHCziExceptionziType_overflowException_closure"
, "-Wl,-u,base_GHCziConcziSync_runSparks_closure"
, "-Wl,-u,base_GHCziConcziIO_ensureIOManagerIsRunning_closure"
, "-Wl,-u,base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure"
diff --git a/rts/win32/libHSbase.def b/rts/win32/libHSbase.def
index d4ec1fab0a..0b674452a1 100644
--- a/rts/win32/libHSbase.def
+++ b/rts/win32/libHSbase.def
@@ -46,3 +46,6 @@ EXPORTS
base_ControlziExceptionziBase_nonTermination_closure
base_ControlziExceptionziBase_nestedAtomically_closure
base_GHCziEventziThread_blockedOnBadFD_closure
+ base_GHCziExceptionziType_divZZeroException_closure
+ base_GHCziExceptionziType_underflowException_closure
+ base_GHCziExceptionziType_overflowException_closure
diff --git a/testsuite/tests/primops/should_run/T14664.hs b/testsuite/tests/primops/should_run/T14664.hs
new file mode 100644
index 0000000000..4c29d327d0
--- /dev/null
+++ b/testsuite/tests/primops/should_run/T14664.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts
+import Control.Exception
+
+main :: IO ()
+main = do
+
+ let
+ printE :: ArithException -> IO ()
+ printE = print
+
+ catch (raiseUnderflow# void#) printE
+ catch (raiseOverflow# void#) printE
+ catch (raiseDivZero# void#) printE
diff --git a/testsuite/tests/primops/should_run/T14664.stdout b/testsuite/tests/primops/should_run/T14664.stdout
new file mode 100644
index 0000000000..35e798039c
--- /dev/null
+++ b/testsuite/tests/primops/should_run/T14664.stdout
@@ -0,0 +1,3 @@
+arithmetic underflow
+arithmetic overflow
+divide by zero
diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T
index bbcbdd8f78..16579207fa 100644
--- a/testsuite/tests/primops/should_run/all.T
+++ b/testsuite/tests/primops/should_run/all.T
@@ -28,3 +28,4 @@ test('CmpInt16', normal, compile_and_run, [''])
test('CmpWord16', normal, compile_and_run, [''])
test('ShrinkSmallMutableArrayA', normal, compile_and_run, [''])
test('ShrinkSmallMutableArrayB', normal, compile_and_run, [''])
+test('T14664', normal, compile_and_run, [''])
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index f7b6ba73dd..7418045e22 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -890,6 +890,7 @@ ppType (TyApp (TyCon "MVar#") [x,y]) = "mkMVarPrimTy " ++ ppType x
++ " " ++ ppType y
ppType (TyApp (TyCon "TVar#") [x,y]) = "mkTVarPrimTy " ++ ppType x
++ " " ++ ppType y
+ppType (TyApp (TyCon "Void#") []) = "voidPrimTy"
ppType (TyApp (VecTyCon _ pptc) []) = pptc
View Lorry Controller Status