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