diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-04-20 16:54:38 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-04-26 13:55:14 -0400 |
commit | af332442123878c1b61d236dce46418efcbe8750 (patch) | |
tree | ec4b332843cdd4fedb4aa60b11b7b8dba82a0764 /compiler/utils/BufWrite.hs | |
parent | b0fbfc7582fb81314dc28a056536737fb5eeaa6e (diff) | |
download | haskell-af332442123878c1b61d236dce46418efcbe8750.tar.gz |
Modules: Utils and Data (#13009)
Update Haddock submodule
Metric Increase:
haddock.compiler
Diffstat (limited to 'compiler/utils/BufWrite.hs')
-rw-r--r-- | compiler/utils/BufWrite.hs | 145 |
1 files changed, 0 insertions, 145 deletions
diff --git a/compiler/utils/BufWrite.hs b/compiler/utils/BufWrite.hs deleted file mode 100644 index 8a28f470f4..0000000000 --- a/compiler/utils/BufWrite.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - ------------------------------------------------------------------------------ --- --- Fast write-buffered Handles --- --- (c) The University of Glasgow 2005-2006 --- --- This is a simple abstraction over Handles that offers very fast write --- buffering, but without the thread safety that Handles provide. It's used --- to save time in Pretty.printDoc. --- ------------------------------------------------------------------------------ - -module BufWrite ( - BufHandle(..), - newBufHandle, - bPutChar, - bPutStr, - bPutFS, - bPutFZS, - bPutPtrString, - bPutReplicate, - bFlush, - ) where - -import GhcPrelude - -import FastString -import FastMutInt - -import Control.Monad ( when ) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Unsafe as BS -import Data.Char ( ord ) -import Foreign -import Foreign.C.String -import System.IO - --- ----------------------------------------------------------------------------- - -data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) - {-#UNPACK#-}!FastMutInt - Handle - -newBufHandle :: Handle -> IO BufHandle -newBufHandle hdl = do - ptr <- mallocBytes buf_size - r <- newFastMutInt - writeFastMutInt r 0 - return (BufHandle ptr r hdl) - -buf_size :: Int -buf_size = 8192 - -bPutChar :: BufHandle -> Char -> IO () -bPutChar b@(BufHandle buf r hdl) !c = do - i <- readFastMutInt r - if (i >= buf_size) - then do hPutBuf hdl buf buf_size - writeFastMutInt r 0 - bPutChar b c - else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) - writeFastMutInt r (i+1) - -bPutStr :: BufHandle -> String -> IO () -bPutStr (BufHandle buf r hdl) !str = do - i <- readFastMutInt r - loop str i - where loop "" !i = do writeFastMutInt r i; return () - loop (c:cs) !i - | i >= buf_size = do - hPutBuf hdl buf buf_size - loop (c:cs) 0 - | otherwise = do - pokeElemOff buf i (fromIntegral (ord c)) - loop cs (i+1) - -bPutFS :: BufHandle -> FastString -> IO () -bPutFS b fs = bPutBS b $ bytesFS fs - -bPutFZS :: BufHandle -> FastZString -> IO () -bPutFZS b fs = bPutBS b $ fastZStringToByteString fs - -bPutBS :: BufHandle -> ByteString -> IO () -bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b - -bPutCStringLen :: BufHandle -> CStringLen -> IO () -bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do - i <- readFastMutInt r - if (i + len) >= buf_size - then do hPutBuf hdl buf i - writeFastMutInt r 0 - if (len >= buf_size) - then hPutBuf hdl ptr len - else bPutCStringLen b cstr - else do - copyBytes (buf `plusPtr` i) ptr len - writeFastMutInt r (i + len) - -bPutPtrString :: BufHandle -> PtrString -> IO () -bPutPtrString b@(BufHandle buf r hdl) l@(PtrString a len) = l `seq` do - i <- readFastMutInt r - if (i+len) >= buf_size - then do hPutBuf hdl buf i - writeFastMutInt r 0 - if (len >= buf_size) - then hPutBuf hdl a len - else bPutPtrString b l - else do - copyBytes (buf `plusPtr` i) a len - writeFastMutInt r (i+len) - --- | Replicate an 8-bit character -bPutReplicate :: BufHandle -> Int -> Char -> IO () -bPutReplicate (BufHandle buf r hdl) len c = do - i <- readFastMutInt r - let oc = fromIntegral (ord c) - if (i+len) < buf_size - then do - fillBytes (buf `plusPtr` i) oc len - writeFastMutInt r (i+len) - else do - -- flush the current buffer - when (i /= 0) $ hPutBuf hdl buf i - if (len < buf_size) - then do - fillBytes buf oc len - writeFastMutInt r len - else do - -- fill a full buffer - fillBytes buf oc buf_size - -- flush it as many times as necessary - let go n | n >= buf_size = do - hPutBuf hdl buf buf_size - go (n-buf_size) - | otherwise = writeFastMutInt r n - go len - -bFlush :: BufHandle -> IO () -bFlush (BufHandle buf r hdl) = do - i <- readFastMutInt r - when (i > 0) $ hPutBuf hdl buf i - free buf - return () |