[project @ 2002-03-26 17:11:15 by simonmar]
[packages/random.git] / Data / Array / IO.hs
1 {-# OPTIONS -#include "HsBase.h" #-}
2 -----------------------------------------------------------------------------
3 --
4 -- Module : Data.Array.IO
5 -- Copyright : (c) The University of Glasgow 2001
6 -- License : BSD-style (see the file libraries/core/LICENSE)
7 --
8 -- Maintainer : libraries@haskell.org
9 -- Stability : experimental
10 -- Portability : non-portable
11 --
12 -- $Id: IO.hs,v 1.6 2002/03/26 17:11:15 simonmar Exp $
13 --
14 -- Mutable boxed/unboxed arrays in the IO monad.
15 --
16 -----------------------------------------------------------------------------
17
18 module Data.Array.IO (
19 module Data.Array.MArray,
20 IOArray, -- instance of: Eq, Typeable
21 IOUArray, -- instance of: Eq, Typeable
22 castIOUArray, -- :: IOUArray i a -> IO (IOUArray i b)
23 hGetArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO Int
24 hPutArray, -- :: Handle -> IOUArray Int Word8 -> Int -> IO ()
25 ) where
26
27 import Prelude
28
29 import Data.Array ( Array )
30 import Data.Array.MArray
31 import Data.Int
32 import Data.Word
33 import Data.Dynamic
34
35 import Foreign.C
36 import Foreign.Ptr ( Ptr, FunPtr )
37 import Foreign.StablePtr ( StablePtr )
38
39 #ifdef __GLASGOW_HASKELL__
40 -- GHC only to the end of file
41
42 import Data.Array.Base
43 import GHC.Arr ( STArray, freezeSTArray, unsafeFreezeSTArray,
44 thawSTArray, unsafeThawSTArray )
45
46 import GHC.ST ( ST(..) )
47
48 import GHC.IOBase
49 import GHC.Handle
50 import GHC.Conc
51
52 import GHC.Base
53
54 -----------------------------------------------------------------------------
55 -- Polymorphic non-strict mutable arrays (IO monad)
56
57 newtype IOArray i e = IOArray (STArray RealWorld i e) deriving Eq
58
59 iOArrayTc :: TyCon
60 iOArrayTc = mkTyCon "IOArray"
61
62 instance (Typeable a, Typeable b) => Typeable (IOArray a b) where
63 typeOf a = mkAppTy iOArrayTc [typeOf ((undefined :: IOArray a b -> a) a),
64 typeOf ((undefined :: IOArray a b -> b) a)]
65
66 instance HasBounds IOArray where
67 {-# INLINE bounds #-}
68 bounds (IOArray marr) = bounds marr
69
70 instance MArray IOArray e IO where
71 {-# INLINE newArray #-}
72 newArray lu init = stToIO $ do
73 marr <- newArray lu init; return (IOArray marr)
74 {-# INLINE newArray_ #-}
75 newArray_ lu = stToIO $ do
76 marr <- newArray_ lu; return (IOArray marr)
77 {-# INLINE unsafeRead #-}
78 unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
79 {-# INLINE unsafeWrite #-}
80 unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
81
82 -----------------------------------------------------------------------------
83 -- Flat unboxed mutable arrays (IO monad)
84
85 newtype IOUArray i e = IOUArray (STUArray RealWorld i e) deriving Eq
86
87 iOUArrayTc :: TyCon
88 iOUArrayTc = mkTyCon "IOUArray"
89
90 instance (Typeable a, Typeable b) => Typeable (IOUArray a b) where
91 typeOf a = mkAppTy iOUArrayTc [typeOf ((undefined :: IOUArray a b -> a) a),
92 typeOf ((undefined :: IOUArray a b -> b) a)]
93
94 instance HasBounds IOUArray where
95 {-# INLINE bounds #-}
96 bounds (IOUArray marr) = bounds marr
97
98 instance MArray IOUArray Bool IO where
99 {-# INLINE newArray #-}
100 newArray lu init = stToIO $ do
101 marr <- newArray lu init; return (IOUArray marr)
102 {-# INLINE newArray_ #-}
103 newArray_ lu = stToIO $ do
104 marr <- newArray_ lu; return (IOUArray marr)
105 {-# INLINE unsafeRead #-}
106 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
107 {-# INLINE unsafeWrite #-}
108 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
109
110 instance MArray IOUArray Char IO where
111 {-# INLINE newArray #-}
112 newArray lu init = stToIO $ do
113 marr <- newArray lu init; return (IOUArray marr)
114 {-# INLINE newArray_ #-}
115 newArray_ lu = stToIO $ do
116 marr <- newArray_ lu; return (IOUArray marr)
117 {-# INLINE unsafeRead #-}
118 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
119 {-# INLINE unsafeWrite #-}
120 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
121
122 instance MArray IOUArray Int IO where
123 {-# INLINE newArray #-}
124 newArray lu init = stToIO $ do
125 marr <- newArray lu init; return (IOUArray marr)
126 {-# INLINE newArray_ #-}
127 newArray_ lu = stToIO $ do
128 marr <- newArray_ lu; return (IOUArray marr)
129 {-# INLINE unsafeRead #-}
130 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
131 {-# INLINE unsafeWrite #-}
132 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
133
134 instance MArray IOUArray Word IO where
135 {-# INLINE newArray #-}
136 newArray lu init = stToIO $ do
137 marr <- newArray lu init; return (IOUArray marr)
138 {-# INLINE newArray_ #-}
139 newArray_ lu = stToIO $ do
140 marr <- newArray_ lu; return (IOUArray marr)
141 {-# INLINE unsafeRead #-}
142 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
143 {-# INLINE unsafeWrite #-}
144 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
145
146 instance MArray IOUArray (Ptr a) IO where
147 {-# INLINE newArray #-}
148 newArray lu init = stToIO $ do
149 marr <- newArray lu init; return (IOUArray marr)
150 {-# INLINE newArray_ #-}
151 newArray_ lu = stToIO $ do
152 marr <- newArray_ lu; return (IOUArray marr)
153 {-# INLINE unsafeRead #-}
154 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
155 {-# INLINE unsafeWrite #-}
156 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
157
158 instance MArray IOUArray (FunPtr a) IO where
159 {-# INLINE newArray #-}
160 newArray lu init = stToIO $ do
161 marr <- newArray lu init; return (IOUArray marr)
162 {-# INLINE newArray_ #-}
163 newArray_ lu = stToIO $ do
164 marr <- newArray_ lu; return (IOUArray marr)
165 {-# INLINE unsafeRead #-}
166 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
167 {-# INLINE unsafeWrite #-}
168 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
169
170 instance MArray IOUArray Float IO where
171 {-# INLINE newArray #-}
172 newArray lu init = stToIO $ do
173 marr <- newArray lu init; return (IOUArray marr)
174 {-# INLINE newArray_ #-}
175 newArray_ lu = stToIO $ do
176 marr <- newArray_ lu; return (IOUArray marr)
177 {-# INLINE unsafeRead #-}
178 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
179 {-# INLINE unsafeWrite #-}
180 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
181
182 instance MArray IOUArray Double IO where
183 {-# INLINE newArray #-}
184 newArray lu init = stToIO $ do
185 marr <- newArray lu init; return (IOUArray marr)
186 {-# INLINE newArray_ #-}
187 newArray_ lu = stToIO $ do
188 marr <- newArray_ lu; return (IOUArray marr)
189 {-# INLINE unsafeRead #-}
190 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
191 {-# INLINE unsafeWrite #-}
192 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
193
194 instance MArray IOUArray (StablePtr a) IO where
195 {-# INLINE newArray #-}
196 newArray lu init = stToIO $ do
197 marr <- newArray lu init; return (IOUArray marr)
198 {-# INLINE newArray_ #-}
199 newArray_ lu = stToIO $ do
200 marr <- newArray_ lu; return (IOUArray marr)
201 {-# INLINE unsafeRead #-}
202 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
203 {-# INLINE unsafeWrite #-}
204 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
205
206 instance MArray IOUArray Int8 IO where
207 {-# INLINE newArray #-}
208 newArray lu init = stToIO $ do
209 marr <- newArray lu init; return (IOUArray marr)
210 {-# INLINE newArray_ #-}
211 newArray_ lu = stToIO $ do
212 marr <- newArray_ lu; return (IOUArray marr)
213 {-# INLINE unsafeRead #-}
214 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
215 {-# INLINE unsafeWrite #-}
216 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
217
218 instance MArray IOUArray Int16 IO where
219 {-# INLINE newArray #-}
220 newArray lu init = stToIO $ do
221 marr <- newArray lu init; return (IOUArray marr)
222 {-# INLINE newArray_ #-}
223 newArray_ lu = stToIO $ do
224 marr <- newArray_ lu; return (IOUArray marr)
225 {-# INLINE unsafeRead #-}
226 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
227 {-# INLINE unsafeWrite #-}
228 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
229
230 instance MArray IOUArray Int32 IO where
231 {-# INLINE newArray #-}
232 newArray lu init = stToIO $ do
233 marr <- newArray lu init; return (IOUArray marr)
234 {-# INLINE newArray_ #-}
235 newArray_ lu = stToIO $ do
236 marr <- newArray_ lu; return (IOUArray marr)
237 {-# INLINE unsafeRead #-}
238 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
239 {-# INLINE unsafeWrite #-}
240 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
241
242 instance MArray IOUArray Int64 IO where
243 {-# INLINE newArray #-}
244 newArray lu init = stToIO $ do
245 marr <- newArray lu init; return (IOUArray marr)
246 {-# INLINE newArray_ #-}
247 newArray_ lu = stToIO $ do
248 marr <- newArray_ lu; return (IOUArray marr)
249 {-# INLINE unsafeRead #-}
250 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
251 {-# INLINE unsafeWrite #-}
252 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
253
254 instance MArray IOUArray Word8 IO where
255 {-# INLINE newArray #-}
256 newArray lu init = stToIO $ do
257 marr <- newArray lu init; return (IOUArray marr)
258 {-# INLINE newArray_ #-}
259 newArray_ lu = stToIO $ do
260 marr <- newArray_ lu; return (IOUArray marr)
261 {-# INLINE unsafeRead #-}
262 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
263 {-# INLINE unsafeWrite #-}
264 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
265
266 instance MArray IOUArray Word16 IO where
267 {-# INLINE newArray #-}
268 newArray lu init = stToIO $ do
269 marr <- newArray lu init; return (IOUArray marr)
270 {-# INLINE newArray_ #-}
271 newArray_ lu = stToIO $ do
272 marr <- newArray_ lu; return (IOUArray marr)
273 {-# INLINE unsafeRead #-}
274 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
275 {-# INLINE unsafeWrite #-}
276 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
277
278 instance MArray IOUArray Word32 IO where
279 {-# INLINE newArray #-}
280 newArray lu init = stToIO $ do
281 marr <- newArray lu init; return (IOUArray marr)
282 {-# INLINE newArray_ #-}
283 newArray_ lu = stToIO $ do
284 marr <- newArray_ lu; return (IOUArray marr)
285 {-# INLINE unsafeRead #-}
286 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
287 {-# INLINE unsafeWrite #-}
288 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
289
290 instance MArray IOUArray Word64 IO where
291 {-# INLINE newArray #-}
292 newArray lu init = stToIO $ do
293 marr <- newArray lu init; return (IOUArray marr)
294 {-# INLINE newArray_ #-}
295 newArray_ lu = stToIO $ do
296 marr <- newArray_ lu; return (IOUArray marr)
297 {-# INLINE unsafeRead #-}
298 unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
299 {-# INLINE unsafeWrite #-}
300 unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
301
302 -----------------------------------------------------------------------------
303 -- Freezing
304
305 freezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
306 freezeIOArray (IOArray marr) = stToIO (freezeSTArray marr)
307
308 freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
309 freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)
310
311 {-# RULES
312 "freeze/IOArray" freeze = freezeIOArray
313 "freeze/IOUArray" freeze = freezeIOUArray
314 #-}
315
316 {-# INLINE unsafeFreezeIOArray #-}
317 unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
318 unsafeFreezeIOArray (IOArray marr) = stToIO (unsafeFreezeSTArray marr)
319
320 {-# INLINE unsafeFreezeIOUArray #-}
321 unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
322 unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)
323
324 {-# RULES
325 "unsafeFreeze/IOArray" unsafeFreeze = unsafeFreezeIOArray
326 "unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray
327 #-}
328
329 -----------------------------------------------------------------------------
330 -- Thawing
331
332 thawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
333 thawIOArray arr = stToIO $ do
334 marr <- thawSTArray arr
335 return (IOArray marr)
336
337 thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
338 thawIOUArray arr = stToIO $ do
339 marr <- thawSTUArray arr
340 return (IOUArray marr)
341
342 {-# RULES
343 "thaw/IOArray" thaw = thawIOArray
344 "thaw/IOUArray" thaw = thawIOUArray
345 #-}
346
347 {-# INLINE unsafeThawIOArray #-}
348 unsafeThawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
349 unsafeThawIOArray arr = stToIO $ do
350 marr <- unsafeThawSTArray arr
351 return (IOArray marr)
352
353 {-# INLINE unsafeThawIOUArray #-}
354 unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
355 unsafeThawIOUArray arr = stToIO $ do
356 marr <- unsafeThawSTUArray arr
357 return (IOUArray marr)
358
359 {-# RULES
360 "unsafeThaw/IOArray" unsafeThaw = unsafeThawIOArray
361 "unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
362 #-}
363
364 castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
365 castSTUArray (STUArray l u marr#) = return (STUArray l u marr#)
366
367 castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)
368 castIOUArray (IOUArray marr) = stToIO $ do
369 marr' <- castSTUArray marr
370 return (IOUArray marr')
371
372 -- ---------------------------------------------------------------------------
373 -- hGetArray
374
375 hGetArray :: Handle -> IOUArray Int Word8 -> Int -> IO Int
376 hGetArray handle (IOUArray (STUArray l u ptr)) count
377 | count <= 0 || count > rangeSize (l,u)
378 = illegalBufferSize handle "hGetArray" count
379 | otherwise = do
380 wantReadableHandle "hGetArray" handle $
381 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
382 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
383 if bufferEmpty buf
384 then readChunk fd is_stream ptr 0 count
385 else do
386 let avail = w - r
387 copied <- if (count >= avail)
388 then do
389 memcpy_ba_baoff ptr raw r (fromIntegral avail)
390 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
391 return avail
392 else do
393 memcpy_ba_baoff ptr raw r (fromIntegral count)
394 writeIORef ref buf{ bufRPtr = r + count }
395 return count
396
397 let remaining = count - copied
398 if remaining > 0
399 then do rest <- readChunk fd is_stream ptr copied remaining
400 return (rest + count)
401 else return count
402
403 readChunk :: FD -> Bool -> RawBuffer -> Int -> Int -> IO Int
404 readChunk fd is_stream ptr init_off bytes = loop init_off bytes
405 where
406 loop :: Int -> Int -> IO Int
407 loop off bytes | bytes <= 0 = return (off - init_off)
408 loop off bytes = do
409 r' <- throwErrnoIfMinus1RetryMayBlock "readChunk"
410 (read_off_ba (fromIntegral fd) is_stream ptr
411 (fromIntegral off) (fromIntegral bytes))
412 (threadWaitRead fd)
413 let r = fromIntegral r'
414 if r == 0
415 then return (off - init_off)
416 else loop (off + r) (bytes - r)
417
418 -- ---------------------------------------------------------------------------
419 -- hPutArray
420
421 hPutArray
422 :: Handle -- handle to write to
423 -> IOUArray Int Word8 -- buffer
424 -> Int -- number of bytes of data to write
425 -> IO ()
426
427 hPutArray handle (IOUArray (STUArray l u raw)) count
428 | count <= 0 || count > rangeSize (l,u)
429 = illegalBufferSize handle "hPutArray" count
430 | otherwise
431 = do wantWritableHandle "hPutArray" handle $
432 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
433
434 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
435 <- readIORef ref
436
437 -- enough room in handle buffer?
438 if (size - w > count)
439 -- There's enough room in the buffer:
440 -- just copy the data in and update bufWPtr.
441 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
442 writeIORef ref old_buf{ bufWPtr = w + count }
443 return ()
444
445 -- else, we have to flush
446 else do flushed_buf <- flushWriteBuffer fd stream old_buf
447 writeIORef ref flushed_buf
448 let this_buf =
449 Buffer{ bufBuf=raw, bufState=WriteBuffer,
450 bufRPtr=0, bufWPtr=count, bufSize=count }
451 flushWriteBuffer fd stream this_buf
452 return ()
453
454 -- ---------------------------------------------------------------------------
455 -- Internal Utils
456
457 foreign import ccall unsafe "__hscore_memcpy_dst_off"
458 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
459 foreign import ccall unsafe "__hscore_memcpy_src_off"
460 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
461
462 illegalBufferSize :: Handle -> String -> Int -> IO a
463 illegalBufferSize handle fn sz =
464 ioException (IOError (Just handle)
465 InvalidArgument fn
466 ("illegal buffer size " ++ showsPrec 9 (sz::Int) [])
467 Nothing)
468
469 #endif /* __GLASGOW_HASKELL__ */