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