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