utils: detabify/dewhitespace GraphPpr
[ghc.git] / compiler / utils / BufWrite.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Fast write-buffered Handles
6 --
7 -- (c) The University of Glasgow 2005-2006
8 --
9 -- This is a simple abstraction over Handles that offers very fast write
10 -- buffering, but without the thread safety that Handles provide. It's used
11 -- to save time in Pretty.printDoc.
12 --
13 -----------------------------------------------------------------------------
14
15 module BufWrite (
16 BufHandle(..),
17 newBufHandle,
18 bPutChar,
19 bPutStr,
20 bPutFS,
21 bPutFZS,
22 bPutLitString,
23 bFlush,
24 ) where
25
26 #include "HsVersions.h"
27
28 import FastString
29 import FastTypes
30 import FastMutInt
31
32 import Control.Monad ( when )
33 import Data.ByteString (ByteString)
34 import qualified Data.ByteString.Unsafe as BS
35 import Data.Char ( ord )
36 import Foreign
37 import Foreign.C.String
38 import System.IO
39
40 -- -----------------------------------------------------------------------------
41
42 data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)
43 {-#UNPACK#-}!FastMutInt
44 Handle
45
46 newBufHandle :: Handle -> IO BufHandle
47 newBufHandle hdl = do
48 ptr <- mallocBytes buf_size
49 r <- newFastMutInt
50 writeFastMutInt r 0
51 return (BufHandle ptr r hdl)
52
53 buf_size :: Int
54 buf_size = 8192
55
56 #define STRICT2(f) f a b | a `seq` b `seq` False = undefined
57 #define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
58
59 bPutChar :: BufHandle -> Char -> IO ()
60 STRICT2(bPutChar)
61 bPutChar b@(BufHandle buf r hdl) c = do
62 i <- readFastMutInt r
63 if (i >= buf_size)
64 then do hPutBuf hdl buf buf_size
65 writeFastMutInt r 0
66 bPutChar b c
67 else do pokeElemOff buf i (fromIntegral (ord c) :: Word8)
68 writeFastMutInt r (i+1)
69
70 bPutStr :: BufHandle -> String -> IO ()
71 STRICT2(bPutStr)
72 bPutStr (BufHandle buf r hdl) str = do
73 i <- readFastMutInt r
74 loop str i
75 where loop _ i | i `seq` False = undefined
76 loop "" i = do writeFastMutInt r i; return ()
77 loop (c:cs) i
78 | i >= buf_size = do
79 hPutBuf hdl buf buf_size
80 loop (c:cs) 0
81 | otherwise = do
82 pokeElemOff buf i (fromIntegral (ord c))
83 loop cs (i+1)
84
85 bPutFS :: BufHandle -> FastString -> IO ()
86 bPutFS b fs = bPutBS b $ fastStringToByteString fs
87
88 bPutFZS :: BufHandle -> FastZString -> IO ()
89 bPutFZS b fs = bPutBS b $ fastZStringToByteString fs
90
91 bPutBS :: BufHandle -> ByteString -> IO ()
92 bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b
93
94 bPutCStringLen :: BufHandle -> CStringLen -> IO ()
95 bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do
96 i <- readFastMutInt r
97 if (i + len) >= buf_size
98 then do hPutBuf hdl buf i
99 writeFastMutInt r 0
100 if (len >= buf_size)
101 then hPutBuf hdl ptr len
102 else bPutCStringLen b cstr
103 else do
104 copyBytes (buf `plusPtr` i) ptr len
105 writeFastMutInt r (i + len)
106
107 bPutLitString :: BufHandle -> LitString -> FastInt -> IO ()
108 bPutLitString b@(BufHandle buf r hdl) a len_ = a `seq` do
109 let len = iBox len_
110 i <- readFastMutInt r
111 if (i+len) >= buf_size
112 then do hPutBuf hdl buf i
113 writeFastMutInt r 0
114 if (len >= buf_size)
115 then hPutBuf hdl a len
116 else bPutLitString b a len_
117 else do
118 copyBytes (buf `plusPtr` i) a len
119 writeFastMutInt r (i+len)
120
121 bFlush :: BufHandle -> IO ()
122 bFlush (BufHandle buf r hdl) = do
123 i <- readFastMutInt r
124 when (i > 0) $ hPutBuf hdl buf i
125 free buf
126 return ()
127
128 #if 0
129 myPutBuf s hdl buf i =
130 modifyIOError (\e -> ioeSetErrorString e (ioeGetErrorString e ++ ':':s ++ " (" ++ show buf ++ "," ++ show i ++ ")")) $
131
132 hPutBuf hdl buf i
133 #endif