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

2 files changed, 12 insertions, 10 deletions

diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs
index 381f39aabe..82ba628690 100644
--- a/libraries/base/GHC/IO/FD.hs
+++ b/libraries/base/GHC/IO/FD.hs
@@ -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
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 5983747a96..5039b64e02 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -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