From 45d7d136321a88d84f41abb5a568c8258f658dd2 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sun, 28 Apr 2024 13:11:07 -0400 Subject: [PATCH 1/7] Fixed off by one for writeBlocksRaw --- src/Data/Text/IO.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Text/IO.hs b/src/Data/Text/IO.hs index a4e5b2d2a..9fe652549 100644 --- a/src/Data/Text/IO.hs +++ b/src/Data/Text/IO.hs @@ -252,7 +252,7 @@ writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0 Done -> commit n False{-no flush-} True{-release-} >> return () Skip s' -> inner s' n Yield x s' - | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s + | n >= len -> commit n True{-needs flush-} False >>= outer s | otherwise -> writeCharBuf raw n x >>= inner s' commit = commitBuffer h raw len From 047971aa989c49335f155c9e38ae4c4c24494d43 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Tue, 30 Apr 2024 12:02:36 -0400 Subject: [PATCH 2/7] has error! do not pull --- src/Data/Text/IO.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Text/IO.hs b/src/Data/Text/IO.hs index 9fe652549..6a8165718 100644 --- a/src/Data/Text/IO.hs +++ b/src/Data/Text/IO.hs @@ -252,7 +252,7 @@ writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0 Done -> commit n False{-no flush-} True{-release-} >> return () Skip s' -> inner s' n Yield x s' - | n >= len -> commit n True{-needs flush-} False >>= outer s + | n - 10 >= len -> commit n True{-needs flush-} False >>= outer s | otherwise -> writeCharBuf raw n x >>= inner s' commit = commitBuffer h raw len From e780821489a28f04cc7b24ced764a0237343699e Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Tue, 30 Apr 2024 13:02:46 -0400 Subject: [PATCH 3/7] added a bounds assert for writeCharBuff in hPutStr --- src/Data/Text/IO.hs | 60 +++++++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 27 deletions(-) diff --git a/src/Data/Text/IO.hs b/src/Data/Text/IO.hs index 6a8165718..112563ed0 100644 --- a/src/Data/Text/IO.hs +++ b/src/Data/Text/IO.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns, CPP, RecordWildCards, ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NamedFieldPuns #-} -- | -- Module : Data.Text.IO -- Copyright : (c) 2009, 2010 Bryan O'Sullivan, @@ -54,9 +55,9 @@ import qualified Data.Text as T import Data.Text.Internal.Fusion (stream) import Data.Text.Internal.Fusion.Types (Step(..), Stream(..)) import Data.Text.Internal.IO (hGetLineWith, readChunk) -import GHC.IO.Buffer (Buffer(..), BufferState(..), CharBufElem, CharBuffer, - RawCharBuffer, emptyBuffer, isEmptyBuffer, newCharBuffer, - writeCharBuf) +import GHC.IO.Buffer (Buffer(..), BufferState(..), RawCharBuffer, CharBuffer, + emptyBuffer, isEmptyBuffer, newCharBuffer) +import qualified GHC.IO.Buffer import GHC.IO.Exception (IOException(ioe_type), IOErrorType(InappropriateType)) import GHC.IO.Handle.Internals (augmentIOError, hClose_help, wantReadableHandle, wantWritableHandle) @@ -206,55 +207,60 @@ hPutChars h (Stream next0 s0 _len) = loop s0 -- performance improvement. Lifting out the raw/cooked newline -- handling gave a few more percent on top. -writeLines :: Handle -> Newline -> Buffer CharBufElem -> Stream Char -> IO () +writeLines :: Handle -> Newline -> CharBuffer -> Stream Char -> IO () writeLines h nl buf0 (Stream next0 s0 _len) = outer s0 buf0 where - outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int) + outer s1 buf@Buffer{..} = inner s1 (0::Int) where inner !s !n = case next0 s of Done -> commit n False{-no flush-} True{-release-} >> return () Skip s' -> inner s' n Yield x s' - | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s + | n + 1 >= bufSize -> commit n True{-needs flush-} False >>= outer s | x == '\n' -> do n' <- if nl == CRLF - then do n1 <- writeCharBuf raw n '\r' - writeCharBuf raw n1 '\n' - else writeCharBuf raw n x + then do n1 <- writeCharBuf bufRaw bufSize n '\r' + writeCharBuf bufRaw bufSize n1 '\n' + else writeCharBuf bufRaw bufSize n x commit n' True{-needs flush-} False >>= outer s' - | otherwise -> writeCharBuf raw n x >>= inner s' - commit = commitBuffer h raw len + | otherwise -> writeCharBuf bufRaw bufSize n x >>= inner s' + commit = commitBuffer h buf -writeBlocksCRLF :: Handle -> Buffer CharBufElem -> Stream Char -> IO () +writeBlocksCRLF :: Handle -> CharBuffer -> Stream Char -> IO () writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0 where - outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int) + outer s1 buf@Buffer{..} = inner s1 (0::Int) where inner !s !n = case next0 s of Done -> commit n False{-no flush-} True{-release-} >> return () Skip s' -> inner s' n Yield x s' - | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s - | x == '\n' -> do n1 <- writeCharBuf raw n '\r' - writeCharBuf raw n1 '\n' >>= inner s' - | otherwise -> writeCharBuf raw n x >>= inner s' - commit = commitBuffer h raw len + | n + 1 >= bufSize -> commit n True{-needs flush-} False >>= outer s + | x == '\n' -> do n1 <- writeCharBuf bufRaw bufSize n '\r' + writeCharBuf bufRaw bufSize n1 '\n' >>= inner s' + | otherwise -> writeCharBuf bufRaw bufSize n x >>= inner s' + commit = commitBuffer h buf -writeBlocksRaw :: Handle -> Buffer CharBufElem -> Stream Char -> IO () +writeBlocksRaw :: Handle -> CharBuffer -> Stream Char -> IO () writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0 where - outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int) + outer s1 buf@Buffer{..} = inner s1 (0::Int) where inner !s !n = case next0 s of Done -> commit n False{-no flush-} True{-release-} >> return () Skip s' -> inner s' n Yield x s' - | n - 10 >= len -> commit n True{-needs flush-} False >>= outer s - | otherwise -> writeCharBuf raw n x >>= inner s' - commit = commitBuffer h raw len + | n >= bufSize -> commit n True{-needs flush-} False >>= outer s + | otherwise -> writeCharBuf bufRaw bufSize n x >>= inner s' + commit = commitBuffer h buf + +-- | Only modifies the raw buffer and not the buffer attributes +writeCharBuf :: RawCharBuffer -> Int -> Int -> Char -> IO Int +writeCharBuf bufRaw bufSize n c = E.assert (n >= 0 && n < bufSize) $ + GHC.IO.Buffer.writeCharBuf bufRaw n c -- This function is completely lifted from GHC.IO.Handle.Text. getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer) @@ -276,12 +282,12 @@ getSpareBuffer Handle__{haCharBuffer=ref, return (mode, new_buf) --- This function is completely lifted from GHC.IO.Handle.Text. -commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool +-- This function is modified from GHC.Internal.IO.Handle.Text. +commitBuffer :: Handle -> CharBuffer -> Int -> Bool -> Bool -> IO CharBuffer -commitBuffer hdl !raw !sz !count flush release = +commitBuffer hdl Buffer{bufRaw, bufSize} !count flush release = wantWritableHandle "commitAndReleaseBuffer" hdl $ - commitBuffer' raw sz count flush release + commitBuffer' bufRaw bufSize count flush release {-# INLINE commitBuffer #-} -- | Write a string to a handle, followed by a newline. From 75246e8e11cbf78459306ddafb71f22f86879bb3 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Wed, 22 May 2024 22:25:53 -0400 Subject: [PATCH 4/7] combined writeBlocks and writeBlocksCLRF, has same performance --- src/Data/Text/IO.hs | 33 ++++++++++----------------------- 1 file changed, 10 insertions(+), 23 deletions(-) diff --git a/src/Data/Text/IO.hs b/src/Data/Text/IO.hs index 112563ed0..4b076b35a 100644 --- a/src/Data/Text/IO.hs +++ b/src/Data/Text/IO.hs @@ -43,6 +43,7 @@ module Data.Text.IO , putStrLn ) where +import Data.Bool (bool) import Data.Text (Text) import Prelude hiding (appendFile, getContents, getLine, interact, putStr, putStrLn, readFile, writeFile) @@ -185,9 +186,7 @@ hPutStr h t = do case buffer_mode of (NoBuffering, _) -> hPutChars h str (LineBuffering, buf) -> writeLines h nl buf str - (BlockBuffering _, buf) - | nl == CRLF -> writeBlocksCRLF h buf str - | otherwise -> writeBlocksRaw h buf str + (BlockBuffering _, buf) -> writeBlocks (nl == CRLF) h buf str hPutChars :: Handle -> Stream Char -> IO () hPutChars h (Stream next0 s0 _len) = loop s0 @@ -227,8 +226,8 @@ writeLines h nl buf0 (Stream next0 s0 _len) = outer s0 buf0 | otherwise -> writeCharBuf bufRaw bufSize n x >>= inner s' commit = commitBuffer h buf -writeBlocksCRLF :: Handle -> CharBuffer -> Stream Char -> IO () -writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0 +writeBlocks :: Bool -> Handle -> CharBuffer -> Stream Char -> IO () +writeBlocks isCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0 where outer s1 buf@Buffer{..} = inner s1 (0::Int) where @@ -237,24 +236,12 @@ writeBlocksCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0 Done -> commit n False{-no flush-} True{-release-} >> return () Skip s' -> inner s' n Yield x s' - | n + 1 >= bufSize -> commit n True{-needs flush-} False >>= outer s - | x == '\n' -> do n1 <- writeCharBuf bufRaw bufSize n '\r' - writeCharBuf bufRaw bufSize n1 '\n' >>= inner s' - | otherwise -> writeCharBuf bufRaw bufSize n x >>= inner s' - commit = commitBuffer h buf - -writeBlocksRaw :: Handle -> CharBuffer -> Stream Char -> IO () -writeBlocksRaw h buf0 (Stream next0 s0 _len) = outer s0 buf0 - where - outer s1 buf@Buffer{..} = inner s1 (0::Int) - where - inner !s !n = - case next0 s of - Done -> commit n False{-no flush-} True{-release-} >> return () - Skip s' -> inner s' n - Yield x s' - | n >= bufSize -> commit n True{-needs flush-} False >>= outer s - | otherwise -> writeCharBuf bufRaw bufSize n x >>= inner s' + | n >= bufSize + bool 1 0 (isCRLF && x == '\n') -> + commit n True{-needs flush-} False >>= outer s + | isCRLF && x == '\n' -> do + n1 <- writeCharBuf bufRaw bufSize n '\r' + writeCharBuf bufRaw bufSize n1 '\n' >>= inner s' + | otherwise -> writeCharBuf bufRaw bufSize n x >>= inner s' commit = commitBuffer h buf -- | Only modifies the raw buffer and not the buffer attributes From e631f71c4f78b08482b7650820ee1ca714332cea Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Thu, 23 May 2024 15:01:17 -0400 Subject: [PATCH 5/7] fixed overflow --- src/Data/Text/IO.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Text/IO.hs b/src/Data/Text/IO.hs index 4b076b35a..624160f57 100644 --- a/src/Data/Text/IO.hs +++ b/src/Data/Text/IO.hs @@ -236,7 +236,7 @@ writeBlocks isCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0 Done -> commit n False{-no flush-} True{-release-} >> return () Skip s' -> inner s' n Yield x s' - | n >= bufSize + bool 1 0 (isCRLF && x == '\n') -> + | n >= bufSize - bool 0 1 (isCRLF && x == '\n') -> commit n True{-needs flush-} False >>= outer s | isCRLF && x == '\n' -> do n1 <- writeCharBuf bufRaw bufSize n '\r' From 2aa9b26cf543d4f115717ed747b8ab0cc5f2b048 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Wed, 29 May 2024 11:19:02 -0400 Subject: [PATCH 6/7] revert buffer field renaming and commit buffer arguments --- src/Data/Text/IO.hs | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/src/Data/Text/IO.hs b/src/Data/Text/IO.hs index 624160f57..bdf56a01f 100644 --- a/src/Data/Text/IO.hs +++ b/src/Data/Text/IO.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, RecordWildCards, ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NamedFieldPuns #-} -- | -- Module : Data.Text.IO -- Copyright : (c) 2009, 2010 Bryan O'Sullivan, @@ -209,40 +208,40 @@ hPutChars h (Stream next0 s0 _len) = loop s0 writeLines :: Handle -> Newline -> CharBuffer -> Stream Char -> IO () writeLines h nl buf0 (Stream next0 s0 _len) = outer s0 buf0 where - outer s1 buf@Buffer{..} = inner s1 (0::Int) + outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int) where inner !s !n = case next0 s of Done -> commit n False{-no flush-} True{-release-} >> return () Skip s' -> inner s' n Yield x s' - | n + 1 >= bufSize -> commit n True{-needs flush-} False >>= outer s + | n + 1 >= len -> commit n True{-needs flush-} False >>= outer s | x == '\n' -> do n' <- if nl == CRLF - then do n1 <- writeCharBuf bufRaw bufSize n '\r' - writeCharBuf bufRaw bufSize n1 '\n' - else writeCharBuf bufRaw bufSize n x + then do n1 <- writeCharBuf raw len n '\r' + writeCharBuf raw len n1 '\n' + else writeCharBuf raw len n x commit n' True{-needs flush-} False >>= outer s' - | otherwise -> writeCharBuf bufRaw bufSize n x >>= inner s' - commit = commitBuffer h buf + | otherwise -> writeCharBuf raw len n x >>= inner s' + commit = commitBuffer h raw len writeBlocks :: Bool -> Handle -> CharBuffer -> Stream Char -> IO () writeBlocks isCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0 where - outer s1 buf@Buffer{..} = inner s1 (0::Int) + outer s1 Buffer{bufRaw=raw, bufSize=len} = inner s1 (0::Int) where inner !s !n = case next0 s of Done -> commit n False{-no flush-} True{-release-} >> return () Skip s' -> inner s' n Yield x s' - | n >= bufSize - bool 0 1 (isCRLF && x == '\n') -> + | n >= len - bool 0 1 (isCRLF && x == '\n') -> commit n True{-needs flush-} False >>= outer s | isCRLF && x == '\n' -> do - n1 <- writeCharBuf bufRaw bufSize n '\r' - writeCharBuf bufRaw bufSize n1 '\n' >>= inner s' - | otherwise -> writeCharBuf bufRaw bufSize n x >>= inner s' - commit = commitBuffer h buf + n1 <- writeCharBuf raw len n '\r' + writeCharBuf raw len n1 '\n' >>= inner s' + | otherwise -> writeCharBuf raw len n x >>= inner s' + commit = commitBuffer h raw len -- | Only modifies the raw buffer and not the buffer attributes writeCharBuf :: RawCharBuffer -> Int -> Int -> Char -> IO Int @@ -270,11 +269,11 @@ getSpareBuffer Handle__{haCharBuffer=ref, -- This function is modified from GHC.Internal.IO.Handle.Text. -commitBuffer :: Handle -> CharBuffer -> Int -> Bool -> Bool +commitBuffer :: Handle -> RawCharBuffer -> Int -> Int -> Bool -> Bool -> IO CharBuffer -commitBuffer hdl Buffer{bufRaw, bufSize} !count flush release = +commitBuffer hdl !raw !sz !count flush release = wantWritableHandle "commitAndReleaseBuffer" hdl $ - commitBuffer' bufRaw bufSize count flush release + commitBuffer' raw sz count flush release {-# INLINE commitBuffer #-} -- | Write a string to a handle, followed by a newline. From 9f3bc7f99d2d5d43089632d827a2f8dc0ed10ce6 Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Wed, 29 May 2024 11:28:59 -0400 Subject: [PATCH 7/7] reordered writeBlocks Yield conditions --- src/Data/Text/IO.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Data/Text/IO.hs b/src/Data/Text/IO.hs index bdf56a01f..a4569bc3d 100644 --- a/src/Data/Text/IO.hs +++ b/src/Data/Text/IO.hs @@ -42,7 +42,6 @@ module Data.Text.IO , putStrLn ) where -import Data.Bool (bool) import Data.Text (Text) import Prelude hiding (appendFile, getContents, getLine, interact, putStr, putStrLn, readFile, writeFile) @@ -235,12 +234,11 @@ writeBlocks isCRLF h buf0 (Stream next0 s0 _len) = outer s0 buf0 Done -> commit n False{-no flush-} True{-release-} >> return () Skip s' -> inner s' n Yield x s' - | n >= len - bool 0 1 (isCRLF && x == '\n') -> - commit n True{-needs flush-} False >>= outer s - | isCRLF && x == '\n' -> do - n1 <- writeCharBuf raw len n '\r' - writeCharBuf raw len n1 '\n' >>= inner s' - | otherwise -> writeCharBuf raw len n x >>= inner s' + | isCRLF && x == '\n' && n + 1 < len -> do + n1 <- writeCharBuf raw len n '\r' + writeCharBuf raw len n1 '\n' >>= inner s' + | n < len -> writeCharBuf raw len n x >>= inner s' + | otherwise -> commit n True{-needs flush-} False >>= outer s commit = commitBuffer h raw len -- | Only modifies the raw buffer and not the buffer attributes