[commit: ghc] master: base: Make raw buffer IO operations more strict (cc2e3ec)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/cc2e3ec06ce5ac979ff2ecf453ad85b0e5ff326d/ghc

>---------------------------------------------------------------

commit cc2e3ec06ce5ac979ff2ecf453ad85b0e5ff326d
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Tue Dec 13 14:49:20 2016 -0500

    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


>---------------------------------------------------------------

cc2e3ec06ce5ac979ff2ecf453ad85b0e5ff326d
 libraries/base/GHC/IO/FD.hs | 20 ++++++++++----------
 libraries/base/changelog.md |  2 ++
 2 files changed, 12 insertions(+), 10 deletions(-)

diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs
index 381f39a..82ba628 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 5983747..5039b64 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