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