Add arithmetic exception primops (#14664)

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

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.

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);

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);

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);
+}

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)                                   \

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"

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

testsuite/tests/primops/should_run/T14664.hs

+{-# 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

testsuite/tests/primops/should_run/T14664.stdout

+arithmetic underflow
+arithmetic overflow
+divide by zero

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, [''])

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