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