base: Clamp IO operation size to 2GB on Darwin

As reported in #17414, Darwin throws EINVAL in response to large
writes.

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)
 
 -- -----------------------------------------------------------------------------