[Git][ghc/ghc][master] 2 commits: ghc-bignum: fix division by zero (#18359)
Marge Bot
gitlab at gitlab.haskell.org
Sat Jun 27 15:56:08 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
a403eb91 by Sylvain Henry at 2020-06-27T11:55:59-04:00
ghc-bignum: fix division by zero (#18359)
- - - - -
1b3d13b6 by Sylvain Henry at 2020-06-27T11:55:59-04:00
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.
- - - - -
17 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-bignum/src/GHC/Num/BigNat.hs
- libraries/ghc-bignum/src/GHC/Num/BigNat/Check.hs
- libraries/ghc-bignum/src/GHC/Num/Integer.hs
- libraries/ghc-bignum/src/GHC/Num/Natural.hs
- libraries/ghc-bignum/src/GHC/Num/Primitives.hs
- + libraries/ghc-prim/GHC/Prim/Exception.hs
- libraries/ghc-prim/ghc-prim.cabal
- rts/Exception.cmm
- rts/PrimOps.cmm
- + testsuite/tests/numeric/should_run/T18359.hs
- + testsuite/tests/numeric/should_run/T18359.stdout
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/primops/should_run/T14664.hs
Changes:
=====================================
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,
=====================================
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# #)
=====================================
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
=====================================
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
=====================================
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 = 1## `remWord#` 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##
=====================================
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#
=====================================
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#)
=====================================
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##
=====================================
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
=====================================
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)
=====================================
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
=====================================
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.
=====================================
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);
-}
=====================================
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##))
=====================================
testsuite/tests/numeric/should_run/T18359.stdout
=====================================
@@ -0,0 +1,2 @@
+Caught DivideByZero exception in foo
+Caught DivideByZero exception in foo2
=====================================
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, [''])
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ce987865d7594ecbcb3d27435eef773e95b2db85...1b3d13b68c95ef9bbeca4437028531d184abcbea
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ce987865d7594ecbcb3d27435eef773e95b2db85...1b3d13b68c95ef9bbeca4437028531d184abcbea
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/20200627/636d0dd6/attachment-0001.html>
More information about the ghc-commits
mailing list