diff options
Diffstat (limited to 'libraries/ghc-bignum/src/GHC/Num')
| -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 |
5 files changed, 111 insertions, 53 deletions
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 |