Add arithmetic exception primops (#14664)

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