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