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