@@ -128,8 +128,10 @@ hPutStr h t = do
128128 let str = stream t
129129 case buffer_mode of
130130 (NoBuffering, _) -> hPutChars h str
131− (LineBuffering, buf) -> writeBlocks h True nl buf str
132− (BlockBuffering _, buf) -> writeBlocks h False nl buf str
131+ (LineBuffering, buf) -> writeLines h nl buf str
132+ (BlockBuffering _, buf)
133+ | nl == CRLF -> writeBlocksCRLF h buf str
134+ | otherwise -> writeBlocksRaw h buf str
133135
134136hPutChars :: Handle -> Stream Char -> IO ()
135137hPutChars h (Stream next0 s0 _len) = loop s0
@@ -139,12 +141,18 @@ hPutChars h (Stream next0 s0 _len) = loop s0
139141 Skip s' -> loop s'
140142 Yield x s' -> hPutChar h x >> loop s'
141143
142−-- This function is largely lifted from GHC.IO.Handle.Text, but
143−-- adapted to a coinductive stream of data instead of an inductive
144+-- The following functions are largely lifted from GHC.IO.Handle.Text,
145+-- but adapted to a coinductive stream of data instead of an inductive
144146-- list.
145−writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> Stream Char
146− -> IO ()
147−writeBlocks h lineBuffered nl buf0 (Stream next0 s0 _len) = outer s0 buf0
147+--
148+-- We have several variations of more or less the same code for
149+-- performance reasons. Splitting the original buffered write
150+-- function into line- and block-oriented versions gave us a 2.1x
151+-- performance improvement. Lifting out the raw/cooked newline
152+-- handling gave a few more percent on top.
153+
154+writeLines :: Handle -> Newline -> Buffer CharBufElem -> Stream Char -> IO ()
155+writeLines h nl buf0 (Stream next0 s0 _len) = outer s0 buf0
148156 where
149157 outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
150158 where
@@ -159,9 +167,37 @@ writeBlocks h lineBuffered nl buf0 (Stream next0 s0 _len) = outer s0 buf0
159167 then do n1 <- writeCharBuf raw n '\r'
160168 writeCharBuf raw n1 '\n'
161169 else writeCharBuf raw n x
162− if lineBuffered
163− then commit n' True{-needs flush-} False >>= outer s'
164− else inner s' n'
170+ commit n' True{-needs flush-} False >>= outer s'
171+ | otherwise -> writeCharBuf raw n x >>= inner s'
172+ commit = commitBuffer h raw len
173+
174+writeBlocksCRLF :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
175+writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0
176+ where
177+ outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
178+ where
179+ inner !s !n =
180+ case next0 s of
181+ Done -> commit n False{-no flush-} True{-release-} >> return ()
182+ Skip s' -> inner s' n
183+ Yield x s'
184+ | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s
185+ | x == '\n' -> do n1 <- writeCharBuf raw n '\r'
186+ writeCharBuf raw n1 '\n' >>= inner s'
187+ | otherwise -> writeCharBuf raw n x >>= inner s'
188+ commit = commitBuffer h raw len
189+
190+writeBlocksRaw :: Handle -> Buffer CharBufElem -> Stream Char -> IO ()
191+writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0
192+ where
193+ outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int)
194+ where
195+ inner !s !n =
196+ case next0 s of
197+ Done -> commit n False{-no flush-} True{-release-} >> return ()
198+ Skip s' -> inner s' n
199+ Yield x s'
200+ | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s
165201 | otherwise -> writeCharBuf raw n x >>= inner s'
166202 commit = commitBuffer h raw len
167203
@@ -191,7 +227,7 @@ commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool
191227commitBuffer hdl !raw !sz !count flush release =
192228 wantWritableHandle "commitAndReleaseBuffer" hdl $
193229 commitBuffer' raw sz count flush release
194−{-# NOINLINE commitBuffer #-}
230+{-# INLINE commitBuffer #-}
195231#endif
196232
197233-- | Write a string to a handle, followed by a newline.