c019d69beae4085d07740310ea3308e9711e4ed5
[packages/base.git] / GHC / IO / Buffer.hs
1 {-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface #-}
2 {-# OPTIONS_GHC -funbox-strict-fields #-}
3
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module : GHC.IO.Buffer
7 -- Copyright : (c) The University of Glasgow 2008
8 -- License : see libraries/base/LICENSE
9 --
10 -- Maintainer : cvs-ghc@haskell.org
11 -- Stability : internal
12 -- Portability : non-portable (GHC Extensions)
13 --
14 -- Buffers used in the IO system
15 --
16 -----------------------------------------------------------------------------
17
18 module GHC.IO.Buffer (
19 -- * Buffers of any element
20 Buffer(..), BufferState(..), CharBuffer, CharBufElem,
21
22 -- ** Creation
23 newByteBuffer,
24 newCharBuffer,
25 newBuffer,
26 emptyBuffer,
27
28 -- ** Insertion/removal
29 bufferRemove,
30 bufferAdd,
31 slideContents,
32 bufferAdjustL,
33
34 -- ** Inspecting
35 isEmptyBuffer,
36 isFullBuffer,
37 isFullCharBuffer,
38 isWriteBuffer,
39 bufferElems,
40 bufferAvailable,
41 summaryBuffer,
42
43 -- ** Operating on the raw buffer as a Ptr
44 withBuffer,
45 withRawBuffer,
46
47 -- ** Assertions
48 checkBuffer,
49
50 -- * Raw buffers
51 RawBuffer,
52 readWord8Buf,
53 writeWord8Buf,
54 RawCharBuffer,
55 peekCharBuf,
56 readCharBuf,
57 writeCharBuf,
58 readCharBufPtr,
59 writeCharBufPtr,
60 charSize,
61 ) where
62
63 import GHC.Base
64 -- import GHC.IO
65 import GHC.Num
66 import GHC.Ptr
67 import GHC.Word
68 import GHC.Show
69 import GHC.Real
70 import Foreign.C.Types
71 import Foreign.ForeignPtr
72 import Foreign.Storable
73
74 -- Char buffers use either UTF-16 or UTF-32, with the endianness matching
75 -- the endianness of the host.
76 --
77 -- Invariants:
78 -- * a Char buffer consists of *valid* UTF-16 or UTF-32
79 -- * only whole characters: no partial surrogate pairs
80
81 #define CHARBUF_UTF32
82
83 -- #define CHARBUF_UTF16
84 --
85 -- NB. it won't work to just change this to CHARBUF_UTF16. Some of
86 -- the code to make this work is there, and it has been tested with
87 -- the Iconv codec, but there are some pieces that are known to be
88 -- broken. In particular, the built-in codecs
89 -- e.g. GHC.IO.Encoding.UTF{8,16,32} need to use isFullCharBuffer or
90 -- similar in place of the ow >= os comparisions.
91
92 -- ---------------------------------------------------------------------------
93 -- Raw blocks of data
94
95 type RawBuffer e = ForeignPtr e
96
97 readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8
98 readWord8Buf arr ix = withForeignPtr arr $ \p -> peekByteOff p ix
99
100 writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO ()
101 writeWord8Buf arr ix w = withForeignPtr arr $ \p -> pokeByteOff p ix w
102
103 #ifdef CHARBUF_UTF16
104 type CharBufElem = Word16
105 #else
106 type CharBufElem = Char
107 #endif
108
109 type RawCharBuffer = RawBuffer CharBufElem
110
111 peekCharBuf :: RawCharBuffer -> Int -> IO Char
112 peekCharBuf arr ix = withForeignPtr arr $ \p -> do
113 (c,_) <- readCharBufPtr p ix
114 return c
115
116 {-# INLINE readCharBuf #-}
117 readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int)
118 readCharBuf arr ix = withForeignPtr arr $ \p -> readCharBufPtr p ix
119
120 {-# INLINE writeCharBuf #-}
121 writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int
122 writeCharBuf arr ix c = withForeignPtr arr $ \p -> writeCharBufPtr p ix c
123
124 {-# INLINE readCharBufPtr #-}
125 readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int)
126 #ifdef CHARBUF_UTF16
127 readCharBufPtr p ix = do
128 c1 <- peekElemOff p ix
129 if (c1 < 0xd800 || c1 > 0xdbff)
130 then return (chr (fromIntegral c1), ix+1)
131 else do c2 <- peekElemOff p (ix+1)
132 return (unsafeChr ((fromIntegral c1 - 0xd800)*0x400 +
133 (fromIntegral c2 - 0xdc00) + 0x10000), ix+2)
134 #else
135 readCharBufPtr p ix = do c <- peekElemOff (castPtr p) ix; return (c, ix+1)
136 #endif
137
138 {-# INLINE writeCharBufPtr #-}
139 writeCharBufPtr :: Ptr CharBufElem -> Int -> Char -> IO Int
140 #ifdef CHARBUF_UTF16
141 writeCharBufPtr p ix ch
142 | c < 0x10000 = do pokeElemOff p ix (fromIntegral c)
143 return (ix+1)
144 | otherwise = do let c' = c - 0x10000
145 pokeElemOff p ix (fromIntegral (c' `div` 0x400 + 0xd800))
146 pokeElemOff p (ix+1) (fromIntegral (c' `mod` 0x400 + 0xdc00))
147 return (ix+2)
148 where
149 c = ord ch
150 #else
151 writeCharBufPtr p ix ch = do pokeElemOff (castPtr p) ix ch; return (ix+1)
152 #endif
153
154 charSize :: Int
155 #ifdef CHARBUF_UTF16
156 charSize = 2
157 #else
158 charSize = 4
159 #endif
160
161 -- ---------------------------------------------------------------------------
162 -- Buffers
163
164 -- | A mutable array of bytes that can be passed to foreign functions.
165 --
166 -- The buffer is represented by a record, where the record contains
167 -- the raw buffer and the start/end points of the filled portion. The
168 -- buffer contents itself is mutable, but the rest of the record is
169 -- immutable. This is a slightly odd mix, but it turns out to be
170 -- quite practical: by making all the buffer metadata immutable, we
171 -- can have operations on buffer metadata outside of the IO monad.
172 --
173 -- The "live" elements of the buffer are those between the 'bufL' and
174 -- 'bufR' offsets. In an empty buffer, 'bufL' is equal to 'bufR', but
175 -- they might not be zero: for exmaple, the buffer might correspond to
176 -- a memory-mapped file and in which case 'bufL' will point to the
177 -- next location to be written, which is not necessarily the beginning
178 -- of the file.
179 data Buffer e
180 = Buffer {
181 bufRaw :: !(RawBuffer e),
182 bufState :: BufferState,
183 bufSize :: !Int, -- in elements, not bytes
184 bufL :: !Int, -- offset of first item in the buffer
185 bufR :: !Int -- offset of last item + 1
186 }
187
188 #ifdef CHARBUF_UTF16
189 type CharBuffer = Buffer Word16
190 #else
191 type CharBuffer = Buffer Char
192 #endif
193
194 data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
195
196 withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a
197 withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f
198
199 withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a
200 withRawBuffer raw f = withForeignPtr (castForeignPtr raw) f
201
202 isEmptyBuffer :: Buffer e -> Bool
203 isEmptyBuffer Buffer{ bufL=l, bufR=r } = l == r
204
205 isFullBuffer :: Buffer e -> Bool
206 isFullBuffer Buffer{ bufR=w, bufSize=s } = s == w
207
208 -- if a Char buffer does not have room for a surrogate pair, it is "full"
209 isFullCharBuffer :: Buffer e -> Bool
210 #ifdef CHARBUF_UTF16
211 isFullCharBuffer buf = bufferAvailable buf < 2
212 #else
213 isFullCharBuffer = isFullBuffer
214 #endif
215
216 isWriteBuffer :: Buffer e -> Bool
217 isWriteBuffer buf = case bufState buf of
218 WriteBuffer -> True
219 ReadBuffer -> False
220
221 bufferElems :: Buffer e -> Int
222 bufferElems Buffer{ bufR=w, bufL=r } = w - r
223
224 bufferAvailable :: Buffer e -> Int
225 bufferAvailable Buffer{ bufR=w, bufSize=s } = s - w
226
227 bufferRemove :: Int -> Buffer e -> Buffer e
228 bufferRemove i buf@Buffer{ bufL=r } = bufferAdjustL (r+i) buf
229
230 bufferAdjustL :: Int -> Buffer e -> Buffer e
231 bufferAdjustL l buf@Buffer{ bufR=w }
232 | l == w = buf{ bufL=0, bufR=0 }
233 | otherwise = buf{ bufL=l, bufR=w }
234
235 bufferAdd :: Int -> Buffer e -> Buffer e
236 bufferAdd i buf@Buffer{ bufR=w } = buf{ bufR=w+i }
237
238 emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e
239 emptyBuffer raw sz state =
240 Buffer{ bufRaw=raw, bufState=state, bufR=0, bufL=0, bufSize=sz }
241
242 newByteBuffer :: Int -> BufferState -> IO (Buffer Word8)
243 newByteBuffer c st = newBuffer c c st
244
245 newCharBuffer :: Int -> BufferState -> IO CharBuffer
246 newCharBuffer c st = newBuffer (c * charSize) c st
247
248 newBuffer :: Int -> Int -> BufferState -> IO (Buffer e)
249 newBuffer bytes sz state = do
250 fp <- mallocForeignPtrBytes bytes
251 return (emptyBuffer fp sz state)
252
253 -- | slides the contents of the buffer to the beginning
254 slideContents :: Buffer Word8 -> IO (Buffer Word8)
255 slideContents buf@Buffer{ bufL=l, bufR=r, bufRaw=raw } = do
256 let elems = r - l
257 withRawBuffer raw $ \p ->
258 do _ <- memcpy p (p `plusPtr` l) (fromIntegral elems)
259 return ()
260 return buf{ bufL=0, bufR=elems }
261
262 foreign import ccall unsafe "memcpy"
263 memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
264
265 summaryBuffer :: Buffer a -> String
266 summaryBuffer buf = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")"
267
268 -- INVARIANTS on Buffers:
269 -- * r <= w
270 -- * if r == w, and the buffer is for reading, then r == 0 && w == 0
271 -- * a write buffer is never full. If an operation
272 -- fills up the buffer, it will always flush it before
273 -- returning.
274 -- * a read buffer may be full as a result of hLookAhead. In normal
275 -- operation, a read buffer always has at least one character of space.
276
277 checkBuffer :: Buffer a -> IO ()
278 checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do
279 check buf (
280 size > 0
281 && r <= w
282 && w <= size
283 && ( r /= w || state == WriteBuffer || (r == 0 && w == 0) )
284 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
285 )
286
287 check :: Buffer a -> Bool -> IO ()
288 check _ True = return ()
289 check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf)