[project @ 2002-02-11 12:28:31 by simonmar]
[packages/old-time.git] / GHC / IO.hs
1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
2
3 #undef DEBUG_DUMP
4
5 -- -----------------------------------------------------------------------------
6 -- $Id: IO.hs,v 1.5 2002/02/11 12:28:31 simonmar Exp $
7 --
8 -- (c) The University of Glasgow, 1992-2001
9 --
10
11 module GHC.IO (
12 hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
13 commitBuffer', -- hack, see below
14 hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
15 hGetBuf, hPutBuf, slurpFile,
16 memcpy_ba_baoff,
17 memcpy_ptr_baoff,
18 memcpy_baoff_ba,
19 memcpy_baoff_ptr,
20 ) where
21
22 import Foreign
23 import Foreign.C
24
25 import System.IO.Error
26 import Data.Maybe
27 import Control.Monad
28
29 import GHC.Enum
30 import GHC.Base
31 import GHC.Posix
32 import GHC.IOBase
33 import GHC.Handle -- much of the real stuff is in here
34 import GHC.Real
35 import GHC.Num
36 import GHC.Show
37 import GHC.List
38 import GHC.Exception ( ioError, catch, throw )
39 import GHC.Conc
40
41 -- ---------------------------------------------------------------------------
42 -- Simple input operations
43
44 -- Computation "hReady hdl" indicates whether at least
45 -- one item is available for input from handle "hdl".
46
47 -- If hWaitForInput finds anything in the Handle's buffer, it
48 -- immediately returns. If not, it tries to read from the underlying
49 -- OS handle. Notice that for buffered Handles connected to terminals
50 -- this means waiting until a complete line is available.
51
52 hWaitForInput :: Handle -> Int -> IO Bool
53 hWaitForInput h msecs = do
54 wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
55 let ref = haBuffer handle_
56 buf <- readIORef ref
57
58 if not (bufferEmpty buf)
59 then return True
60 else do
61
62 r <- throwErrnoIfMinus1Retry "hWaitForInput"
63 (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
64 return (r /= 0)
65
66 foreign import ccall unsafe "inputReady"
67 inputReady :: CInt -> CInt -> Bool -> IO CInt
68
69 -- ---------------------------------------------------------------------------
70 -- hGetChar
71
72 -- hGetChar reads the next character from a handle,
73 -- blocking until a character is available.
74
75 hGetChar :: Handle -> IO Char
76 hGetChar handle =
77 wantReadableHandle "hGetChar" handle $ \handle_ -> do
78
79 let fd = haFD handle_
80 ref = haBuffer handle_
81
82 buf <- readIORef ref
83 if not (bufferEmpty buf)
84 then hGetcBuffered fd ref buf
85 else do
86
87 -- buffer is empty.
88 case haBufferMode handle_ of
89 LineBuffering -> do
90 new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
91 hGetcBuffered fd ref new_buf
92 BlockBuffering _ -> do
93 new_buf <- fillReadBuffer fd False (haIsStream handle_) buf
94 hGetcBuffered fd ref new_buf
95 NoBuffering -> do
96 -- make use of the minimal buffer we already have
97 let raw = bufBuf buf
98 r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
99 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
100 (threadWaitRead fd)
101 if r == 0
102 then ioe_EOF
103 else do (c,_) <- readCharFromBuffer raw 0
104 return c
105
106 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
107 = do (c,r) <- readCharFromBuffer b r
108 let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
109 | otherwise = buf{ bufRPtr=r }
110 writeIORef ref new_buf
111 return c
112
113 -- ---------------------------------------------------------------------------
114 -- hGetLine
115
116 -- If EOF is reached before EOL is encountered, ignore the EOF and
117 -- return the partial line. Next attempt at calling hGetLine on the
118 -- handle will yield an EOF IO exception though.
119
120 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
121 -- the duration.
122 hGetLine :: Handle -> IO String
123 hGetLine h = do
124 m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
125 case haBufferMode handle_ of
126 NoBuffering -> return Nothing
127 LineBuffering -> do
128 l <- hGetLineBuffered handle_
129 return (Just l)
130 BlockBuffering _ -> do
131 l <- hGetLineBuffered handle_
132 return (Just l)
133 case m of
134 Nothing -> hGetLineUnBuffered h
135 Just l -> return l
136
137
138 hGetLineBuffered handle_ = do
139 let ref = haBuffer handle_
140 buf <- readIORef ref
141 hGetLineBufferedLoop handle_ ref buf []
142
143
144 hGetLineBufferedLoop handle_ ref
145 buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
146 let
147 -- find the end-of-line character, if there is one
148 loop raw r
149 | r == w = return (False, w)
150 | otherwise = do
151 (c,r') <- readCharFromBuffer raw r
152 if c == '\n'
153 then return (True, r) -- NB. not r': don't include the '\n'
154 else loop raw r'
155 in do
156 (eol, off) <- loop raw r
157
158 #ifdef DEBUG_DUMP
159 puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
160 #endif
161
162 xs <- unpack raw r off
163 if eol
164 then do if w == off + 1
165 then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
166 else writeIORef ref buf{ bufRPtr = off + 1 }
167 return (concat (reverse (xs:xss)))
168 else do
169 maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
170 buf{ bufWPtr=0, bufRPtr=0 }
171 case maybe_buf of
172 -- Nothing indicates we caught an EOF, and we may have a
173 -- partial line to return.
174 Nothing -> let str = concat (reverse (xs:xss)) in
175 if not (null str)
176 then return str
177 else ioe_EOF
178 Just new_buf ->
179 hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
180
181
182 maybeFillReadBuffer fd is_line is_stream buf
183 = catch
184 (do buf <- fillReadBuffer fd is_line is_stream buf
185 return (Just buf)
186 )
187 (\e -> do if isEOFError e
188 then return Nothing
189 else throw e)
190
191
192 unpack :: RawBuffer -> Int -> Int -> IO [Char]
193 unpack buf r 0 = return ""
194 unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
195 where
196 unpack acc i s
197 | i <# r = (# s, acc #)
198 | otherwise =
199 case readCharArray# buf i s of
200 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
201
202
203 hGetLineUnBuffered :: Handle -> IO String
204 hGetLineUnBuffered h = do
205 c <- hGetChar h
206 if c == '\n' then
207 return ""
208 else do
209 l <- getRest
210 return (c:l)
211 where
212 getRest = do
213 c <-
214 catch
215 (hGetChar h)
216 (\ err -> do
217 if isEOFError err then
218 return '\n'
219 else
220 ioError err)
221 if c == '\n' then
222 return ""
223 else do
224 s <- getRest
225 return (c:s)
226
227 -- -----------------------------------------------------------------------------
228 -- hGetContents
229
230 -- hGetContents returns the list of characters corresponding to the
231 -- unread portion of the channel or file managed by the handle, which
232 -- is made semi-closed.
233
234 -- hGetContents on a DuplexHandle only affects the read side: you can
235 -- carry on writing to it afterwards.
236
237 hGetContents :: Handle -> IO String
238 hGetContents handle =
239 withHandle "hGetContents" handle $ \handle_ ->
240 case haType handle_ of
241 ClosedHandle -> ioe_closedHandle
242 SemiClosedHandle -> ioe_closedHandle
243 AppendHandle -> ioe_notReadable
244 WriteHandle -> ioe_notReadable
245 _ -> do xs <- lazyRead handle
246 return (handle_{ haType=SemiClosedHandle}, xs )
247
248 -- Note that someone may close the semi-closed handle (or change its
249 -- buffering), so each time these lazy read functions are pulled on,
250 -- they have to check whether the handle has indeed been closed.
251
252 lazyRead :: Handle -> IO String
253 lazyRead handle =
254 unsafeInterleaveIO $
255 withHandle "lazyRead" handle $ \ handle_ -> do
256 case haType handle_ of
257 ClosedHandle -> return (handle_, "")
258 SemiClosedHandle -> lazyRead' handle handle_
259 _ -> ioException
260 (IOError (Just handle) IllegalOperation "lazyRead"
261 "illegal handle type" Nothing)
262
263 lazyRead' h handle_ = do
264 let ref = haBuffer handle_
265 fd = haFD handle_
266
267 -- even a NoBuffering handle can have a char in the buffer...
268 -- (see hLookAhead)
269 buf <- readIORef ref
270 if not (bufferEmpty buf)
271 then lazyReadHaveBuffer h handle_ fd ref buf
272 else do
273
274 case haBufferMode handle_ of
275 NoBuffering -> do
276 -- make use of the minimal buffer we already have
277 let raw = bufBuf buf
278 r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
279 (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
280 (threadWaitRead fd)
281 if r == 0
282 then do handle_ <- hClose_help handle_
283 return (handle_, "")
284 else do (c,_) <- readCharFromBuffer raw 0
285 rest <- lazyRead h
286 return (handle_, c : rest)
287
288 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
289 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
290
291 -- we never want to block during the read, so we call fillReadBuffer with
292 -- is_line==True, which tells it to "just read what there is".
293 lazyReadBuffered h handle_ fd ref buf = do
294 catch
295 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
296 lazyReadHaveBuffer h handle_ fd ref buf
297 )
298 -- all I/O errors are discarded. Additionally, we close the handle.
299 (\e -> do handle_ <- hClose_help handle_
300 return (handle_, "")
301 )
302
303 lazyReadHaveBuffer h handle_ fd ref buf = do
304 more <- lazyRead h
305 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
306 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
307 return (handle_, s)
308
309
310 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
311 unpackAcc buf r 0 acc = return ""
312 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
313 where
314 unpack acc i s
315 | i <# r = (# s, acc #)
316 | otherwise =
317 case readCharArray# buf i s of
318 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
319
320 -- ---------------------------------------------------------------------------
321 -- hPutChar
322
323 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
324 -- managed by `hdl'. Characters may be buffered if buffering is
325 -- enabled for `hdl'.
326
327 hPutChar :: Handle -> Char -> IO ()
328 hPutChar handle c =
329 c `seq` do -- must evaluate c before grabbing the handle lock
330 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
331 let fd = haFD handle_
332 case haBufferMode handle_ of
333 LineBuffering -> hPutcBuffered handle_ True c
334 BlockBuffering _ -> hPutcBuffered handle_ False c
335 NoBuffering ->
336 withObject (castCharToCChar c) $ \buf ->
337 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
338 (write_off (fromIntegral fd) (haIsStream handle_) buf 0 1)
339 (threadWaitWrite fd)
340
341
342 hPutcBuffered handle_ is_line c = do
343 let ref = haBuffer handle_
344 buf <- readIORef ref
345 let w = bufWPtr buf
346 w' <- writeCharIntoBuffer (bufBuf buf) w c
347 let new_buf = buf{ bufWPtr = w' }
348 if bufferFull new_buf || is_line && c == '\n'
349 then do
350 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
351 writeIORef ref flushed_buf
352 else do
353 writeIORef ref new_buf
354
355
356 hPutChars :: Handle -> [Char] -> IO ()
357 hPutChars handle [] = return ()
358 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
359
360 -- ---------------------------------------------------------------------------
361 -- hPutStr
362
363 -- `hPutStr hdl s' writes the string `s' to the file or
364 -- hannel managed by `hdl', buffering the output if needs be.
365
366 -- We go to some trouble to avoid keeping the handle locked while we're
367 -- evaluating the string argument to hPutStr, in case doing so triggers another
368 -- I/O operation on the same handle which would lead to deadlock. The classic
369 -- case is
370 --
371 -- putStr (trace "hello" "world")
372 --
373 -- so the basic scheme is this:
374 --
375 -- * copy the string into a fresh buffer,
376 -- * "commit" the buffer to the handle.
377 --
378 -- Committing may involve simply copying the contents of the new
379 -- buffer into the handle's buffer, flushing one or both buffers, or
380 -- maybe just swapping the buffers over (if the handle's buffer was
381 -- empty). See commitBuffer below.
382
383 hPutStr :: Handle -> String -> IO ()
384 hPutStr handle str = do
385 buffer_mode <- wantWritableHandle "hPutStr" handle
386 (\ handle_ -> do getSpareBuffer handle_)
387 case buffer_mode of
388 (NoBuffering, _) -> do
389 hPutChars handle str -- v. slow, but we don't care
390 (LineBuffering, buf) -> do
391 writeLines handle buf str
392 (BlockBuffering _, buf) -> do
393 writeBlocks handle buf str
394
395
396 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
397 getSpareBuffer Handle__{haBuffer=ref,
398 haBuffers=spare_ref,
399 haBufferMode=mode}
400 = do
401 case mode of
402 NoBuffering -> return (mode, error "no buffer!")
403 _ -> do
404 bufs <- readIORef spare_ref
405 buf <- readIORef ref
406 case bufs of
407 BufferListCons b rest -> do
408 writeIORef spare_ref rest
409 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
410 BufferListNil -> do
411 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
412 return (mode, new_buf)
413
414
415 writeLines :: Handle -> Buffer -> String -> IO ()
416 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
417 let
418 shoveString :: Int -> [Char] -> IO ()
419 -- check n == len first, to ensure that shoveString is strict in n.
420 shoveString n cs | n == len = do
421 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
422 writeLines hdl new_buf cs
423 shoveString n [] = do
424 commitBuffer hdl raw len n False{-no flush-} True{-release-}
425 return ()
426 shoveString n (c:cs) = do
427 n' <- writeCharIntoBuffer raw n c
428 if (c == '\n')
429 then do
430 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
431 writeLines hdl new_buf cs
432 else
433 shoveString n' cs
434 in
435 shoveString 0 s
436
437 writeBlocks :: Handle -> Buffer -> String -> IO ()
438 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
439 let
440 shoveString :: Int -> [Char] -> IO ()
441 -- check n == len first, to ensure that shoveString is strict in n.
442 shoveString n cs | n == len = do
443 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
444 writeBlocks hdl new_buf cs
445 shoveString n [] = do
446 commitBuffer hdl raw len n False{-no flush-} True{-release-}
447 return ()
448 shoveString n (c:cs) = do
449 n' <- writeCharIntoBuffer raw n c
450 shoveString n' cs
451 in
452 shoveString 0 s
453
454 -- -----------------------------------------------------------------------------
455 -- commitBuffer handle buf sz count flush release
456 --
457 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
458 -- 'count' bytes of data) to handle (handle must be block or line buffered).
459 --
460 -- Implementation:
461 --
462 -- for block/line buffering,
463 -- 1. If there isn't room in the handle buffer, flush the handle
464 -- buffer.
465 --
466 -- 2. If the handle buffer is empty,
467 -- if flush,
468 -- then write buf directly to the device.
469 -- else swap the handle buffer with buf.
470 --
471 -- 3. If the handle buffer is non-empty, copy buf into the
472 -- handle buffer. Then, if flush != 0, flush
473 -- the buffer.
474
475 commitBuffer
476 :: Handle -- handle to commit to
477 -> RawBuffer -> Int -- address and size (in bytes) of buffer
478 -> Int -- number of bytes of data in buffer
479 -> Bool -- True <=> flush the handle afterward
480 -> Bool -- release the buffer?
481 -> IO Buffer
482
483 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
484 wantWritableHandle "commitAndReleaseBuffer" hdl $
485 commitBuffer' hdl raw sz count flush release
486
487 -- Explicitly lambda-lift this function to subvert GHC's full laziness
488 -- optimisations, which otherwise tends to float out subexpressions
489 -- past the \handle, which is really a pessimisation in this case because
490 -- that lambda is a one-shot lambda.
491 --
492 -- Don't forget to export the function, to stop it being inlined too
493 -- (this appears to be better than NOINLINE, because the strictness
494 -- analyser still gets to worker-wrapper it).
495 --
496 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
497 --
498 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
499 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
500
501 #ifdef DEBUG_DUMP
502 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
503 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
504 #endif
505
506 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
507 <- readIORef ref
508
509 buf_ret <-
510 -- enough room in handle buffer?
511 if (not flush && (size - w > count))
512 -- The > is to be sure that we never exactly fill
513 -- up the buffer, which would require a flush. So
514 -- if copying the new data into the buffer would
515 -- make the buffer full, we just flush the existing
516 -- buffer and the new data immediately, rather than
517 -- copying before flushing.
518
519 -- not flushing, and there's enough room in the buffer:
520 -- just copy the data in and update bufWPtr.
521 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
522 writeIORef ref old_buf{ bufWPtr = w + count }
523 return (newEmptyBuffer raw WriteBuffer sz)
524
525 -- else, we have to flush
526 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
527
528 let this_buf =
529 Buffer{ bufBuf=raw, bufState=WriteBuffer,
530 bufRPtr=0, bufWPtr=count, bufSize=sz }
531
532 -- if: (a) we don't have to flush, and
533 -- (b) size(new buffer) == size(old buffer), and
534 -- (c) new buffer is not full,
535 -- we can just just swap them over...
536 if (not flush && sz == size && count /= sz)
537 then do
538 writeIORef ref this_buf
539 return flushed_buf
540
541 -- otherwise, we have to flush the new data too,
542 -- and start with a fresh buffer
543 else do
544 flushWriteBuffer fd (haIsStream handle_) this_buf
545 writeIORef ref flushed_buf
546 -- if the sizes were different, then allocate
547 -- a new buffer of the correct size.
548 if sz == size
549 then return (newEmptyBuffer raw WriteBuffer sz)
550 else allocateBuffer size WriteBuffer
551
552 -- release the buffer if necessary
553 case buf_ret of
554 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
555 if release && buf_ret_sz == size
556 then do
557 spare_bufs <- readIORef spare_buf_ref
558 writeIORef spare_buf_ref
559 (BufferListCons buf_ret_raw spare_bufs)
560 return buf_ret
561 else
562 return buf_ret
563
564 -- ---------------------------------------------------------------------------
565 -- Reading/writing sequences of bytes.
566
567 {-
568 Semantics of hGetBuf:
569
570 - hGetBuf reads data into the buffer until either
571
572 (a) EOF is reached
573 (b) the buffer is full
574
575 It returns the amount of data actually read. This may
576 be zero in case (a). hGetBuf never raises
577 an EOF exception, it always returns zero instead.
578
579 If the handle is a pipe or socket, and the writing end
580 is closed, hGetBuf will behave as for condition (a).
581
582 Semantics of hPutBuf:
583
584 - hPutBuf writes data from the buffer to the handle
585 until the buffer is empty. It returns ().
586
587 If the handle is a pipe or socket, and the reading end is
588 closed, hPutBuf will raise a ResourceVanished exception.
589 (If this is a POSIX system, and the program has not
590 asked to ignore SIGPIPE, then a SIGPIPE may be delivered
591 instead, whose default action is to terminate the program).
592 -}
593
594 -- ---------------------------------------------------------------------------
595 -- hPutBuf
596
597 hPutBuf :: Handle -- handle to write to
598 -> Ptr a -- address of buffer
599 -> Int -- number of bytes of data in buffer
600 -> IO ()
601 hPutBuf handle ptr count
602 | count <= 0 = illegalBufferSize handle "hPutBuf" count
603 | otherwise =
604 wantWritableHandle "hPutBuf" handle $
605 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
606
607 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
608 <- readIORef ref
609
610 -- enough room in handle buffer?
611 if (size - w > count)
612 -- There's enough room in the buffer:
613 -- just copy the data in and update bufWPtr.
614 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
615 writeIORef ref old_buf{ bufWPtr = w + count }
616 return ()
617
618 -- else, we have to flush
619 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
620 writeIORef ref flushed_buf
621 -- ToDo: should just memcpy instead of writing if possible
622 writeChunk fd ptr count
623
624 writeChunk :: FD -> Ptr a -> Int -> IO ()
625 writeChunk fd ptr bytes = loop 0 bytes
626 where
627 loop :: Int -> Int -> IO ()
628 loop _ bytes | bytes <= 0 = return ()
629 loop off bytes = do
630 r <- fromIntegral `liftM`
631 throwErrnoIfMinus1RetryMayBlock "writeChunk"
632 (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
633 (threadWaitWrite fd)
634 -- write can't return 0
635 loop (off + r) (bytes - r)
636
637 -- ---------------------------------------------------------------------------
638 -- hGetBuf
639
640 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
641 hGetBuf handle ptr count
642 | count <= 0 = illegalBufferSize handle "hGetBuf" count
643 | otherwise =
644 wantReadableHandle "hGetBuf" handle $
645 \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
646 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
647 if bufferEmpty buf
648 then readChunk fd ptr count
649 else do
650 let avail = w - r
651 copied <- if (count >= avail)
652 then do
653 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
654 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
655 return avail
656 else do
657 memcpy_ptr_baoff ptr raw r (fromIntegral count)
658 writeIORef ref buf{ bufRPtr = r + count }
659 return count
660
661 let remaining = count - copied
662 if remaining > 0
663 then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
664 return (rest + copied)
665 else return count
666
667 readChunk :: FD -> Ptr a -> Int -> IO Int
668 readChunk fd ptr bytes = loop 0 bytes
669 where
670 loop :: Int -> Int -> IO Int
671 loop off bytes | bytes <= 0 = return off
672 loop off bytes = do
673 r <- fromIntegral `liftM`
674 throwErrnoIfMinus1RetryMayBlock "readChunk"
675 (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
676 (threadWaitRead fd)
677 if r == 0
678 then return off
679 else loop (off + r) (bytes - r)
680
681 slurpFile :: FilePath -> IO (Ptr (), Int)
682 slurpFile fname = do
683 handle <- openFile fname ReadMode
684 sz <- hFileSize handle
685 if sz > fromIntegral (maxBound::Int) then
686 ioError (userError "slurpFile: file too big")
687 else do
688 let sz_i = fromIntegral sz
689 chunk <- mallocBytes sz_i
690 r <- hGetBuf handle chunk sz_i
691 hClose handle
692 return (chunk, r)
693
694 -- ---------------------------------------------------------------------------
695 -- memcpy wrappers
696
697 foreign import ccall unsafe "__hscore_memcpy_src_off"
698 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
699 foreign import ccall unsafe "__hscore_memcpy_src_off"
700 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
701 foreign import ccall unsafe "__hscore_memcpy_dst_off"
702 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
703 foreign import ccall unsafe "__hscore_memcpy_dst_off"
704 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
705
706 -----------------------------------------------------------------------------
707 -- Internal Utils
708
709 illegalBufferSize :: Handle -> String -> Int -> IO a
710 illegalBufferSize handle fn (sz :: Int) =
711 ioException (IOError (Just handle)
712 InvalidArgument fn
713 ("illegal buffer size " ++ showsPrec 9 sz [])
714 Nothing)