warp: cache a ForeignPtr in WriteBuffer, drop per-flush allocation

warp/Network/Wai/Handler/Warp/Buffer.hs

@@ -4,6 +4,7 @@ module Network.Wai.Handler.Warp.Buffer (
     freeBuffer,
     toBuilderBuffer,
     bufferIO,
+    rawBufferIO,
 ) where
 
 import Data.IORef (IORef, readIORef)
@@ -23,9 +24,11 @@ import Network.Wai.Handler.Warp.Types
 createWriteBuffer :: BufSize -> IO WriteBuffer
 createWriteBuffer size = do
     bytes <- allocateBuffer size
+    fptr <- newForeignPtr_ bytes
     return
         WriteBuffer
             { bufBuffer = bytes
+            , bufFPtr = fptr
             , bufSize = size
             , bufFree = freeBuffer bytes
             }
@@ -48,12 +51,19 @@ freeBuffer = free
 toBuilderBuffer :: IORef WriteBuffer -> IO B.Buffer
 toBuilderBuffer writeBufferRef = do
     writeBuffer <- readIORef writeBufferRef
-    let ptr = bufBuffer writeBuffer
+    let fptr = bufFPtr writeBuffer
+        ptr = bufBuffer writeBuffer
         size = bufSize writeBuffer
-    fptr <- newForeignPtr_ ptr
     return $ B.Buffer fptr ptr ptr (ptr `plusPtr` size)
 
-bufferIO :: Buffer -> Int -> (ByteString -> IO ()) -> IO ()
-bufferIO ptr siz io = do
+-- | Slice the given number of bytes out of a 'WriteBuffer' using its
+-- cached 'ForeignPtr', without allocating a fresh wrapper.
+bufferIO :: WriteBuffer -> Int -> (ByteString -> IO ()) -> IO ()
+bufferIO writeBuffer siz io = io $ PS (bufFPtr writeBuffer) 0 siz
+
+-- | Like 'bufferIO' for callers that only have a raw pointer.
+-- This allocates a fresh 'ForeignPtr' wrapper on every call.
+rawBufferIO :: Buffer -> Int -> (ByteString -> IO ()) -> IO ()
+rawBufferIO ptr siz io = do
     fptr <- newForeignPtr_ ptr
     io $ PS fptr 0 siz

warp/Network/Wai/Handler/Warp/IO.hs

@@ -19,7 +19,7 @@ toBufIOWith maxRspBufSize writeBufferRef io builder = do
         let buf = bufBuffer writeBuffer
             size = bufSize writeBuffer
         (len, signal) <- writer buf size
-        bufferIO buf len io
+        bufferIO writeBuffer len io
         let totalBytesSent = toInteger len + bytesSent
         case signal of
             Done -> return totalBytesSent

warp/Network/Wai/Handler/Warp/SendFile.hs

@@ -72,7 +72,7 @@ packHeader buf siz send hook (bs : bss) n
         let dst = buf `plusPtr` n
             (bs1, bs2) = BS.splitAt room bs
         void $ copy dst bs1
-        bufferIO buf siz send
+        rawBufferIO buf siz send
         hook
         packHeader buf siz send hook (bs2 : bss) 0
   where
@@ -98,7 +98,7 @@ readSendFile buf siz send fid off0 len0 hook headers = do
     IO.withBinaryFile path IO.ReadMode $ \h -> do
         IO.hSeek h IO.AbsoluteSeek off0
         n <- IO.hGetBufSome h buf' (mini room len0)
-        bufferIO buf (hn + n) send
+        rawBufferIO buf (hn + n) send
         hook
         let n' = fromIntegral n
         fptr <- newForeignPtr_ buf
@@ -123,7 +123,7 @@ readSendFile buf siz send fid off0 len0 hook headers =
         let room = siz - hn
             buf' = buf `plusPtr` hn
         n <- positionRead fd buf' (mini room len0) off0
-        bufferIO buf (hn + n) send
+        rawBufferIO buf (hn + n) send
         hook
         let n' = fromIntegral n
         loop fd (len0 - n') (off0 + n')
@@ -139,7 +139,7 @@ readSendFile buf siz send fid off0 len0 hook headers =
         | len <= 0 = return ()
         | otherwise = do
             n <- positionRead fd buf (mini siz len) off
-            bufferIO buf n send
+            rawBufferIO buf n send
             let n' = fromIntegral n
             hook
             loop fd (len - n') (off + n')

warp/Network/Wai/Handler/Warp/Types.hs

@@ -10,6 +10,7 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 #ifdef MIN_VERSION_crypton_x509
 import Data.X509
 #endif
+import Foreign.ForeignPtr (ForeignPtr)
 import Network.Socket (SockAddr)
 import Network.Socket.BufferPool
 import System.Posix.Types (Fd)
@@ -95,6 +96,10 @@ type SendFile = FileId -> Integer -> Integer -> IO () -> [ByteString] -> IO ()
 -- containing bytes and a way to free the buffer.
 data WriteBuffer = WriteBuffer
     { bufBuffer :: Buffer
+    , bufFPtr :: ForeignPtr Word8
+    -- ^ A finalizer-free 'ForeignPtr' wrapping 'bufBuffer', cached so that
+    -- flushing does not allocate a fresh wrapper on every call. The buffer
+    -- is freed via 'bufFree', never via this 'ForeignPtr'.
     , bufSize :: !BufSize
     -- ^ The size of the write buffer.
     , bufFree :: IO ()