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