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