diff options
author | Ben Gamari <ben@smart-cactus.org> | 2019-10-29 09:46:10 -0400 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-10-31 19:02:32 -0400 |
commit | 97b6f7a3969ad128f94e872f7389ccc790334d9c (patch) | |
tree | 24886bc56419929856abf68203e4f8b9754fd0c8 | |
parent | 337e9b5adb58cf1a8c4daf76ac286126f2871ad7 (diff) | |
download | haskell-97b6f7a3969ad128f94e872f7389ccc790334d9c.tar.gz |
base: Clamp IO operation size to 2GB on Darwin
As reported in #17414, Darwin throws EINVAL in response to large
writes.
-rw-r--r-- | libraries/base/GHC/IO/FD.hs | 21 |
1 files changed, 17 insertions, 4 deletions
diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs index 2d3736a9dc..a889601be9 100644 --- a/libraries/base/GHC/IO/FD.hs +++ b/libraries/base/GHC/IO/FD.hs @@ -67,6 +67,17 @@ import System.Posix.Types c_DEBUG_DUMP :: Bool c_DEBUG_DUMP = False +-- Darwin limits the length of writes to 2GB. See +-- #17414. +clampWriteSize, clampReadSize :: Int -> Int +#if defined(darwin_HOST_OS) +clampWriteSize = min 0x7fffffff +clampReadSize = min 0x7fffffff +#else +clampWriteSize = id +clampReadSize = id +#endif + -- ----------------------------------------------------------------------------- -- The file-descriptor IO device @@ -430,13 +441,14 @@ setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw) fdRead :: FD -> Ptr Word8 -> Int -> IO Int fdRead fd ptr bytes - = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes) + = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 + (fromIntegral $ clampReadSize bytes) ; return (fromIntegral r) } fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int) fdReadNonBlocking fd ptr bytes = do r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr - 0 (fromIntegral bytes) + 0 (fromIntegral $ clampReadSize bytes) case fromIntegral r of (-1) -> return (Nothing) n -> return (Just n) @@ -444,7 +456,8 @@ fdReadNonBlocking fd ptr bytes = do fdWrite :: FD -> Ptr Word8 -> Int -> IO () fdWrite fd ptr bytes = do - res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes) + res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 + (fromIntegral $ clampWriteSize bytes) let res' = fromIntegral res if res' < bytes then fdWrite fd (ptr `plusPtr` res') (bytes - res') @@ -454,7 +467,7 @@ fdWrite fd ptr bytes = do fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int fdWriteNonBlocking fd ptr bytes = do res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0 - (fromIntegral bytes) + (fromIntegral $ clampWriteSize bytes) return (fromIntegral res) -- ----------------------------------------------------------------------------- |