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