Commit cc2e3ec0 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari
Browse files

base: Make raw buffer IO operations more strict

Ticket #9696 reported that `readRawBufferPtr` and `writeRawBufferPtr`
allocated unnecessarily. The binding is question was,
```
let {
  buf_s4VD [Dmd=<L,U(U)>] :: GHC.Ptr.Ptr GHC.Word.Word8
  [LclId, Unf=OtherCon []] =
      NO_CCS GHC.Ptr.Ptr! [ds1_s4Vy];
} in
  case
      GHC.IO.FD.$wreadRawBufferPtr
          Main.main5
          0#
          0#
          buf_s4VD
          Main.main4
          Main.main3
          GHC.Prim.void#
  of ...
```
The problem was that GHC apparently couldn't tell that
`readRawBufferPtr` would always demand the buffer. Here we simple add
bang patterns on all of the small arguments of these functions to ensure
that worker/wrappers can eliminate these allocations.

Test Plan: Look at STG produced by testcase in #9696, verify no
allocations

Reviewers: austin, hvr, simonmar

Reviewed By: simonmar

Subscribers: RyanGlScott, simonmar, thomie

Differential Revision: https://phabricator.haskell.org/D2813

GHC Trac Issues: #9696
parent f723ba2f
...@@ -500,7 +500,7 @@ indicates that there's no data, we call threadWaitRead. ...@@ -500,7 +500,7 @@ indicates that there's no data, we call threadWaitRead.
-} -}
readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtr loc !fd buf off len readRawBufferPtr loc !fd !buf !off !len
| isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
| otherwise = do r <- throwErrnoIfMinus1 loc | otherwise = do r <- throwErrnoIfMinus1 loc
(unsafe_fdReady (fdFD fd) 0 0 0) (unsafe_fdReady (fdFD fd) 0 0 0)
...@@ -517,7 +517,7 @@ readRawBufferPtr loc !fd buf off len ...@@ -517,7 +517,7 @@ readRawBufferPtr loc !fd buf off len
-- return: -1 indicates EOF, >=0 is bytes read -- return: -1 indicates EOF, >=0 is bytes read
readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
readRawBufferPtrNoBlock loc !fd buf off len readRawBufferPtrNoBlock loc !fd !buf !off !len
| isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
| otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0 | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
if r /= 0 then safe_read if r /= 0 then safe_read
...@@ -533,7 +533,7 @@ readRawBufferPtrNoBlock loc !fd buf off len ...@@ -533,7 +533,7 @@ readRawBufferPtrNoBlock loc !fd buf off len
safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len) safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len)
writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr loc !fd buf off len writeRawBufferPtr loc !fd !buf !off !len
| isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
| otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
if r /= 0 if r /= 0
...@@ -548,7 +548,7 @@ writeRawBufferPtr loc !fd buf off len ...@@ -548,7 +548,7 @@ writeRawBufferPtr loc !fd buf off len
safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len) safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtrNoBlock loc !fd buf off len writeRawBufferPtrNoBlock loc !fd !buf !off !len
| isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
| otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0 | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
if r /= 0 then write if r /= 0 then write
...@@ -571,12 +571,12 @@ foreign import ccall unsafe "fdReady" ...@@ -571,12 +571,12 @@ foreign import ccall unsafe "fdReady"
#else /* mingw32_HOST_OS.... */ #else /* mingw32_HOST_OS.... */
readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
readRawBufferPtr loc !fd buf off len readRawBufferPtr loc !fd !buf !off !len
| threaded = blockingReadRawBufferPtr loc fd buf off len | threaded = blockingReadRawBufferPtr loc fd buf off len
| otherwise = asyncReadRawBufferPtr loc fd buf off len | otherwise = asyncReadRawBufferPtr loc fd buf off len
writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
writeRawBufferPtr loc !fd buf off len writeRawBufferPtr loc !fd !buf !off !len
| threaded = blockingWriteRawBufferPtr loc fd buf off len | threaded = blockingWriteRawBufferPtr loc fd buf off len
| otherwise = asyncWriteRawBufferPtr loc fd buf off len | otherwise = asyncWriteRawBufferPtr loc fd buf off len
...@@ -589,7 +589,7 @@ writeRawBufferPtrNoBlock = writeRawBufferPtr ...@@ -589,7 +589,7 @@ writeRawBufferPtrNoBlock = writeRawBufferPtr
-- Async versions of the read/write primitives, for the non-threaded RTS -- Async versions of the read/write primitives, for the non-threaded RTS
asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncReadRawBufferPtr loc !fd buf off len = do asyncReadRawBufferPtr loc !fd !buf !off !len = do
(l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
(fromIntegral len) (buf `plusPtr` off) (fromIntegral len) (buf `plusPtr` off)
if l == (-1) if l == (-1)
...@@ -598,7 +598,7 @@ asyncReadRawBufferPtr loc !fd buf off len = do ...@@ -598,7 +598,7 @@ asyncReadRawBufferPtr loc !fd buf off len = do
else return (fromIntegral l) else return (fromIntegral l)
asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
asyncWriteRawBufferPtr loc !fd buf off len = do asyncWriteRawBufferPtr loc !fd !buf !off !len = do
(l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd) (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
(fromIntegral len) (buf `plusPtr` off) (fromIntegral len) (buf `plusPtr` off)
if l == (-1) if l == (-1)
...@@ -609,14 +609,14 @@ asyncWriteRawBufferPtr loc !fd buf off len = do ...@@ -609,14 +609,14 @@ asyncWriteRawBufferPtr loc !fd buf off len = do
-- Blocking versions of the read/write primitives, for the threaded RTS -- Blocking versions of the read/write primitives, for the threaded RTS
blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingReadRawBufferPtr loc fd buf off len blockingReadRawBufferPtr loc !fd !buf !off !len
= throwErrnoIfMinus1Retry loc $ = throwErrnoIfMinus1Retry loc $
if fdIsSocket fd if fdIsSocket fd
then c_safe_recv (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0 then c_safe_recv (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0
else c_safe_read (fdFD fd) (buf `plusPtr` off) (fromIntegral len) else c_safe_read (fdFD fd) (buf `plusPtr` off) (fromIntegral len)
blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
blockingWriteRawBufferPtr loc fd buf off len blockingWriteRawBufferPtr loc !fd !buf !off !len
= throwErrnoIfMinus1Retry loc $ = throwErrnoIfMinus1Retry loc $
if fdIsSocket fd if fdIsSocket fd
then c_safe_send (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0 then c_safe_send (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0
......
...@@ -30,6 +30,8 @@ ...@@ -30,6 +30,8 @@
* Added `Eq1`, `Ord1`, `Read1` and `Show1` instances for `NonEmpty`. * Added `Eq1`, `Ord1`, `Read1` and `Show1` instances for `NonEmpty`.
* Raw buffer operations in `GHC.IO.FD` are now strict in the buffer, offset, and length operations (#9696)
## 4.9.0.0 *May 2016* ## 4.9.0.0 *May 2016*
* Bundled with GHC 8.0 * Bundled with GHC 8.0
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment