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