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