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