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