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