Commit aba51b65 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Add arithmetic exception primops (#14664)

parent b75e7486
......@@ -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
......
......@@ -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.
......
......@@ -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);
......
......@@ -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);
......
......@@ -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);
}
......@@ -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) \
......
......@@ -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"
......
......@@ -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
{-# 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
arithmetic underflow
arithmetic overflow
divide by zero
......@@ -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, [''])
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment