Commit 1b3d13b6 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

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.
parent a403eb91
Pipeline #21557 failed with stages
in 487 minutes and 45 seconds
......@@ -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,
......
......@@ -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# #)
......
......@@ -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
......
......@@ -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
......
......@@ -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##
......
......@@ -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#
......@@ -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#)
......
......@@ -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##
......
......@@ -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
......
{-# 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)
......@@ -47,6 +47,7 @@ Library
GHC.Magic
GHC.Prim.Ext
GHC.Prim.Panic
GHC.Prim.Exception
GHC.PrimopWrappers
GHC.Tuple
GHC.Types
......
......@@ -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);
}