diff options
| -rw-r--r-- | compiler/GHC/Builtin/Names.hs | 11 | ||||
| -rw-r--r-- | compiler/GHC/Builtin/primops.txt.pp | 45 | ||||
| -rw-r--r-- | compiler/GHC/Core/Make.hs | 39 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Prim.hs | 3 | ||||
| -rw-r--r-- | libraries/ghc-bignum/src/GHC/Num/BigNat.hs | 38 | ||||
| -rw-r--r-- | libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs | 43 | ||||
| -rw-r--r-- | libraries/ghc-bignum/src/GHC/Num/Integer.hs | 6 | ||||
| -rw-r--r-- | libraries/ghc-bignum/src/GHC/Num/Natural.hs | 14 | ||||
| -rw-r--r-- | libraries/ghc-bignum/src/GHC/Num/Primitives.hs | 63 | ||||
| -rw-r--r-- | libraries/ghc-prim/GHC/Prim/Exception.hs | 52 | ||||
| -rw-r--r-- | libraries/ghc-prim/ghc-prim.cabal | 1 | ||||
| -rw-r--r-- | rts/Exception.cmm | 19 | ||||
| -rw-r--r-- | rts/PrimOps.cmm | 19 | ||||
| -rw-r--r-- | testsuite/tests/numeric/should_run/T18359.hs | 18 | ||||
| -rw-r--r-- | testsuite/tests/numeric/should_run/T18359.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/numeric/should_run/all.T | 1 | ||||
| -rw-r--r-- | testsuite/tests/primops/should_run/T14664.hs | 7 |
17 files changed, 255 insertions, 126 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 21196c415d..02a10d4b35 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -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, diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index a9ebb5645f..62391da8f8 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -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# #) diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index e586a92e44..7bc9c161a5 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index fee96f31f8..38c5327570 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -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 diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs index 156a76d9ed..cf08320a11 100644 --- a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs @@ -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## diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs index aad7d903ff..011330cf5e 100644 --- a/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs +++ b/libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs @@ -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# diff --git a/libraries/ghc-bignum/src/GHC/Num/Integer.hs b/libraries/ghc-bignum/src/GHC/Num/Integer.hs index e9e38c9afd..82c109c5f7 100644 --- a/libraries/ghc-bignum/src/GHC/Num/Integer.hs +++ b/libraries/ghc-bignum/src/GHC/Num/Integer.hs @@ -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#) diff --git a/libraries/ghc-bignum/src/GHC/Num/Natural.hs b/libraries/ghc-bignum/src/GHC/Num/Natural.hs index 1adb02181d..574f8f04b3 100644 --- a/libraries/ghc-bignum/src/GHC/Num/Natural.hs +++ b/libraries/ghc-bignum/src/GHC/Num/Natural.hs @@ -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## diff --git a/libraries/ghc-bignum/src/GHC/Num/Primitives.hs b/libraries/ghc-bignum/src/GHC/Num/Primitives.hs index 2c1a0b6955..358c83b3be 100644 --- a/libraries/ghc-bignum/src/GHC/Num/Primitives.hs +++ b/libraries/ghc-bignum/src/GHC/Num/Primitives.hs @@ -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 diff --git a/libraries/ghc-prim/GHC/Prim/Exception.hs b/libraries/ghc-prim/GHC/Prim/Exception.hs new file mode 100644 index 0000000000..36889dc1e3 --- /dev/null +++ b/libraries/ghc-prim/GHC/Prim/Exception.hs @@ -0,0 +1,52 @@ +{-# 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) diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal index 4ac3054b05..625773b4fe 100644 --- a/libraries/ghc-prim/ghc-prim.cabal +++ b/libraries/ghc-prim/ghc-prim.cabal @@ -47,6 +47,7 @@ Library GHC.Magic GHC.Prim.Ext GHC.Prim.Panic + GHC.Prim.Exception GHC.PrimopWrappers GHC.Tuple GHC.Types diff --git a/rts/Exception.cmm b/rts/Exception.cmm index 587708e47e..3216edbcc4 100644 --- a/rts/Exception.cmm +++ b/rts/Exception.cmm @@ -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); +} + +stg_raiseOverflowzh () +{ + jump stg_raisezh(base_GHCziExceptionziType_overflowException_closure); +} + /* The FFI doesn't support variadic C functions so we can't directly expose * `barf` to Haskell code. Instead we define "stg_panic#" and it is exposed to * Haskell programs in GHC.Prim.Panic. diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 1bd30b3af0..1fd746edf6 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -31,9 +31,6 @@ 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; @@ -2601,19 +2598,3 @@ 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); -} diff --git a/testsuite/tests/numeric/should_run/T18359.hs b/testsuite/tests/numeric/should_run/T18359.hs new file mode 100644 index 0000000000..16deba75dd --- /dev/null +++ b/testsuite/tests/numeric/should_run/T18359.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Num.BigNat +import GHC.Num.Primitives +import GHC.Prim.Exception +import GHC.Exts +import Control.Exception + +main :: IO () +main = do + foo `catch` \DivideByZero -> putStrLn "Caught DivideByZero exception in foo" + foo2 `catch` \DivideByZero -> putStrLn "Caught DivideByZero exception in foo2" + +foo2 = case raiseDivZero of + I# _ -> print "NOPE" + +foo :: IO () +foo = print (W# (bigNatRemWord# (bigNatOne void#) 0##)) diff --git a/testsuite/tests/numeric/should_run/T18359.stdout b/testsuite/tests/numeric/should_run/T18359.stdout new file mode 100644 index 0000000000..65d3805d2e --- /dev/null +++ b/testsuite/tests/numeric/should_run/T18359.stdout @@ -0,0 +1,2 @@ +Caught DivideByZero exception in foo +Caught DivideByZero exception in foo2 diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T index 71e81daaab..ce44e15729 100644 --- a/testsuite/tests/numeric/should_run/all.T +++ b/testsuite/tests/numeric/should_run/all.T @@ -69,3 +69,4 @@ test('T12136', normal, compile_and_run, ['']) test('T15301', normal, compile_and_run, ['-O2']) test('T497', normal, compile_and_run, ['-O']) test('T17303', normal, compile_and_run, ['']) +test('T18359', normal, compile_and_run, ['']) diff --git a/testsuite/tests/primops/should_run/T14664.hs b/testsuite/tests/primops/should_run/T14664.hs index 4c29d327d0..a7b8308024 100644 --- a/testsuite/tests/primops/should_run/T14664.hs +++ b/testsuite/tests/primops/should_run/T14664.hs @@ -3,6 +3,7 @@ module Main where import GHC.Exts +import GHC.Prim.Exception import Control.Exception main :: IO () @@ -12,6 +13,6 @@ main = do printE :: ArithException -> IO () printE = print - catch (raiseUnderflow# void#) printE - catch (raiseOverflow# void#) printE - catch (raiseDivZero# void#) printE + catch raiseUnderflow printE + catch raiseOverflow printE + catch raiseDivZero printE |