Numeric exceptions: replace FFI calls with primops

ghc-bignum needs a way to raise numerical exceptions defined in base
package. At the time we used FFI calls into primops defined in the RTS.
These FFI calls had to be wrapped into hacky bottoming functions because
"foreign import prim" syntax doesn't support giving a bottoming demand
to the foreign call (cf #16929).

These hacky wrapper functions trip up the JavaScript backend (#21078)
because they are polymorphic in their return type. This commit
replaces them with primops very similar to raise# but raising predefined
exceptions.

7 files changed, 41 insertions, 65 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 7daba318ef..57e2fcdc75 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -532,7 +532,7 @@ genericTyConNames = [
 pRELUDE :: Module
 pRELUDE         = mkBaseModule_ pRELUDE_NAME
 
-gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION,
+gHC_PRIM, gHC_PRIM_PANIC,
     gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_MAGIC_DICT,
     gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,
     gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
@@ -552,7 +552,6 @@ gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION,
 
 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_MAGIC_DICT  = mkPrimModule (fsLit "GHC.Magic.Dict")
@@ -2259,8 +2258,7 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
     unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey,
     unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey,
     typeErrorIdKey, divIntIdKey, modIntIdKey,
-    absentSumFieldErrorIdKey, cstringLengthIdKey,
-    raiseOverflowIdKey, raiseUnderflowIdKey, raiseDivZeroIdKey
+    absentSumFieldErrorIdKey, cstringLengthIdKey
     :: Unique
 
 wildCardKey                   = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]
@@ -2293,9 +2291,6 @@ typeErrorIdKey                = mkPreludeMiscIdUnique 24
 divIntIdKey                   = mkPreludeMiscIdUnique 25
 modIntIdKey                   = mkPreludeMiscIdUnique 26
 cstringLengthIdKey            = mkPreludeMiscIdUnique 27
-raiseOverflowIdKey            = mkPreludeMiscIdUnique 28
-raiseUnderflowIdKey           = mkPreludeMiscIdUnique 29
-raiseDivZeroIdKey             = mkPreludeMiscIdUnique 30
 
 concatIdKey, filterIdKey, zipIdKey,
     bindIOIdKey, returnIOIdKey, newStablePtrIdKey,
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index 2deb2f48ef..1fc7bd5f23 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -2573,6 +2573,30 @@ primop  RaiseOp "raise#" GenPrimOp
    out_of_line = True
    can_fail = True
 
+primop  RaiseUnderflowOp "raiseUnderflow#" GenPrimOp
+   (# #) -> p
+   with
+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }
+   out_of_line = True
+   can_fail = True
+   code_size = { primOpCodeSizeForeignCall }
+
+primop  RaiseOverflowOp "raiseOverflow#" GenPrimOp
+   (# #) -> p
+   with
+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }
+   out_of_line = True
+   can_fail = True
+   code_size = { primOpCodeSizeForeignCall }
+
+primop  RaiseDivZeroOp "raiseDivZero#" GenPrimOp
+   (# #) -> p
+   with
+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }
+   out_of_line = True
+   can_fail = True
+   code_size = { primOpCodeSizeForeignCall }
+
 primop  RaiseIOOp "raiseIO#" GenPrimOp
    v -> State# RealWorld -> (# State# RealWorld, p #)
    with
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index 41757c0d30..9c3b8edfee 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -768,10 +768,7 @@ errorIds
       rEC_SEL_ERROR_ID,
       aBSENT_ERROR_ID,
       aBSENT_SUM_FIELD_ERROR_ID,
-      tYPE_ERROR_ID,   -- Used with Opt_DeferTypeErrors, see #10284
-      rAISE_OVERFLOW_ID,
-      rAISE_UNDERFLOW_ID,
-      rAISE_DIVZERO_ID
+      tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284
       ]
 
 recSelErrorName, runtimeErrorName, absentErrorName :: Name
@@ -779,7 +776,6 @@ recConErrorName, patErrorName :: Name
 nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
 typeErrorName :: Name
 absentSumFieldErrorName :: Name
-raiseOverflowName, raiseUnderflowName, raiseDivZeroName :: Name
 
 recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID
 runtimeErrorName    = err_nm "runtimeError"    runtimeErrorIdKey    rUNTIME_ERROR_ID
@@ -798,7 +794,6 @@ 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
@@ -913,31 +908,7 @@ absentErrorName
       absentErrorIdKey
       aBSENT_ERROR_ID
 
-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\"
 --
@@ -974,7 +945,7 @@ runtimeErrorTy :: Type
 runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
                                  (mkVisFunTyMany addrPrimTy openAlphaTy)
 
--- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID' or 'raiseOverflow', that
+-- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID', that
 -- throws an (imprecise) exception after being supplied one value arg for every
 -- argument 'Demand' in the list. The demands end up in the demand signature.
 --
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 518080797f..7366c529c8 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1563,6 +1563,9 @@ emitPrimOp cfg primop =
   CasMutVarOp -> alwaysExternal
   CatchOp -> alwaysExternal
   RaiseOp -> alwaysExternal
+  RaiseUnderflowOp -> alwaysExternal
+  RaiseOverflowOp -> alwaysExternal
+  RaiseDivZeroOp -> alwaysExternal
   RaiseIOOp -> alwaysExternal
   MaskAsyncExceptionsOp -> alwaysExternal
   MaskUninterruptibleOp -> alwaysExternal
diff --git a/libraries/ghc-prim/GHC/Prim/Exception.hs b/libraries/ghc-prim/GHC/Prim/Exception.hs
index 5984dab09c..71c17f96a4 100644
--- a/libraries/ghc-prim/GHC/Prim/Exception.hs
+++ b/libraries/ghc-prim/GHC/Prim/Exception.hs
@@ -1,9 +1,6 @@
-{-# LANGUAGE GHCForeignImportPrim #-}
-{-# LANGUAGE UnliftedFFITypes #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE EmptyCase #-}
 
 -- | Primitive exceptions.
 --
@@ -16,7 +13,7 @@ module GHC.Prim.Exception
 where
 
 import GHC.Prim
-import GHC.Magic
+import GHC.Types ()
 
 default () -- Double and Integer aren't available yet
 
@@ -31,25 +28,14 @@ default () -- Double and Integer aren't available yet
 --
 -- See also: Note [Wired-in exceptions are not CAFfy] in GHC.Core.Make.
 
-foreign import prim "stg_raiseOverflowzh" raiseOverflow# :: State# RealWorld -> (# State# RealWorld, (# #) #)
-foreign import prim "stg_raiseUnderflowzh" raiseUnderflow# :: State# RealWorld -> (# State# RealWorld, (# #) #)
-foreign import prim "stg_raiseDivZZerozh" raiseDivZero# :: State# RealWorld -> (# State# RealWorld, (# #) #)
-
--- 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)
+raiseOverflow = raiseOverflow# (# #)
 
 -- | Raise 'GHC.Exception.Type.underflowException'
 raiseUnderflow :: a
-{-# NOINLINE raiseUnderflow #-}
-raiseUnderflow = runRW# (\s -> case raiseUnderflow# s of (# _, _ #) -> let x = x in x)
+raiseUnderflow = raiseUnderflow# (# #)
 
 -- | Raise 'GHC.Exception.Type.divZeroException'
 raiseDivZero :: a
-{-# NOINLINE raiseDivZero #-}
-raiseDivZero = runRW# (\s -> case raiseDivZero# s of (# _, _ #) -> let x = x in x)
+raiseDivZero = raiseDivZero# (# #)
diff --git a/rts/Prelude.h b/rts/Prelude.h
index b52e1b38fd..a474771f5d 100644
--- a/rts/Prelude.h
+++ b/rts/Prelude.h
@@ -21,9 +21,6 @@
 
 /* See Note [Wired-in exceptions are not CAFfy] in GHC.Core.Make. */
 PRELUDE_CLOSURE(ghczmprim_GHCziPrimziPanic_absentSumFieldError_closure);
-PRELUDE_CLOSURE(ghczmprim_GHCziPrimziException_raiseUnderflow_closure);
-PRELUDE_CLOSURE(ghczmprim_GHCziPrimziException_raiseOverflow_closure);
-PRELUDE_CLOSURE(ghczmprim_GHCziPrimziException_raiseDivZZero_closure);
 
 /* Define canonical names so we can abstract away from the actual
  * modules these names are defined in.
@@ -121,9 +118,9 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
 #define nestedAtomically_closure  DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nestedAtomically_closure)
 #define doubleReadException  DLL_IMPORT_DATA_REF(base_GHCziIOPort_doubleReadException_closure)
 #define absentSumFieldError_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziPrimziPanic_absentSumFieldError_closure)
-#define raiseUnderflowException_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziPrimziException_raiseUnderflow_closure)
-#define raiseOverflowException_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziPrimziException_raiseOverflow_closure)
-#define raiseDivZeroException_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziPrimziException_raiseDivZZero_closure)
+#define underflowException_closure DLL_IMPORT_DATA_REF(base_GHCziExceptionziType_underflowException_closure)
+#define overflowException_closure DLL_IMPORT_DATA_REF(base_GHCziExceptionziType_overflowException_closure)
+#define divZeroException_closure  DLL_IMPORT_DATA_REF(base_GHCziExceptionziType_divZZeroException_closure)
 
 #define blockedOnBadFD_closure    DLL_IMPORT_DATA_REF(base_GHCziEventziThread_blockedOnBadFD_closure)
 
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 8ec69f84ab..a80dfc2959 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -203,6 +203,9 @@ static void initBuiltinGcRoots(void)
     getStablePtr((StgPtr)cannotCompactPinned_closure);
     getStablePtr((StgPtr)cannotCompactMutable_closure);
     getStablePtr((StgPtr)nestedAtomically_closure);
+    getStablePtr((StgPtr)underflowException_closure);
+    getStablePtr((StgPtr)overflowException_closure);
+    getStablePtr((StgPtr)divZeroException_closure);
     getStablePtr((StgPtr)runSparks_closure);
     getStablePtr((StgPtr)ensureIOManagerIsRunning_closure);
     getStablePtr((StgPtr)interruptIOManager_closure);
@@ -220,9 +223,6 @@ static void initBuiltinGcRoots(void)
      * GHC.Core.Make.mkExceptionId.
      */
     getStablePtr((StgPtr)absentSumFieldError_closure);
-    getStablePtr((StgPtr)raiseUnderflowException_closure);
-    getStablePtr((StgPtr)raiseOverflowException_closure);
-    getStablePtr((StgPtr)raiseDivZeroException_closure);
 }
 
 void