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