diff options
| author | Simon Marlow <marlowsd@gmail.com> | 2012-10-24 16:57:39 +0100 |
|---|---|---|
| committer | Simon Marlow <marlowsd@gmail.com> | 2012-10-25 13:30:57 +0100 |
| commit | 6f847e97b37e552232be1e72b7f5ec493120a9d3 (patch) | |
| tree | c9360c9df4c18e88aee44facfd610e473672dc6c | |
| parent | 3c083fae0833ba222dc5c36cb04f2a9d88e39c86 (diff) | |
| download | haskell-6f847e97b37e552232be1e72b7f5ec493120a9d3.tar.gz | |
Fix #7233: avoid overflow in divInt64#
| -rw-r--r-- | libraries/base/GHC/Int.hs | 24 |
1 files changed, 16 insertions, 8 deletions
diff --git a/libraries/base/GHC/Int.hs b/libraries/base/GHC/Int.hs index fc1ba492b3..43125f3fa3 100644 --- a/libraries/base/GHC/Int.hs +++ b/libraries/base/GHC/Int.hs @@ -633,18 +633,26 @@ instance Integral Int64 where divInt64#, modInt64# :: Int64# -> Int64# -> Int64# + +-- Define div in terms of quot, being careful to avoid overflow (#7233) x# `divInt64#` y# - | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#) - = ((x# `minusInt64#` y#) `minusInt64#` intToInt64# 1#) `quotInt64#` y# - | (x# `ltInt64#` intToInt64# 0#) && (y# `gtInt64#` intToInt64# 0#) - = ((x# `minusInt64#` y#) `plusInt64#` intToInt64# 1#) `quotInt64#` y# - | otherwise = x# `quotInt64#` y# + | (x# `gtInt64#` zero) && (y# `ltInt64#` zero) + = ((x# `minusInt64#` one) `quotInt64#` y#) `minusInt64#` one + | (x# `ltInt64#` zero) && (y# `gtInt64#` zero) + = ((x# `plusInt64#` one) `quotInt64#` y#) `minusInt64#` one + | otherwise + = x# `quotInt64#` y# + where + !zero = intToInt64# 0# + !one = intToInt64# 1# + x# `modInt64#` y# - | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#) || - (x# `ltInt64#` intToInt64# 0#) && (y# `gtInt64#` intToInt64# 0#) - = if r# `neInt64#` intToInt64# 0# then r# `plusInt64#` y# else intToInt64# 0# + | (x# `gtInt64#` zero) && (y# `ltInt64#` zero) || + (x# `ltInt64#` zero) && (y# `gtInt64#` zero) + = if r# `neInt64#` zero then r# `plusInt64#` y# else zero | otherwise = r# where + !zero = intToInt64# 0# !r# = x# `remInt64#` y# instance Read Int64 where |