Fix ghc-bignum exceptions

We must ensure that exceptions are not simplified. Previously we used:

   case raiseDivZero of
      _ -> 0## -- dummyValue

But it was wrong because the evaluation of `raiseDivZero` was removed and
the dummy value was directly returned. See new Note [ghc-bignum exceptions].

I've also removed the exception triggering primops which were fragile.
We don't need them to be primops, we can have them exported by ghc-prim.

I've also added a test for #18359 which triggered this patch.

17 files changed, 255 insertions, 126 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
diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs
index 156a76d9ed..cf08320a11 100644
--- a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs
+++ b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs
@@ -101,6 +101,11 @@ bigNatOne :: Void# -> BigNat -- cf Note [Why Void#?]
 bigNatOne _ = case bigNatOneW of
    BigNatW w -> w
 
+raiseDivZero_BigNat :: Void# -> BigNat
+raiseDivZero_BigNat _ = case raiseDivZero of
+   !_ -> bigNatZero void#
+   -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives
+
 -- | Indicate if a bigNat is zero
 bigNatIsZero :: BigNat -> Bool
 bigNatIsZero bn = isTrue# (bigNatIsZero# bn)
@@ -486,7 +491,10 @@ bigNatSubUnsafe a b
       in withNewWordArrayTrimed# szA \mwa s->
             case inline bignat_sub mwa a b s of
                (# s', 0# #) -> s'
-               (# s', _  #) -> case underflow of _ -> s'
+               (# s', _  #) -> case raiseUnderflow of
+                                 !_ -> s'
+                                 -- see Note [ghc-bignum exceptions] in
+                                 -- GHC.Num.Primitives
 
 -- | Subtract two BigNat
 bigNatSub :: BigNat -> BigNat -> (# () | BigNat #)
@@ -511,7 +519,7 @@ bigNatSub a b
 bigNatQuotWord# :: BigNat -> Word# -> BigNat
 bigNatQuotWord# a b
    | 1## <- b = a
-   | 0## <- b = case divByZero of _ -> bigNatZero void#
+   | 0## <- b = raiseDivZero_BigNat void#
    | True =
    let
       sz = wordArraySize# a
@@ -531,7 +539,7 @@ bigNatQuotWord a (W# b) = bigNatQuotWord# a b
 --    b /= 0
 bigNatRemWord# :: BigNat -> Word# -> Word#
 bigNatRemWord# a b
-   | 0## <- b       = case divByZero of _ -> 0##
+   | 0## <- b       = raiseDivZero_Word# void#
    | 1## <- b       = 0##
    | bigNatIsZero a = 0##
    | True           = inline bignat_rem_word a b
@@ -549,7 +557,9 @@ bigNatRemWord a (W# b) = W# (bigNatRemWord# a b)
 --    b /= 0
 bigNatQuotRemWord# :: BigNat -> Word# -> (# BigNat, Word# #)
 bigNatQuotRemWord# a b
-   | 0## <- b = case divByZero of _ -> (# bigNatZero void#, 0## #)
+   | 0## <- b = case raiseDivZero of
+                  !_ -> (# bigNatZero void#, 0## #)
+                  -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives
    | 1## <- b = (# a, 0## #)
    | isTrue# (bigNatSize# a ==# 1#)
    , a0 <- indexWordArray# a 0#
@@ -575,7 +585,9 @@ bigNatQuotRemWord# a b
 -- | BigNat division returning (quotient,remainder)
 bigNatQuotRem# :: BigNat -> BigNat -> (# BigNat,BigNat #)
 bigNatQuotRem# a b
-   | bigNatIsZero b          = case divByZero of _ -> (# bigNatZero void#, bigNatZero void# #)
+   | bigNatIsZero b          = case raiseDivZero of
+                                 !_ -> (# bigNatZero void#, bigNatZero void# #)
+                                 -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives
    | bigNatIsZero a          = (# bigNatZero void#, bigNatZero void# #)
    | bigNatIsOne b           = (# a               , bigNatZero void# #)
    | LT <- cmp               = (# bigNatZero void#, a #)
@@ -596,7 +608,7 @@ bigNatQuotRem# a b
 -- | BigNat division returning quotient
 bigNatQuot :: BigNat -> BigNat -> BigNat
 bigNatQuot a b
-   | bigNatIsZero b          = case divByZero of _ -> bigNatZero void#
+   | bigNatIsZero b          = raiseDivZero_BigNat void#
    | bigNatIsZero a          = bigNatZero void#
    | bigNatIsOne b           = a
    | LT <- cmp               = bigNatZero void#
@@ -613,7 +625,7 @@ bigNatQuot a b
 -- | BigNat division returning remainder
 bigNatRem :: BigNat -> BigNat -> BigNat
 bigNatRem a b
-   | bigNatIsZero b          = case divByZero of _ -> bigNatZero void#
+   | bigNatIsZero b          = raiseDivZero_BigNat void#
    | bigNatIsZero a          = bigNatZero void#
    | bigNatIsOne b           = bigNatZero void#
    | LT <- cmp               = a
@@ -1036,7 +1048,7 @@ bigNatLog2 a = W# (bigNatLog2# a)
 bigNatLogBase# :: BigNat -> BigNat -> Word#
 bigNatLogBase# base a
    | bigNatIsZero base || bigNatIsOne base
-   = case unexpectedValue of _ -> 0##
+   = unexpectedValue_Word# void#
 
    | 1# <- bigNatSize# base
    , 2## <- bigNatIndex# base 0#
@@ -1062,8 +1074,8 @@ bigNatLogBase base a = W# (bigNatLogBase# base a)
 -- | Logarithm for an arbitrary base
 bigNatLogBaseWord# :: Word# -> BigNat -> Word#
 bigNatLogBaseWord# base a
-   | 0## <- base = case unexpectedValue of _ -> 0##
-   | 1## <- base = case unexpectedValue of _ -> 0##
+   | 0## <- base = unexpectedValue_Word# void#
+   | 1## <- base = unexpectedValue_Word# void#
    | 2## <- base = bigNatLog2# a
    -- TODO: optimize log base power of 2 (256, etc.)
    | True = bigNatLogBase# (bigNatFromWord# base) a
@@ -1082,7 +1094,7 @@ bigNatLogBaseWord (W# base) a = W# (bigNatLogBaseWord# base a)
 bigNatSizeInBase# :: Word# -> BigNat -> Word#
 bigNatSizeInBase# base a
    | isTrue# (base `leWord#` 1##)
-   = case unexpectedValue of _ -> 0##
+   = unexpectedValue_Word# void#
 
    | bigNatIsZero a
    = 0##
@@ -1111,7 +1123,7 @@ powModWord# = bignat_powmod_words
 -- | \"@'bigNatPowModWord#' /b/ /e/ /m/@\" computes base @/b/@ raised to
 -- exponent @/e/@ modulo @/m/@.
 bigNatPowModWord# :: BigNat -> BigNat -> Word# -> Word#
-bigNatPowModWord# !_ !_ 0## = case divByZero of _ -> 0##
+bigNatPowModWord# !_ !_ 0## = raiseDivZero_Word# void#
 bigNatPowModWord# _  _  1## = 0##
 bigNatPowModWord# b  e  m
    | bigNatIsZero e         = 1##
@@ -1125,7 +1137,7 @@ bigNatPowMod :: BigNat -> BigNat -> BigNat -> BigNat
 bigNatPowMod !b !e !m
    | (# m' | #) <- bigNatToWordMaybe# m
    = bigNatFromWord# (bigNatPowModWord# b e m')
-   | bigNatIsZero m = case divByZero of _ -> bigNatZero void#
+   | bigNatIsZero m = raiseDivZero_BigNat void#
    | bigNatIsOne  m = bigNatFromWord# 0##
    | bigNatIsZero e = bigNatFromWord# 1##
    | bigNatIsZero b = bigNatFromWord# 0##
diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs
index aad7d903ff..011330cf5e 100644
--- a/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs
+++ b/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs
@@ -8,7 +8,6 @@
 {-# LANGUAGE NegativeLiterals #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
-{-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-}
 
 -- | Check Native implementation against another backend
 module GHC.Num.BigNat.Check where
@@ -43,7 +42,7 @@ bignat_compare a b =
       gr = Other.bignat_compare a b
       nr = Native.bignat_compare a b
    in case gr ==# nr of
-         0# -> case unexpectedValue of I# x -> x
+         0# -> unexpectedValue_Int# void#
          _  -> gr
 
 mwaCompare
@@ -81,7 +80,10 @@ mwaCompareOp mwa f g s =
    case mwaTrimZeroes# mwa s of { s ->
    case mwaTrimZeroes# mwb s of { s ->
    case mwaCompare mwa mwb s of
-      (# s, 0# #) -> case unexpectedValue of _ -> s
+      (# s, 0# #) -> case unexpectedValue of
+                        !_ -> s
+                        -- see Note [ghc-bignum exceptions] in
+                        -- GHC.Num.Primitives
       (# s, _  #) -> s
    }}}}}}
 
@@ -106,7 +108,9 @@ mwaCompareOp2 mwa mwb f g s =
    case mwaCompare mwa mwa' s of { (# s, ba #) ->
    case mwaCompare mwb mwb' s of { (# s, bb #) ->
    case ba &&# bb of
-      0# -> case unexpectedValue of _ -> s
+      0# -> case unexpectedValue of
+               !_ -> s
+               -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives
       _  -> s
    }}}}}}}}}}}}
 
@@ -122,13 +126,18 @@ mwaCompareOpBool mwa f g s =
    case f mwa s of { (# s, ra #) ->
    case g mwb s of { (# s, rb #) ->
    case ra ==# rb of
-      0# -> case unexpectedValue of _ -> (# s, ra #)
+      0# -> case unexpectedValue of
+               !_ -> (# s, ra #)
+               -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives
       _  -> case (ra ==# 1#) of -- don't compare MWAs if overflow signaled!
          1# -> (# s, ra #)
          _  -> case mwaTrimZeroes# mwa s of { s ->
                case mwaTrimZeroes# mwb s of { s ->
                case mwaCompare mwa mwb s of
-                  (# s, 0# #) -> case unexpectedValue of _ -> (# s, ra #)
+                  (# s, 0# #) -> case unexpectedValue of
+                                    !_ -> (# s, ra #)
+                                    -- see Note [ghc-bignum exceptions] in
+                                    -- GHC.Num.Primitives
                   _  -> (# s, ra #)
    }}}}}}
 
@@ -147,7 +156,9 @@ mwaCompareOpWord mwa f g s =
    case mwaTrimZeroes# mwb s of { s ->
    case mwaCompare mwa mwb s of
       (# s, b #) -> case b &&# (ra `eqWord#` rb) of
-         0# -> case unexpectedValue of _ -> (# s, ra #)
+         0# -> case unexpectedValue of
+                  !_ -> (# s, ra #)
+                  -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives
          _  -> (# s, ra #)
    }}}}}}
 
@@ -369,8 +380,7 @@ bignat_rem_word wa b =
       nr = Native.bignat_rem_word wa b
    in case gr `eqWord#` nr of
        1# -> gr
-       _  -> case unexpectedValue of
-               W# e -> e
+       _  -> unexpectedValue_Word# void#
 
 bignat_gcd
    :: MutableWordArray# RealWorld
@@ -393,8 +403,7 @@ bignat_gcd_word wa b =
       nr = Native.bignat_gcd_word wa b
    in case gr `eqWord#` nr of
        1# -> gr
-       _  -> case unexpectedValue of
-               W# e -> e
+       _  -> unexpectedValue_Word# void#
 
 bignat_gcd_word_word
    :: Word#
@@ -406,8 +415,7 @@ bignat_gcd_word_word a b =
       nr = Native.bignat_gcd_word_word a b
    in case gr `eqWord#` nr of
        1# -> gr
-       _  -> case unexpectedValue of
-               W# e -> e
+       _  -> unexpectedValue_Word# void#
 
 bignat_encode_double :: WordArray# -> Int# -> Double#
 bignat_encode_double a e =
@@ -417,7 +425,8 @@ bignat_encode_double a e =
    in case gr ==## nr of
        1# -> gr
        _  -> case unexpectedValue of
-               _ -> gr
+               !_ -> 0.0##
+               -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives
 
 bignat_powmod_word :: WordArray# -> WordArray# -> Word# -> Word#
 bignat_powmod_word b e m =
@@ -426,8 +435,7 @@ bignat_powmod_word b e m =
       nr = Native.bignat_powmod_word b e m
    in case gr `eqWord#` nr of
        1# -> gr
-       _  -> case unexpectedValue of
-               W# e -> e
+       _  -> unexpectedValue_Word# void#
 
 bignat_powmod
    :: MutableWordArray# RealWorld
@@ -452,5 +460,4 @@ bignat_powmod_words b e m =
       nr = Native.bignat_powmod_words b e m
    in case gr `eqWord#` nr of
        1# -> gr
-       _  -> case unexpectedValue of
-               W# e -> e
+       _  -> unexpectedValue_Word# void#
diff --git a/libraries/ghc-bignum/src/GHC/Num/Integer.hs b/libraries/ghc-bignum/src/GHC/Num/Integer.hs
index e9e38c9afd..82c109c5f7 100644
--- a/libraries/ghc-bignum/src/GHC/Num/Integer.hs
+++ b/libraries/ghc-bignum/src/GHC/Num/Integer.hs
@@ -767,7 +767,9 @@ integerQuotRem# :: Integer -> Integer -> (# Integer, Integer #)
 {-# NOINLINE integerQuotRem# #-}
 integerQuotRem# !n      (IS 1#) = (# n, IS 0# #)
 integerQuotRem# !n     (IS -1#) = let !q = integerNegate n in (# q, (IS 0#) #)
-integerQuotRem# !_      (IS 0#) = (# divByZero, divByZero #)
+integerQuotRem# !_      (IS 0#) = case raiseDivZero of
+                                    !_ -> (# IS 0#, IS 0# #)
+                                    -- see Note [ghc-bignum exceptions] in GHC.Num.Primitives
 integerQuotRem# (IS 0#) _       = (# IS 0#, IS 0# #)
 integerQuotRem# (IS n#) (IS d#) = case quotRemInt# n# d# of
     (# q#, r# #) -> (# IS q#, IS r# #)
@@ -808,7 +810,7 @@ integerQuot :: Integer -> Integer -> Integer
 {-# NOINLINE integerQuot #-}
 integerQuot !n      (IS 1#)  = n
 integerQuot !n      (IS -1#) = integerNegate n
-integerQuot !_      (IS 0#)  = divByZero
+integerQuot !_      (IS 0#)  = raiseDivZero
 integerQuot (IS 0#) _        = IS 0#
 integerQuot (IS n#) (IS d#)  = IS (quotInt# n# d#)
 integerQuot (IP n)  (IS d#)
diff --git a/libraries/ghc-bignum/src/GHC/Num/Natural.hs b/libraries/ghc-bignum/src/GHC/Num/Natural.hs
index 1adb02181d..574f8f04b3 100644
--- a/libraries/ghc-bignum/src/GHC/Num/Natural.hs
+++ b/libraries/ghc-bignum/src/GHC/Num/Natural.hs
@@ -129,7 +129,7 @@ naturalFromIntUnsafe (I# i) = naturalFromIntUnsafe# i
 -- Throws 'Control.Exception.Underflow' when passed a negative 'Int'.
 naturalFromIntThrow# :: Int# -> Natural
 naturalFromIntThrow# i
-   | isTrue# (i <# 0#) = case underflow of _ -> NS 0##
+   | isTrue# (i <# 0#) = raiseUnderflow
    | True              = naturalFromIntUnsafe# i
 
 -- | Create a Natural from an Int
@@ -154,7 +154,7 @@ naturalToInt !n = I# (naturalToInt# n)
 naturalFromInt# :: Int# -> Natural
 naturalFromInt# !i
    | isTrue# (i >=# 0#) = NS (int2Word# i)
-   | True               = case underflow of _ -> NS 0##
+   | True               = raiseUnderflow
 
 -- | Create a Natural from an Int
 --
@@ -269,15 +269,15 @@ naturalSub (NB x) (NB y) =
 --
 -- Throw an Underflow exception if x < y
 naturalSubThrow :: Natural -> Natural -> Natural
-naturalSubThrow (NS _) (NB _) = case underflow of _ -> NS 0##
+naturalSubThrow (NS _) (NB _) = raiseUnderflow
 naturalSubThrow (NB x) (NS y) = naturalFromBigNat (bigNatSubWordUnsafe# x y)
 naturalSubThrow (NS x) (NS y) =
    case subWordC# x y of
       (# l,0# #) -> NS l
-      (# _,_  #) -> case underflow of _ -> NS 0##
+      (# _,_  #) -> raiseUnderflow
 naturalSubThrow (NB x) (NB y) =
    case bigNatSub x y of
-      (# () | #) -> case underflow of _ -> NS 0##
+      (# () | #) -> raiseUnderflow
       (# | z  #) -> naturalFromBigNat z
 
 -- | Sub two naturals
@@ -325,7 +325,7 @@ naturalSignum _        = NS 1##
 naturalNegate :: Natural -> Natural
 {-# NOINLINE naturalNegate #-}
 naturalNegate (NS 0##) = NS 0##
-naturalNegate _        = case underflow of _ -> NS 0##
+naturalNegate _        = raiseUnderflow
 
 -- | Return division quotient and remainder
 --
@@ -463,7 +463,7 @@ naturalLogBase !base !a = W# (naturalLogBase# base a)
 -- | \"@'naturalPowMod' /b/ /e/ /m/@\" computes base @/b/@ raised to
 -- exponent @/e/@ modulo @/m/@.
 naturalPowMod :: Natural -> Natural -> Natural -> Natural
-naturalPowMod !_         !_       (NS 0##) = case divByZero of _ -> naturalZero
+naturalPowMod !_         !_       (NS 0##) = raiseDivZero
 naturalPowMod _          _        (NS 1##) = NS 0##
 naturalPowMod _          (NS 0##) _        = NS 1##
 naturalPowMod (NS 0##)   _        _        = NS 0##
diff --git a/libraries/ghc-bignum/src/GHC/Num/Primitives.hs b/libraries/ghc-bignum/src/GHC/Num/Primitives.hs
index 2c1a0b6955..358c83b3be 100644
--- a/libraries/ghc-bignum/src/GHC/Num/Primitives.hs
+++ b/libraries/ghc-bignum/src/GHC/Num/Primitives.hs
@@ -68,9 +68,13 @@ module GHC.Num.Primitives
    , wordWriteMutableByteArrayLE#
    , wordWriteMutableByteArrayBE#
    -- * Exception
-   , underflow
-   , divByZero
+   , raiseUnderflow
+   , raiseUnderflow_Word#
+   , raiseDivZero
+   , raiseDivZero_Word#
    , unexpectedValue
+   , unexpectedValue_Int#
+   , unexpectedValue_Word#
    -- * IO
    , ioWord#
    , ioInt#
@@ -87,6 +91,8 @@ where
 
 #if (__GLASGOW_HASKELL__ < 811)
 import GHC.Magic
+#else
+import GHC.Prim.Exception
 #endif
 
 import GHC.Prim
@@ -241,7 +247,7 @@ wordLog2# w   = (WORD_SIZE_IN_BITS## `minusWord#` 1##) `minusWord#` (clz# w)
 wordLogBase# :: Word# -> Word# -> Word#
 wordLogBase# base a
    | isTrue# (base `leWord#` 1##)
-   = case unexpectedValue of _ -> 0##
+   = unexpectedValue_Word# void#
 
    | 2## <- base
    = wordLog2# a
@@ -590,32 +596,63 @@ ioBool (IO io) s = case io s of
 -- Exception
 ----------------------------------
 
-#if (__GLASGOW_HASKELL__ >= 811)
+-- Note [ghc-bignum exceptions]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- `ghc-bignum` package can't depend on `base` package (it would create a cyclic
+-- dependency). Hence it can't import "Control.Exception" and throw exceptions
+-- the usual way. Instead it uses some wired-in functions from `ghc-prim` which
+-- themselves call wired-in functions from the RTS: raiseOverflow,
+-- raiseUnderflow, raiseDivZero.
+--
+-- We have to be careful when we want to throw an exception instead of returning
+-- an unlifted value (e.g. Word#, unboxed tuple, etc.). We have to ensure the
+-- evaluation of the exception throwing function before returning a dummy value,
+-- otherwise it will be removed by the simplifier as dead-code.
+--
+--    foo :: ... -> Word#
+--    foo = ... case raiseDivZero of
+--                !_ -> 0## -- the bang-pattern is necessary!
+--                          -- 0## is a dummy value (unreachable code)
+--
+
+unexpectedValue_Int# :: Void# -> Int#
+unexpectedValue_Int# _ = case unexpectedValue of
+   !_ -> 0# -- see Note [ghc-bignum exceptions]
+
+unexpectedValue_Word# :: Void# -> Word#
+unexpectedValue_Word# _ = case unexpectedValue of
+   !_ -> 0## -- see Note [ghc-bignum exceptions]
 
-underflow :: a
-underflow = raiseUnderflow# void#
+raiseDivZero_Word# :: Void# -> Word#
+raiseDivZero_Word# _ = case raiseDivZero of
+   !_ -> 0## -- see Note [ghc-bignum exceptions]
 
-divByZero :: a
-divByZero = raiseDivZero# void#
+raiseUnderflow_Word# :: Void# -> Word#
+raiseUnderflow_Word# _ = case raiseUnderflow of
+   !_ -> 0## -- see Note [ghc-bignum exceptions]
+
+#if (__GLASGOW_HASKELL__ >= 811)
 
 unexpectedValue :: a
-unexpectedValue = raiseOverflow# void#
+unexpectedValue = raiseOverflow
 
 #else
 
 -- Before GHC 8.11 we use the exception trick taken from #14664
 exception :: a
+{-# NOINLINE exception #-}
 exception = runRW# \s ->
    case atomicLoop s of
       (# _, a #) -> a
    where
       atomicLoop s = atomically# atomicLoop s
 
-underflow :: a
-underflow = exception
+raiseUnderflow :: a
+raiseUnderflow = exception
 
-divByZero :: a
-divByZero = exception
+raiseDivZero :: a
+raiseDivZero = exception
 
 unexpectedValue :: a
 unexpectedValue = exception
diff --git a/libraries/ghc-prim/GHC/Prim/Exception.hs b/libraries/ghc-prim/GHC/Prim/Exception.hs
new file mode 100644
index 0000000000..36889dc1e3
--- /dev/null
+++ b/libraries/ghc-prim/GHC/Prim/Exception.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE EmptyCase #-}
+
+-- | Primitive exceptions.
+module GHC.Prim.Exception
+   ( raiseOverflow
+   , raiseUnderflow
+   , raiseDivZero
+   )
+where
+
+import GHC.Prim
+import GHC.Magic
+
+default () -- Double and Integer aren't available yet
+
+-- Note [Arithmetic exceptions]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- ghc-prim provides several functions to raise arithmetic exceptions
+-- (raiseDivZero, raiseUnderflow, raiseOverflow) that are wired-in the RTS.
+-- These exceptions 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 dependency
+-- cycle (base <-> bignum package). See #14664
+
+foreign import prim "stg_raiseOverflowzh" raiseOverflow# :: State# RealWorld -> (# State# RealWorld, Void# #)
+foreign import prim "stg_raiseUnderflowzh" raiseUnderflow# :: State# RealWorld -> (# State# RealWorld, Void# #)
+foreign import prim "stg_raiseDivZZerozh" raiseDivZero# :: State# RealWorld -> (# State# RealWorld, Void# #)
+
+-- 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)
+
+-- | Raise 'GHC.Exception.Type.underflowException'
+raiseUnderflow :: a
+{-# NOINLINE raiseUnderflow #-}
+raiseUnderflow = runRW# (\s -> case raiseUnderflow# s of (# _, _ #) -> let x = x in x)
+
+-- | Raise 'GHC.Exception.Type.divZeroException'
+raiseDivZero :: a
+{-# NOINLINE raiseDivZero #-}
+raiseDivZero = runRW# (\s -> case raiseDivZero# s of (# _, _ #) -> let x = x in x)
diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal
index 4ac3054b05..625773b4fe 100644
--- a/libraries/ghc-prim/ghc-prim.cabal
+++ b/libraries/ghc-prim/ghc-prim.cabal
@@ -47,6 +47,7 @@ Library
         GHC.Magic
         GHC.Prim.Ext
         GHC.Prim.Panic
+        GHC.Prim.Exception
         GHC.PrimopWrappers
         GHC.Tuple
         GHC.Types
diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index 587708e47e..3216edbcc4 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -14,6 +14,9 @@
 #include "RaiseAsync.h"
 
 import CLOSURE ghczmprim_GHCziTypes_True_closure;
+import CLOSURE base_GHCziExceptionziType_divZZeroException_closure;
+import CLOSURE base_GHCziExceptionziType_underflowException_closure;
+import CLOSURE base_GHCziExceptionziType_overflowException_closure;
 
 /* -----------------------------------------------------------------------------
    Exception Primitives
@@ -633,6 +636,22 @@ stg_raiseIOzh (P_ exception)
     jump stg_raisezh (exception);
 }
 
+
+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);
+}
+
 /* The FFI doesn't support variadic C functions so we can't directly expose
  * `barf` to Haskell code. Instead we define "stg_panic#" and it is exposed to
  * Haskell programs in GHC.Prim.Panic.
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 1bd30b3af0..1fd746edf6 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -31,9 +31,6 @@ 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;
@@ -2601,19 +2598,3 @@ 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/testsuite/tests/numeric/should_run/T18359.hs b/testsuite/tests/numeric/should_run/T18359.hs
new file mode 100644
index 0000000000..16deba75dd
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T18359.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE MagicHash #-}
+
+import GHC.Num.BigNat
+import GHC.Num.Primitives
+import GHC.Prim.Exception
+import GHC.Exts
+import Control.Exception
+
+main :: IO ()
+main = do
+   foo  `catch` \DivideByZero -> putStrLn "Caught DivideByZero exception in foo"
+   foo2 `catch` \DivideByZero -> putStrLn "Caught DivideByZero exception in foo2"
+
+foo2 = case raiseDivZero of
+   I# _ -> print "NOPE"
+
+foo :: IO ()
+foo = print (W# (bigNatRemWord# (bigNatOne void#) 0##))
diff --git a/testsuite/tests/numeric/should_run/T18359.stdout b/testsuite/tests/numeric/should_run/T18359.stdout
new file mode 100644
index 0000000000..65d3805d2e
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T18359.stdout
@@ -0,0 +1,2 @@
+Caught DivideByZero exception in foo
+Caught DivideByZero exception in foo2
diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T
index 71e81daaab..ce44e15729 100644
--- a/testsuite/tests/numeric/should_run/all.T
+++ b/testsuite/tests/numeric/should_run/all.T
@@ -69,3 +69,4 @@ test('T12136', normal, compile_and_run, [''])
 test('T15301', normal, compile_and_run, ['-O2'])
 test('T497', normal, compile_and_run, ['-O'])
 test('T17303', normal, compile_and_run, [''])
+test('T18359', normal, compile_and_run, [''])
diff --git a/testsuite/tests/primops/should_run/T14664.hs b/testsuite/tests/primops/should_run/T14664.hs
index 4c29d327d0..a7b8308024 100644
--- a/testsuite/tests/primops/should_run/T14664.hs
+++ b/testsuite/tests/primops/should_run/T14664.hs
@@ -3,6 +3,7 @@
 module Main where
 
 import GHC.Exts
+import GHC.Prim.Exception
 import Control.Exception
 
 main :: IO ()
@@ -12,6 +13,6 @@ main = do
       printE :: ArithException -> IO ()
       printE = print
 
-   catch (raiseUnderflow# void#) printE
-   catch (raiseOverflow#  void#) printE
-   catch (raiseDivZero#   void#) printE
+   catch raiseUnderflow printE
+   catch raiseOverflow  printE
+   catch raiseDivZero   printE