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

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.
-}
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
| otherwise = do r <- throwErrnoIfMinus1 loc
(unsafe_fdReady (fdFD fd) 0 0 0)
......@@ -517,7 +517,7 @@ readRawBufferPtr loc !fd buf off len
-- return: -1 indicates EOF, >=0 is bytes read
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
| otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0
if r /= 0 then safe_read
......@@ -533,7 +533,7 @@ readRawBufferPtrNoBlock loc !fd buf 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 loc !fd buf off len
writeRawBufferPtr loc !fd !buf !off !len
| isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
| otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
if r /= 0
......@@ -548,7 +548,7 @@ writeRawBufferPtr loc !fd buf 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 loc !fd buf off len
writeRawBufferPtrNoBlock loc !fd !buf !off !len
| isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
| otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0
if r /= 0 then write
......@@ -571,12 +571,12 @@ foreign import ccall unsafe "fdReady"
#else /* mingw32_HOST_OS.... */
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
| otherwise = asyncReadRawBufferPtr loc fd buf off len
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
| otherwise = asyncWriteRawBufferPtr loc fd buf off len
......@@ -589,7 +589,7 @@ writeRawBufferPtrNoBlock = writeRawBufferPtr
-- Async versions of the read/write primitives, for the non-threaded RTS
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)
(fromIntegral len) (buf `plusPtr` off)
if l == (-1)
......@@ -598,7 +598,7 @@ asyncReadRawBufferPtr loc !fd buf off len = do
else return (fromIntegral l)
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)
(fromIntegral len) (buf `plusPtr` off)
if l == (-1)
......@@ -609,14 +609,14 @@ asyncWriteRawBufferPtr loc !fd buf off len = do
-- Blocking versions of the read/write primitives, for the threaded RTS
blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
blockingReadRawBufferPtr loc fd buf off len
blockingReadRawBufferPtr loc !fd !buf !off !len
= throwErrnoIfMinus1Retry loc $
if fdIsSocket fd
then c_safe_recv (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0
else c_safe_read (fdFD fd) (buf `plusPtr` off) (fromIntegral len)
blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
blockingWriteRawBufferPtr loc fd buf off len
blockingWriteRawBufferPtr loc !fd !buf !off !len
= throwErrnoIfMinus1Retry loc $
if fdIsSocket fd
then c_safe_send (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0
......
......@@ -30,6 +30,8 @@
* 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*
* 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