From 7f203d00edd639d24af2cf5970e771207adc2bc6 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Mon, 10 Oct 2022 14:51:28 +0200 Subject: 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. --- compiler/GHC/Builtin/Names.hs | 9 ++------- compiler/GHC/Builtin/primops.txt.pp | 24 ++++++++++++++++++++++++ compiler/GHC/Core/Make.hs | 33 ++------------------------------- compiler/GHC/StgToCmm/Prim.hs | 3 +++ 4 files changed, 31 insertions(+), 38 deletions(-) (limited to 'compiler') 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 -- cgit v1.2.1