[Git][ghc/ghc][master] Numeric exceptions: replace FFI calls with primops
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Oct 25 22:08:00 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7f203d00 by Sylvain Henry at 2022-10-25T18:07:43-04:00
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 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Make.hs
- compiler/GHC/StgToCmm/Prim.hs
- libraries/ghc-prim/GHC/Prim/Exception.hs
- rts/Prelude.h
- rts/RtsStartup.c
Changes:
=====================================
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,
=====================================
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
=====================================
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.
--
=====================================
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
=====================================
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# (# #)
=====================================
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)
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f203d00edd639d24af2cf5970e771207adc2bc6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f203d00edd639d24af2cf5970e771207adc2bc6
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221025/3ade8ec6/attachment-0001.html>
More information about the ghc-commits
mailing list