[project @ 2003-12-23 12:35:34 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 buf' -> do
783 writeIORef ref 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 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
801 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
802 let remaining = count - avail
803 so_far' = so_far + avail
804 ptr' = ptr `plusPtr` avail
805
806 if remaining < sz
807 then bufRead fd ref is_stream ptr' so_far' remaining
808 else do
809
810 rest <- readChunk fd is_stream ptr' remaining
811 return (so_far' + rest)
812
813 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
814 readChunk fd is_stream ptr bytes = loop 0 bytes
815 where
816 loop :: Int -> Int -> IO Int
817 loop off bytes | bytes <= 0 = return off
818 loop off bytes = do
819 r <- fromIntegral `liftM`
820 readRawBufferPtr "readChunk" (fromIntegral fd) is_stream
821 (castPtr ptr) off (fromIntegral bytes)
822 if r == 0
823 then return off
824 else loop (off + r) (bytes - r)
825
826
827 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
828 -- into the buffer @buf@ until either EOF is reached, or
829 -- @count@ 8-bit bytes have been read, or there is no more data available
830 -- to read immediately.
831 --
832 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
833 -- never block waiting for data to become available, instead it returns
834 -- only whatever data is available. To wait for data to arrive before
835 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
836 --
837 -- If the handle is a pipe or socket, and the writing end
838 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
839 --
840 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
841 hGetBufNonBlocking h ptr count
842 | count == 0 = return 0
843 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
844 | otherwise =
845 wantReadableHandle "hGetBufNonBlocking" h $
846 \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
847 bufReadNonBlocking fd ref is_stream ptr 0 count
848
849 bufReadNonBlocking fd ref is_stream ptr so_far count =
850 seq fd $ seq so_far $ seq count $ do -- strictness hack
851 buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
852 if bufferEmpty buf
853 then if count > sz -- large read?
854 then do rest <- readChunkNonBlocking fd is_stream ptr count
855 return (so_far + rest)
856 else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
857 case buf' of { Buffer{ bufWPtr=w } ->
858 if (w == 0)
859 then return so_far
860 else do writeIORef ref buf'
861 bufReadNonBlocking fd ref is_stream ptr
862 so_far (min count w)
863 -- NOTE: new count is 'min count w'
864 -- so we will just copy the contents of the
865 -- buffer in the recursive call, and not
866 -- loop again.
867 }
868 else do
869 let avail = w - r
870 if (count == avail)
871 then do
872 memcpy_ptr_baoff ptr raw r (fromIntegral count)
873 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
874 return (so_far + count)
875 else do
876 if (count < avail)
877 then do
878 memcpy_ptr_baoff ptr raw r (fromIntegral count)
879 writeIORef ref buf{ bufRPtr = r + count }
880 return (so_far + count)
881 else do
882
883 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
884 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
885 let remaining = count - avail
886 so_far' = so_far + avail
887 ptr' = ptr `plusPtr` avail
888
889 -- we haven't attempted to read anything yet if we get to here.
890 if remaining < sz
891 then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
892 else do
893
894 rest <- readChunkNonBlocking fd is_stream ptr' remaining
895 return (so_far' + rest)
896
897
898 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
899 readChunkNonBlocking fd is_stream ptr bytes = do
900 #ifndef mingw32_TARGET_OS
901 ssize <- c_read (fromIntegral fd) (castPtr ptr) (fromIntegral bytes)
902 let r = fromIntegral ssize :: Int
903 if (r == -1)
904 then do errno <- getErrno
905 if (errno == eAGAIN || errno == eWOULDBLOCK)
906 then return 0
907 else throwErrno "readChunk"
908 else return r
909 #else
910 (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream)
911 (fromIntegral bytes) ptr
912 let r = fromIntegral ssize :: Int
913 if r == (-1)
914 then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
915 else return r
916 #endif
917
918 slurpFile :: FilePath -> IO (Ptr (), Int)
919 slurpFile fname = do
920 handle <- openFile fname ReadMode
921 sz <- hFileSize handle
922 if sz > fromIntegral (maxBound::Int) then
923 ioError (userError "slurpFile: file too big")
924 else do
925 let sz_i = fromIntegral sz
926 if sz_i == 0 then return (nullPtr, 0) else do
927 chunk <- mallocBytes sz_i
928 r <- hGetBuf handle chunk sz_i
929 hClose handle
930 return (chunk, r)
931
932 -- ---------------------------------------------------------------------------
933 -- memcpy wrappers
934
935 foreign import ccall unsafe "__hscore_memcpy_src_off"
936 memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
937 foreign import ccall unsafe "__hscore_memcpy_src_off"
938 memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
939 foreign import ccall unsafe "__hscore_memcpy_dst_off"
940 memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
941 foreign import ccall unsafe "__hscore_memcpy_dst_off"
942 memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
943
944 -----------------------------------------------------------------------------
945 -- Internal Utils
946
947 illegalBufferSize :: Handle -> String -> Int -> IO a
948 illegalBufferSize handle fn (sz :: Int) =
949 ioException (IOError (Just handle)
950 InvalidArgument fn
951 ("illegal buffer size " ++ showsPrec 9 sz [])
952 Nothing)