GHC hPutBuf bug example for spurious empty write("") syscalls -- repro for GHC bug #13246 and fix https://ghc.haskell.org/trac/ghc/ticket/13246

ghc-bug-13246-fix.hs

{-# LANGUAGE RecordWildCards #-}

module Main where

import Foreign
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc (allocaBytes)
-- import System.Directory
import System.IO
import Data.IORef
import Data.Typeable
import Control.Concurrent.MVar
import Control.Monad (when)
import qualified Data.ByteString.Char8 as BS8

import GHC.IO.Buffer
import GHC.IO.FD
import GHC.IO.Handle.Types
import GHC.IO.Handle.Internals hiding (debugIO, wantWritableHandle)
import qualified GHC.IO.BufferedIO as Buffered
import qualified GHC.IO.Device as RawIO

c_DEBUG_DUMP = True

debugIO :: String -> IO ()
debugIO s
 | c_DEBUG_DUMP = BS8.hPutStrLn System.IO.stderr (BS8.pack s)
 -- | c_DEBUG_DUMP
 --    = do _ <- withCStringLen (s ++ "\n") $
 --                  \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)
 --         return ()
 | otherwise = return ()

copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
copyToRawBuffer raw off ptr bytes =
 withRawBuffer raw $ \praw ->
   do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
      return ()

foreign import ccall unsafe "memcpy"
   memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())


writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
writeChunk h_@Handle__{..} ptr bytes
  | Just fd <- cast haDevice  =  RawIO.write (fd::FD) ptr bytes
  | otherwise = error "Todo: hPutBuf"


writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
writeChunkNonBlocking h_@Handle__{..} ptr bytes
  | Just fd <- cast haDevice  =  RawIO.writeNonBlocking (fd::FD) ptr bytes
  | otherwise = error "Todo: hPutBuf"

bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
bufWrite h_@Handle__{..} ptr count can_block =
  seq count $ do  -- strictness hack
  old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
     <- readIORef haByteBuffer

  -- TODO: Possible optimisation:
  --       If we know that `w + count > size`, we should write both the
  --       handle buffer and the `ptr` in a single `writev()` syscall.

  -- Need to buffer and enough room in handle buffer?
  -- There's no need to buffer if the data to be written is larger than
  -- the handle buffer (`count >= size`).
  if (count < size && count <= size - w)
        -- We need to buffer and there's enough room in the buffer:
        -- just copy the data in and update bufR.
        then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
                copyToRawBuffer old_raw w ptr count
                let written_buf = old_buf{ bufR = w + count }
                -- If the write filled the buffer completely, we need to flush,
                -- to maintain the "INVARIANTS on Buffers" from
                -- GHC.IO.Buffer.checkBuffer: "a write buffer is never full".
                if (size - w == count)
                  then do
                    debugIO "hPutBuf: flushing full buffer after writing"
                    flushed_buf <- Buffered.flushWriteBuffer haDevice written_buf
                            -- TODO: we should do a non-blocking flush here
                    writeIORef haByteBuffer flushed_buf
                  else do
                    writeIORef haByteBuffer written_buf
                return count

        -- else, we have to flush any existing handle buffer data
        -- and can then write out `ptr` directly.
        else do -- No point flushing when there's nothing in the buffer.
                when (w > 0) $ do
                  debugIO "hPutBuf: flushing first"
                  old_buf' <- Buffered.flushWriteBuffer haDevice old_buf
                          -- TODO: we should do a non-blocking flush here
                  writeIORef haByteBuffer old_buf'
                -- if we can fit in the buffer, then just loop
                if count < size
                   then bufWrite h_ ptr count can_block
                   else if can_block
                           then do writeChunk h_ (castPtr ptr) count
                                   return count
                           else writeChunkNonBlocking h_ (castPtr ptr) count

wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle fun h@(FileHandle _ m) act
  = wantWritableHandle' fun h m act
wantWritableHandle fun h@(DuplexHandle _ _ m) act
  = wantWritableHandle' fun h m act

wantWritableHandle'
        :: String -> Handle -> MVar Handle__
        -> (Handle__ -> IO a) -> IO a
wantWritableHandle' fun h m act
   = withHandle_' fun h m (checkWritableHandle act)

checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkWritableHandle act h_@Handle__{..}
  = case haType of
      ClosedHandle         -> ioe_closedHandle
      SemiClosedHandle     -> ioe_semiclosedHandle
      ReadHandle           -> ioe_notWritable
      ReadWriteHandle      -> do
        buf <- readIORef haCharBuffer
        when (not (isWriteBuffer buf)) $ do
           flushCharReadBuffer h_
           flushByteReadBuffer h_
           buf <- readIORef haCharBuffer
           writeIORef haCharBuffer buf{ bufState = WriteBuffer }
           buf <- readIORef haByteBuffer
           buf' <- Buffered.emptyWriteBuffer haDevice buf
           writeIORef haByteBuffer buf'
        act h_
      _other               -> act h_

hPutBuf :: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> IO ()
hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
                         return ()

hPutBuf':: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> Bool                         -- allow blocking?
        -> IO Int
hPutBuf' handle ptr count can_block
  | count == 0 = return 0
  | count <  0 = error "hPutBuf': negative count"
  | otherwise =
    wantWritableHandle "hPutBuf" handle $
      \ h_@Handle__{..} -> do
          debugIO ("hPutBuf count=" ++ show count)

          r <- bufWrite h_ (castPtr ptr) count can_block

          -- we must flush if this Handle is set to NoBuffering.  If
          -- it is set to LineBuffering, be conservative and flush
          -- anyway (we didn't check for newlines in the data).
          case haBufferMode of
             BlockBuffering _      -> do return ()
             _line_or_no_buffering -> do flushWriteBuffer h_
          return r

-- main = copyFile "testfile" "testfile2"
-- main = copyFileWithMetadata "testfile" "testfile2"
main = do
  withBinaryFile "testfile2" WriteMode $ \ hTo -> do
    let bufferSize = 8096 -- write("") is gone when we use 8095 here
    allocaBytes bufferSize $ \buffer -> do
      -- hPutBuf hTo buffer bufferSize
      -- hPutBuf hTo buffer bufferSize
      Main.hPutBuf hTo buffer bufferSize

ghc-bug-13246-repro.hs

{-# LANGUAGE RecordWildCards #-}

module Main where

import Foreign
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc (allocaBytes)
-- import System.Directory
import System.IO
import Data.IORef
import Data.Typeable
import Control.Concurrent.MVar
import Control.Monad (when)
import qualified Data.ByteString.Char8 as BS8

import GHC.IO.Buffer
import GHC.IO.FD
import GHC.IO.Handle.Types
import GHC.IO.Handle.Internals hiding (debugIO, wantWritableHandle)
import qualified GHC.IO.BufferedIO as Buffered
import qualified GHC.IO.Device as RawIO

c_DEBUG_DUMP = True

debugIO :: String -> IO ()
debugIO s
 | c_DEBUG_DUMP = BS8.hPutStrLn System.IO.stderr (BS8.pack s)
 -- | c_DEBUG_DUMP
 --    = do _ <- withCStringLen (s ++ "\n") $
 --                  \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)
 --         return ()
 | otherwise = return ()

copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
copyToRawBuffer raw off ptr bytes =
 withRawBuffer raw $ \praw ->
   do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
      return ()

foreign import ccall unsafe "memcpy"
   memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())


writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
writeChunk h_@Handle__{..} ptr bytes
  | Just fd <- cast haDevice  =  RawIO.write (fd::FD) ptr bytes
  | otherwise = error "Todo: hPutBuf"


writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
writeChunkNonBlocking h_@Handle__{..} ptr bytes
  | Just fd <- cast haDevice  =  RawIO.writeNonBlocking (fd::FD) ptr bytes
  | otherwise = error "Todo: hPutBuf"

bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
bufWrite h_@Handle__{..} ptr count can_block =
  seq count $ do  -- strictness hack
  old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
     <- readIORef haByteBuffer

  -- enough room in handle buffer?
  if (size - w > count)
        -- There's enough room in the buffer:
        -- just copy the data in and update bufR.
        then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
                copyToRawBuffer old_raw w ptr count
                writeIORef haByteBuffer old_buf{ bufR = w + count }
                return count

        -- else, we have to flush
        else do debugIO "hPutBuf: flushing first"
                old_buf' <- Buffered.flushWriteBuffer haDevice old_buf
                        -- TODO: we should do a non-blocking flush here
                writeIORef haByteBuffer old_buf'
                -- if we can fit in the buffer, then just loop
                if count < size
                   then bufWrite h_ ptr count can_block
                   else if can_block
                           then do writeChunk h_ (castPtr ptr) count
                                   return count
                           else writeChunkNonBlocking h_ (castPtr ptr) count

wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantWritableHandle fun h@(FileHandle _ m) act
  = wantWritableHandle' fun h m act
wantWritableHandle fun h@(DuplexHandle _ _ m) act
  = wantWritableHandle' fun h m act

wantWritableHandle'
        :: String -> Handle -> MVar Handle__
        -> (Handle__ -> IO a) -> IO a
wantWritableHandle' fun h m act
   = withHandle_' fun h m (checkWritableHandle act)

checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkWritableHandle act h_@Handle__{..}
  = case haType of
      ClosedHandle         -> ioe_closedHandle
      SemiClosedHandle     -> ioe_semiclosedHandle
      ReadHandle           -> ioe_notWritable
      ReadWriteHandle      -> do
        buf <- readIORef haCharBuffer
        when (not (isWriteBuffer buf)) $ do
           flushCharReadBuffer h_
           flushByteReadBuffer h_
           buf <- readIORef haCharBuffer
           writeIORef haCharBuffer buf{ bufState = WriteBuffer }
           buf <- readIORef haByteBuffer
           buf' <- Buffered.emptyWriteBuffer haDevice buf
           writeIORef haByteBuffer buf'
        act h_
      _other               -> act h_

hPutBuf :: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> IO ()
hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
                         return ()

hPutBuf':: Handle                       -- handle to write to
        -> Ptr a                        -- address of buffer
        -> Int                          -- number of bytes of data in buffer
        -> Bool                         -- allow blocking?
        -> IO Int
hPutBuf' handle ptr count can_block
  | count == 0 = return 0
  | count <  0 = error "hPutBuf': negative count"
  | otherwise =
    wantWritableHandle "hPutBuf" handle $
      \ h_@Handle__{..} -> do
          debugIO ("hPutBuf count=" ++ show count)

          r <- bufWrite h_ (castPtr ptr) count can_block

          -- we must flush if this Handle is set to NoBuffering.  If
          -- it is set to LineBuffering, be conservative and flush
          -- anyway (we didn't check for newlines in the data).
          case haBufferMode of
             BlockBuffering _      -> do return ()
             _line_or_no_buffering -> do flushWriteBuffer h_
          return r

-- main = copyFile "testfile" "testfile2"
-- main = copyFileWithMetadata "testfile" "testfile2"
main = do
  withBinaryFile "testfile2" WriteMode $ \ hTo -> do
    let bufferSize = 8096 -- write("") is gone when we use 8095 here
    allocaBytes bufferSize $ \buffer -> do
      -- hPutBuf hTo buffer bufferSize
      -- hPutBuf hTo buffer bufferSize
      Main.hPutBuf hTo buffer bufferSize