914a55a9178a8378fcd3e5b36e72461c27e92ce2
[packages/random.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 import System.Posix.Internals
37
38 import GHC.Enum
39 import GHC.Base
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 True (haIsStream handle_) buf
102 -- ^^^^
103 -- don't wait for a completely full buffer.
104 hGetcBuffered fd ref new_buf
105 NoBuffering -> do
106 -- make use of the minimal buffer we already have
107 let raw = bufBuf buf
108 r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
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 <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
292 if r == 0
293 then do handle_ <- hClose_help handle_
294 return (handle_, "")
295 else do (c,_) <- readCharFromBuffer raw 0
296 rest <- lazyRead h
297 return (handle_, c : rest)
298
299 LineBuffering -> lazyReadBuffered h handle_ fd ref buf
300 BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
301
302 -- we never want to block during the read, so we call fillReadBuffer with
303 -- is_line==True, which tells it to "just read what there is".
304 lazyReadBuffered h handle_ fd ref buf = do
305 catch
306 (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
307 lazyReadHaveBuffer h handle_ fd ref buf
308 )
309 -- all I/O errors are discarded. Additionally, we close the handle.
310 (\e -> do handle_ <- hClose_help handle_
311 return (handle_, "")
312 )
313
314 lazyReadHaveBuffer h handle_ fd ref buf = do
315 more <- lazyRead h
316 writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
317 s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
318 return (handle_, s)
319
320
321 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
322 unpackAcc buf r 0 acc = return acc
323 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
324 where
325 unpack acc i s
326 | i <# r = (# s, acc #)
327 | otherwise =
328 case readCharArray# buf i s of
329 (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
330
331 -- ---------------------------------------------------------------------------
332 -- hPutChar
333
334 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
335 -- managed by `hdl'. Characters may be buffered if buffering is
336 -- enabled for `hdl'.
337
338 hPutChar :: Handle -> Char -> IO ()
339 hPutChar handle c =
340 c `seq` do -- must evaluate c before grabbing the handle lock
341 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
342 let fd = haFD handle_
343 case haBufferMode handle_ of
344 LineBuffering -> hPutcBuffered handle_ True c
345 BlockBuffering _ -> hPutcBuffered handle_ False c
346 NoBuffering ->
347 withObject (castCharToCChar c) $ \buf -> do
348 writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
349 return ()
350
351 hPutcBuffered handle_ is_line c = do
352 let ref = haBuffer handle_
353 buf <- readIORef ref
354 let w = bufWPtr buf
355 w' <- writeCharIntoBuffer (bufBuf buf) w c
356 let new_buf = buf{ bufWPtr = w' }
357 if bufferFull new_buf || is_line && c == '\n'
358 then do
359 flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
360 writeIORef ref flushed_buf
361 else do
362 writeIORef ref new_buf
363
364
365 hPutChars :: Handle -> [Char] -> IO ()
366 hPutChars handle [] = return ()
367 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
368
369 -- ---------------------------------------------------------------------------
370 -- hPutStr
371
372 -- `hPutStr hdl s' writes the string `s' to the file or
373 -- hannel managed by `hdl', buffering the output if needs be.
374
375 -- We go to some trouble to avoid keeping the handle locked while we're
376 -- evaluating the string argument to hPutStr, in case doing so triggers another
377 -- I/O operation on the same handle which would lead to deadlock. The classic
378 -- case is
379 --
380 -- putStr (trace "hello" "world")
381 --
382 -- so the basic scheme is this:
383 --
384 -- * copy the string into a fresh buffer,
385 -- * "commit" the buffer to the handle.
386 --
387 -- Committing may involve simply copying the contents of the new
388 -- buffer into the handle's buffer, flushing one or both buffers, or
389 -- maybe just swapping the buffers over (if the handle's buffer was
390 -- empty). See commitBuffer below.
391
392 hPutStr :: Handle -> String -> IO ()
393 hPutStr handle str = do
394 buffer_mode <- wantWritableHandle "hPutStr" handle
395 (\ handle_ -> do getSpareBuffer handle_)
396 case buffer_mode of
397 (NoBuffering, _) -> do
398 hPutChars handle str -- v. slow, but we don't care
399 (LineBuffering, buf) -> do
400 writeLines handle buf str
401 (BlockBuffering _, buf) -> do
402 writeBlocks handle buf str
403
404
405 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
406 getSpareBuffer Handle__{haBuffer=ref,
407 haBuffers=spare_ref,
408 haBufferMode=mode}
409 = do
410 case mode of
411 NoBuffering -> return (mode, error "no buffer!")
412 _ -> do
413 bufs <- readIORef spare_ref
414 buf <- readIORef ref
415 case bufs of
416 BufferListCons b rest -> do
417 writeIORef spare_ref rest
418 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
419 BufferListNil -> do
420 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
421 return (mode, new_buf)
422
423
424 writeLines :: Handle -> Buffer -> String -> IO ()
425 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
426 let
427 shoveString :: Int -> [Char] -> IO ()
428 -- check n == len first, to ensure that shoveString is strict in n.
429 shoveString n cs | n == len = do
430 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
431 writeLines hdl new_buf cs
432 shoveString n [] = do
433 commitBuffer hdl raw len n False{-no flush-} True{-release-}
434 return ()
435 shoveString n (c:cs) = do
436 n' <- writeCharIntoBuffer raw n c
437 if (c == '\n')
438 then do
439 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
440 writeLines hdl new_buf cs
441 else
442 shoveString n' cs
443 in
444 shoveString 0 s
445
446 writeBlocks :: Handle -> Buffer -> String -> IO ()
447 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
448 let
449 shoveString :: Int -> [Char] -> IO ()
450 -- check n == len first, to ensure that shoveString is strict in n.
451 shoveString n cs | n == len = do
452 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
453 writeBlocks hdl new_buf cs
454 shoveString n [] = do
455 commitBuffer hdl raw len n False{-no flush-} True{-release-}
456 return ()
457 shoveString n (c:cs) = do
458 n' <- writeCharIntoBuffer raw n c
459 shoveString n' cs
460 in
461 shoveString 0 s
462
463 -- -----------------------------------------------------------------------------
464 -- commitBuffer handle buf sz count flush release
465 --
466 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
467 -- 'count' bytes of data) to handle (handle must be block or line buffered).
468 --
469 -- Implementation:
470 --
471 -- for block/line buffering,
472 -- 1. If there isn't room in the handle buffer, flush the handle
473 -- buffer.
474 --
475 -- 2. If the handle buffer is empty,
476 -- if flush,
477 -- then write buf directly to the device.
478 -- else swap the handle buffer with buf.
479 --
480 -- 3. If the handle buffer is non-empty, copy buf into the
481 -- handle buffer. Then, if flush != 0, flush
482 -- the buffer.
483
484 commitBuffer
485 :: Handle -- handle to commit to
486 -> RawBuffer -> Int -- address and size (in bytes) of buffer
487 -> Int -- number of bytes of data in buffer
488 -> Bool -- True <=> flush the handle afterward
489 -> Bool -- release the buffer?
490 -> IO Buffer
491
492 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
493 wantWritableHandle "commitAndReleaseBuffer" hdl $
494 commitBuffer' hdl raw sz count flush release
495
496 -- Explicitly lambda-lift this function to subvert GHC's full laziness
497 -- optimisations, which otherwise tends to float out subexpressions
498 -- past the \handle, which is really a pessimisation in this case because
499 -- that lambda is a one-shot lambda.
500 --
501 -- Don't forget to export the function, to stop it being inlined too
502 -- (this appears to be better than NOINLINE, because the strictness
503 -- analyser still gets to worker-wrapper it).
504 --
505 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
506 --
507 commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
508 handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
509
510 #ifdef DEBUG_DUMP
511 puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
512 ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
513 #endif
514
515 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
516 <- readIORef ref
517
518 buf_ret <-
519 -- enough room in handle buffer?
520 if (not flush && (size - w > count))
521 -- The > is to be sure that we never exactly fill
522 -- up the buffer, which would require a flush. So
523 -- if copying the new data into the buffer would
524 -- make the buffer full, we just flush the existing
525 -- buffer and the new data immediately, rather than
526 -- copying before flushing.
527
528 -- not flushing, and there's enough room in the buffer:
529 -- just copy the data in and update bufWPtr.
530 then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
531 writeIORef ref old_buf{ bufWPtr = w + count }
532 return (newEmptyBuffer raw WriteBuffer sz)
533
534 -- else, we have to flush
535 else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
536
537 let this_buf =
538 Buffer{ bufBuf=raw, bufState=WriteBuffer,
539 bufRPtr=0, bufWPtr=count, bufSize=sz }
540
541 -- if: (a) we don't have to flush, and
542 -- (b) size(new buffer) == size(old buffer), and
543 -- (c) new buffer is not full,
544 -- we can just just swap them over...
545 if (not flush && sz == size && count /= sz)
546 then do
547 writeIORef ref this_buf
548 return flushed_buf
549
550 -- otherwise, we have to flush the new data too,
551 -- and start with a fresh buffer
552 else do
553 flushWriteBuffer fd (haIsStream handle_) this_buf
554 writeIORef ref flushed_buf
555 -- if the sizes were different, then allocate
556 -- a new buffer of the correct size.
557 if sz == size
558 then return (newEmptyBuffer raw WriteBuffer sz)
559 else allocateBuffer size WriteBuffer
560
561 -- release the buffer if necessary
562 case buf_ret of
563 Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
564 if release && buf_ret_sz == size
565 then do
566 spare_bufs <- readIORef spare_buf_ref
567 writeIORef spare_buf_ref
568 (BufferListCons buf_ret_raw spare_bufs)
569 return buf_ret
570 else
571 return buf_ret
572
573 -- ---------------------------------------------------------------------------
574 -- Reading/writing sequences of bytes.
575
576 {-
577 Semantics of hGetBuf:
578
579 - hGetBuf reads data into the buffer until either
580
581 (a) EOF is reached
582 (b) the buffer is full
583
584 It returns the amount of data actually read. This may
585 be zero in case (a). hGetBuf never raises
586 an EOF exception, it always returns zero instead.
587
588 If the handle is a pipe or socket, and the writing end
589 is closed, hGetBuf will behave as for condition (a).
590
591 Semantics of hPutBuf:
592
593 - hPutBuf writes data from the buffer to the handle
594 until the buffer is empty. It returns ().
595
596 If the handle is a pipe or socket, and the reading end is
597 closed, hPutBuf will raise a ResourceVanished exception.
598 (If this is a POSIX system, and the program has not
599 asked to ignore SIGPIPE, then a SIGPIPE may be delivered
600 instead, whose default action is to terminate the program).
601 -}
602
603 -- ---------------------------------------------------------------------------
604 -- hPutBuf
605
606 hPutBuf :: Handle -- handle to write to
607 -> Ptr a -- address of buffer
608 -> Int -- number of bytes of data in buffer
609 -> IO ()
610 hPutBuf handle ptr count
611 | count == 0 = return ()
612 | count < 0 = illegalBufferSize handle "hPutBuf" count
613 | otherwise =
614 wantWritableHandle "hPutBuf" handle $
615 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
616
617 old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
618 <- readIORef ref
619
620 -- enough room in handle buffer?
621 if (size - w > count)
622 -- There's enough room in the buffer:
623 -- just copy the data in and update bufWPtr.
624 then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
625 writeIORef ref old_buf{ bufWPtr = w + count }
626 return ()
627
628 -- else, we have to flush
629 else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
630 writeIORef ref flushed_buf
631 -- ToDo: should just memcpy instead of writing if possible
632 writeChunk fd is_stream (castPtr ptr) count
633
634 writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
635 writeChunk fd is_stream ptr bytes = loop 0 bytes
636 where
637 loop :: Int -> Int -> IO ()
638 loop _ bytes | bytes <= 0 = return ()
639 loop off bytes = do
640 r <- fromIntegral `liftM`
641 writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
642 off (fromIntegral bytes)
643 -- write can't return 0
644 loop (off + r) (bytes - r)
645
646 -- ---------------------------------------------------------------------------
647 -- hGetBuf
648
649 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
650 hGetBuf handle ptr count
651 | count == 0 = return 0
652 | count < 0 = illegalBufferSize handle "hGetBuf" count
653 | otherwise =
654 wantReadableHandle "hGetBuf" handle $
655 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
656 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
657 if bufferEmpty buf
658 then readChunk fd is_stream ptr count
659 else do
660 let avail = w - r
661 copied <- if (count >= avail)
662 then do
663 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
664 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
665 return avail
666 else do
667 memcpy_ptr_baoff ptr raw r (fromIntegral count)
668 writeIORef ref buf{ bufRPtr = r + count }
669 return count
670
671 let remaining = count - copied
672 if remaining > 0
673 then do rest <- readChunk fd is_stream (ptr `plusPtr` copied) remaining
674 return (rest + copied)
675 else return count
676
677 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
678 readChunk fd is_stream ptr bytes = loop 0 bytes
679 where
680 loop :: Int -> Int -> IO Int
681 loop off bytes | bytes <= 0 = return off
682 loop off bytes = do
683 r <- fromIntegral `liftM`
684 readRawBufferPtr "readChunk" (fromIntegral fd) is_stream
685 (castPtr ptr) off (fromIntegral bytes)
686 if r == 0
687 then return off
688 else loop (off + r) (bytes - r)
689
690 slurpFile :: FilePath -> IO (Ptr (), Int)
691 slurpFile fname = do
692 handle <- openFile fname ReadMode
693 sz <- hFileSize handle
694 if sz > fromIntegral (maxBound::Int) then
695 ioError (userError "slurpFile: file too big")
696 else do
697 let sz_i = fromIntegral sz
698 if sz_i == 0 then return (nullPtr, 0) else do
699 chunk <- mallocBytes sz_i
700 r <- hGetBuf handle chunk sz_i
701 hClose handle
702 return (chunk, r)
703
704 -- ---------------------------------------------------------------------------
705 -- memcpy wrappers
706
707 foreign import ccall unsafe "__hscore_memcpy_src_off"
708 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
709 foreign import ccall unsafe "__hscore_memcpy_src_off"
710 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
711 foreign import ccall unsafe "__hscore_memcpy_dst_off"
712 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
713 foreign import ccall unsafe "__hscore_memcpy_dst_off"
714 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
715
716 -----------------------------------------------------------------------------
717 -- Internal Utils
718
719 illegalBufferSize :: Handle -> String -> Int -> IO a
720 illegalBufferSize handle fn (sz :: Int) =
721 ioException (IOError (Just handle)
722 InvalidArgument fn
723 ("illegal buffer size " ++ showsPrec 9 sz [])
724 Nothing)