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