[project @ 2001-06-28 14:15:04 by simonmar]
[packages/pretty.git] / GHC / IO.hsc
1 {-# OPTIONS -fno-implicit-prelude #-}
2
3 #undef DEBUG_DUMP
4
5 -- -----------------------------------------------------------------------------
6 -- $Id: IO.hsc,v 1.1 2001/06/28 14:15:03 simonmar Exp $
7 --
8 -- (c) The University of Glasgow, 1992-2001
9 --
10 -- Module GHC.IO
11
12 -- This module defines all basic IO operations.
13 -- These are needed for the IO operations exported by Prelude,
14 -- but as it happens they also do everything required by library
15 -- module IO.
16
17 module GHC.IO where
18
19 #include "HsCore.h"
20 #include "GHC/Handle_hsc.h"
21
22 import Foreign
23 import Foreign.C
24
25 import Data.Maybe
26 import Control.Monad
27
28 import GHC.ByteArr
29 import GHC.Enum
30 import GHC.Base
31 import GHC.Posix
32 import GHC.IOBase
33 import GHC.Handle       -- much of the real stuff is in here
34 import GHC.Real
35 import GHC.Num
36 import GHC.Show
37 import GHC.List
38 import GHC.Exception    ( ioError, catch, throw )
39 import GHC.Conc
40
41 -- ---------------------------------------------------------------------------
42 -- Simple input operations
43
44 -- Computation "hReady hdl" indicates whether at least
45 -- one item is available for input from handle "hdl".
46
47 -- If hWaitForInput finds anything in the Handle's buffer, it
48 -- immediately returns.  If not, it tries to read from the underlying
49 -- OS handle. Notice that for buffered Handles connected to terminals
50 -- this means waiting until a complete line is available.
51
52 hWaitForInput :: Handle -> Int -> IO Bool
53 hWaitForInput h msecs = do
54   wantReadableHandle "hReady" h $ \ handle_ -> do
55   let ref = haBuffer handle_
56   buf <- readIORef ref
57
58   if not (bufferEmpty buf)
59         then return True
60         else do
61
62   r <- throwErrnoIfMinus1Retry "hReady"
63           (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
64   return (r /= 0)
65
66 foreign import "inputReady" 
67   inputReady :: CInt -> CInt -> IO CInt
68
69 -- ---------------------------------------------------------------------------
70 -- hGetChar
71
72 -- hGetChar reads the next character from a handle,
73 -- blocking until a character is available.
74
75 hGetChar :: Handle -> IO Char
76 hGetChar handle =
77   wantReadableHandle "hGetChar" handle $ \handle_ -> do
78
79   let fd = haFD handle_
80       ref = haBuffer handle_
81
82   buf <- readIORef ref
83   if not (bufferEmpty buf)
84         then hGetcBuffered fd ref buf
85         else do
86
87   -- buffer is empty.
88   case haBufferMode handle_ of
89     LineBuffering    -> do
90         new_buf <- fillReadBuffer fd True buf
91         hGetcBuffered fd ref new_buf
92     BlockBuffering _ -> do
93         new_buf <- fillReadBuffer fd False buf
94         hGetcBuffered fd ref new_buf
95     NoBuffering -> do
96         -- make use of the minimal buffer we already have
97         let raw = bufBuf buf
98         r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
99                 (read_off (fromIntegral fd) raw 0 1)
100                 (threadWaitRead fd)
101         if r == 0
102            then ioe_EOF
103            else do (c,_) <- readCharFromBuffer raw 0
104                    return c
105
106 hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
107  = do (c,r) <- readCharFromBuffer b r
108       let new_buf | r == w    = buf{ bufRPtr=0, bufWPtr=0 }
109                   | otherwise = buf{ bufRPtr=r }
110       writeIORef ref new_buf
111       return c
112
113 -- ---------------------------------------------------------------------------
114 -- hGetLine
115
116 -- If EOF is reached before EOL is encountered, ignore the EOF and
117 -- return the partial line. Next attempt at calling hGetLine on the
118 -- handle will yield an EOF IO exception though.
119
120 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
121 -- the duration.
122 hGetLine :: Handle -> IO String
123 hGetLine h = do
124   m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
125         case haBufferMode handle_ of
126            NoBuffering      -> return Nothing
127            LineBuffering    -> do
128               l <- hGetLineBuffered handle_
129               return (Just l)
130            BlockBuffering _ -> do 
131               l <- hGetLineBuffered handle_
132               return (Just l)
133   case m of
134         Nothing -> hGetLineUnBuffered h
135         Just l  -> return l
136
137
138 hGetLineBuffered handle_ = do
139   let ref = haBuffer handle_
140   buf <- readIORef ref
141   hGetLineBufferedLoop handle_ ref buf []
142
143
144 hGetLineBufferedLoop handle_ ref 
145         buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
146   let 
147         -- find the end-of-line character, if there is one
148         loop raw r
149            | r == w = return (False, w)
150            | otherwise =  do
151                 (c,r') <- readCharFromBuffer raw r
152                 if c == '\n' 
153                    then return (True, r) -- NB. not r': don't include the '\n'
154                    else loop raw r'
155   in do
156   (eol, off) <- loop raw r
157
158 #ifdef DEBUG_DUMP
159   puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
160 #endif
161
162   xs <- unpack raw r off
163   if eol
164         then do if w == off + 1
165                    then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
166                    else writeIORef ref buf{ bufRPtr = off + 1 }
167                 return (concat (reverse (xs:xss)))
168         else do
169              maybe_buf <- maybeFillReadBuffer (haFD handle_) True 
170                                 buf{ bufWPtr=0, bufRPtr=0 }
171              case maybe_buf of
172                 -- Nothing indicates we caught an EOF, and we may have a
173                 -- partial line to return.
174                 Nothing -> let str = concat (reverse (xs:xss)) in
175                            if not (null str)
176                               then return str
177                               else ioe_EOF
178                 Just new_buf -> 
179                      hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
180
181
182 unpack :: RawBuffer -> Int -> Int -> IO [Char]
183 unpack buf r 0   = return ""
184 unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
185    where
186     unpack acc i s
187      | i <## r  = (## s, acc ##)
188      | otherwise = 
189           case readCharArray## buf i s of
190             (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
191
192
193 hGetLineUnBuffered :: Handle -> IO String
194 hGetLineUnBuffered h = do
195   c <- hGetChar h
196   if c == '\n' then
197      return ""
198    else do
199     l <- getRest
200     return (c:l)
201  where
202   getRest = do
203     c <- 
204       catch 
205         (hGetChar h)
206         (\ err -> do
207           if isEOFError err then
208              return '\n'
209            else
210              ioError err)
211     if c == '\n' then
212        return ""
213      else do
214        s <- getRest
215        return (c:s)
216
217 -- -----------------------------------------------------------------------------
218 -- hGetContents
219
220 -- hGetContents returns the list of characters corresponding to the
221 -- unread portion of the channel or file managed by the handle, which
222 -- is made semi-closed.
223
224 -- hGetContents on a DuplexHandle only affects the read side: you can
225 -- carry on writing to it afterwards.
226
227 hGetContents :: Handle -> IO String
228 hGetContents handle@(DuplexHandle r w) 
229   = withHandle' "hGetContents" handle r (hGetContents' handle)
230 hGetContents handle@(FileHandle m) 
231   = withHandle' "hGetContents" handle m (hGetContents' handle)
232
233 hGetContents' handle handle_ = 
234     case haType handle_ of 
235       ClosedHandle         -> ioe_closedHandle
236       SemiClosedHandle     -> ioe_closedHandle
237       AppendHandle         -> ioe_notReadable
238       WriteHandle          -> ioe_notReadable
239       _ -> do xs <- lazyRead handle
240               return (handle_{ haType=SemiClosedHandle}, xs )
241
242 -- Note that someone may close the semi-closed handle (or change its
243 -- buffering), so each time these lazy read functions are pulled on,
244 -- they have to check whether the handle has indeed been closed.
245
246 lazyRead :: Handle -> IO String
247 lazyRead handle = 
248    unsafeInterleaveIO $
249         withHandle_ "lazyRead" handle $ \ handle_ -> do
250         case haType handle_ of
251           ClosedHandle     -> return ""
252           SemiClosedHandle -> lazyRead' handle handle_
253           _ -> ioException 
254                   (IOError (Just handle) IllegalOperation "lazyRead"
255                         "illegal handle type" Nothing)
256
257 lazyRead' h handle_ = do
258   let ref = haBuffer handle_
259       fd  = haFD handle_
260
261   -- even a NoBuffering handle can have a char in the buffer... 
262   -- (see hLookAhead)
263   buf <- readIORef ref
264   if not (bufferEmpty buf)
265         then lazyReadBuffered h fd ref buf
266         else do
267
268   case haBufferMode handle_ of
269      NoBuffering      -> do
270         -- make use of the minimal buffer we already have
271         let raw = bufBuf buf
272             fd  = haFD handle_
273         r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
274                 (read_off (fromIntegral fd) raw 0 1)
275                 (threadWaitRead fd)
276         if r == 0
277            then return ""
278            else do (c,_) <- readCharFromBuffer raw 0
279                    rest <- lazyRead h
280                    return (c : rest)
281
282      LineBuffering    -> lazyReadBuffered h fd ref buf
283      BlockBuffering _ -> lazyReadBuffered h fd ref buf
284
285 -- we never want to block during the read, so we call fillReadBuffer with
286 -- is_line==True, which tells it to "just read what there is".
287 lazyReadBuffered h fd ref buf = do
288    maybe_new_buf <- 
289         if bufferEmpty buf 
290            then maybeFillReadBuffer fd True buf
291            else return (Just buf)
292    case maybe_new_buf of
293         Nothing  -> return ""
294         Just buf -> do
295            more <- lazyRead h
296            writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
297            unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
298
299
300 maybeFillReadBuffer fd is_line buf
301   = catch 
302      (do buf <- fillReadBuffer fd is_line buf
303          return (Just buf)
304      )
305      (\e -> if isEOFError e 
306                 then return Nothing 
307                 else throw e)
308
309
310 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
311 unpackAcc buf r 0 acc  = return ""
312 unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
313    where
314     unpack acc i s
315      | i <## r  = (## s, acc ##)
316      | otherwise = 
317           case readCharArray## buf i s of
318             (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
319
320 -- ---------------------------------------------------------------------------
321 -- hPutChar
322
323 -- `hPutChar hdl ch' writes the character `ch' to the file or channel
324 -- managed by `hdl'.  Characters may be buffered if buffering is
325 -- enabled for `hdl'.
326
327 hPutChar :: Handle -> Char -> IO ()
328 hPutChar handle c = 
329     c `seq` do   -- must evaluate c before grabbing the handle lock
330     wantWritableHandle "hPutChar" handle $ \ handle_  -> do
331     let fd = haFD handle_
332     case haBufferMode handle_ of
333         LineBuffering    -> hPutcBuffered handle_ True  c
334         BlockBuffering _ -> hPutcBuffered handle_ False c
335         NoBuffering      ->
336                 withObject (castCharToCChar c) $ \buf ->
337                 throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
338                    (c_write (fromIntegral fd) buf 1)
339                    (threadWaitWrite fd)
340
341
342 hPutcBuffered handle_ is_line c = do
343   let ref = haBuffer handle_
344   buf <- readIORef ref
345   let w = bufWPtr buf
346   w'  <- writeCharIntoBuffer (bufBuf buf) w c
347   let new_buf = buf{ bufWPtr = w' }
348   if bufferFull new_buf || is_line && c == '\n'
349      then do 
350         flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
351         writeIORef ref flushed_buf
352      else do 
353         writeIORef ref new_buf
354
355
356 hPutChars :: Handle -> [Char] -> IO ()
357 hPutChars handle [] = return ()
358 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
359
360 -- ---------------------------------------------------------------------------
361 -- hPutStr
362
363 -- `hPutStr hdl s' writes the string `s' to the file or
364 -- hannel managed by `hdl', buffering the output if needs be.
365
366 -- We go to some trouble to avoid keeping the handle locked while we're
367 -- evaluating the string argument to hPutStr, in case doing so triggers another
368 -- I/O operation on the same handle which would lead to deadlock.  The classic
369 -- case is
370 --
371 --              putStr (trace "hello" "world")
372 --
373 -- so the basic scheme is this:
374 --
375 --      * copy the string into a fresh buffer,
376 --      * "commit" the buffer to the handle.
377 --
378 -- Committing may involve simply copying the contents of the new
379 -- buffer into the handle's buffer, flushing one or both buffers, or
380 -- maybe just swapping the buffers over (if the handle's buffer was
381 -- empty).  See commitBuffer below.
382
383 hPutStr :: Handle -> String -> IO ()
384 hPutStr handle str = do
385     buffer_mode <- wantWritableHandle "hPutStr" handle 
386                         (\ handle_ -> do getSpareBuffer handle_)
387     case buffer_mode of
388        (NoBuffering, _) -> do
389             hPutChars handle str        -- v. slow, but we don't care
390        (LineBuffering, buf) -> do
391             writeLines handle buf str
392        (BlockBuffering _, buf) -> do
393             writeBlocks handle buf str
394
395
396 getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
397 getSpareBuffer Handle__{haBuffer=ref, 
398                         haBuffers=spare_ref,
399                         haBufferMode=mode}
400  = do
401    case mode of
402      NoBuffering -> return (mode, error "no buffer!")
403      _ -> do
404           bufs <- readIORef spare_ref
405           buf  <- readIORef ref
406           case bufs of
407             BufferListCons b rest -> do
408                 writeIORef spare_ref rest
409                 return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
410             BufferListNil -> do
411                 new_buf <- allocateBuffer (bufSize buf) WriteBuffer
412                 return (mode, new_buf)
413
414
415 writeLines :: Handle -> Buffer -> String -> IO ()
416 writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
417   let
418    shoveString :: Int -> [Char] -> IO ()
419         -- check n == len first, to ensure that shoveString is strict in n.
420    shoveString n cs | n == len = do
421         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
422         writeBlocks hdl new_buf cs
423    shoveString n [] = do
424         commitBuffer hdl raw len n False{-no flush-} True{-release-}
425         return ()
426    shoveString n (c:cs) = do
427         n' <- writeCharIntoBuffer raw n c
428         shoveString n' cs
429   in
430   shoveString 0 s
431
432 writeBlocks :: Handle -> Buffer -> String -> IO ()
433 writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
434   let
435    shoveString :: Int -> [Char] -> IO ()
436         -- check n == len first, to ensure that shoveString is strict in n.
437    shoveString n cs | n == len = do
438         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
439         writeBlocks hdl new_buf cs
440    shoveString n [] = do
441         commitBuffer hdl raw len n False{-no flush-} True{-release-}
442         return ()
443    shoveString n (c:cs) = do
444         n' <- writeCharIntoBuffer raw n c
445         shoveString n' cs
446   in
447   shoveString 0 s
448
449 -- -----------------------------------------------------------------------------
450 -- commitBuffer handle buf sz count flush release
451 -- 
452 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
453 -- 'count' bytes of data) to handle (handle must be block or line buffered).
454 -- 
455 -- Implementation:
456 -- 
457 --    for block/line buffering,
458 --       1. If there isn't room in the handle buffer, flush the handle
459 --          buffer.
460 -- 
461 --       2. If the handle buffer is empty,
462 --               if flush, 
463 --                   then write buf directly to the device.
464 --                   else swap the handle buffer with buf.
465 -- 
466 --       3. If the handle buffer is non-empty, copy buf into the
467 --          handle buffer.  Then, if flush != 0, flush
468 --          the buffer.
469
470 commitBuffer
471         :: Handle                       -- handle to commit to
472         -> RawBuffer -> Int             -- address and size (in bytes) of buffer
473         -> Int                          -- number of bytes of data in buffer
474         -> Bool                         -- flush the handle afterward?
475         -> Bool                         -- release the buffer?
476         -> IO Buffer
477
478 commitBuffer hdl raw sz count flush release = do
479   wantWritableHandle "commitAndReleaseBuffer" hdl $ 
480     \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } -> do
481
482 #ifdef DEBUG_DUMP
483       puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
484             ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
485 #endif
486
487       old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
488           <- readIORef ref
489
490       buf_ret <-
491         -- enough room in handle buffer?
492          if (not flush && (size - w > count))
493                 -- The > is to be sure that we never exactly fill
494                 -- up the buffer, which would require a flush.  So
495                 -- if copying the new data into the buffer would
496                 -- make the buffer full, we just flush the existing
497                 -- buffer and the new data immediately, rather than
498                 -- copying before flushing.
499
500                 -- not flushing, and there's enough room in the buffer:
501                 -- just copy the data in and update bufWPtr.
502             then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
503                     writeIORef ref old_buf{ bufWPtr = w + count }
504                     return (newEmptyBuffer raw WriteBuffer sz)
505
506                 -- else, we have to flush
507             else do flushed_buf <- flushWriteBuffer fd old_buf
508
509                     let this_buf = 
510                             Buffer{ bufBuf=raw, bufState=WriteBuffer, 
511                                     bufRPtr=0, bufWPtr=count, bufSize=sz }
512
513                         -- if:  (a) we don't have to flush, and
514                         --      (b) size(new buffer) == size(old buffer), and
515                         --      (c) new buffer is not full,
516                         -- we can just just swap them over...
517                     if (not flush && sz == size && count /= sz)
518                         then do 
519                           writeIORef ref this_buf
520                           return flushed_buf                         
521
522                         -- otherwise, we have to flush the new data too,
523                         -- and start with a fresh buffer
524                         else do
525                           flushWriteBuffer fd this_buf
526                           writeIORef ref flushed_buf
527                             -- if the sizes were different, then allocate
528                             -- a new buffer of the correct size.
529                           if sz == size
530                              then return (newEmptyBuffer raw WriteBuffer sz)
531                              else allocateBuffer size WriteBuffer
532
533       -- release the buffer if necessary
534       if release && bufSize buf_ret == size
535          then do
536               spare_bufs <- readIORef spare_buf_ref
537               writeIORef spare_buf_ref 
538                 (BufferListCons (bufBuf buf_ret) spare_bufs)
539               return buf_ret
540          else
541               return buf_ret
542
543 -- ---------------------------------------------------------------------------
544 -- Reading/writing sequences of bytes.
545
546 {-
547 Semantics of hGetBuf:
548
549    - hGetBuf reads data into the buffer until either
550
551         (a) EOF is reached
552         (b) the buffer is full
553      
554      It returns the amount of data actually read.  This may
555      be zero in case (a).  hGetBuf never raises
556      an EOF exception, it always returns zero instead.
557
558      If the handle is a pipe or socket, and the writing end
559      is closed, hGetBuf will behave as for condition (a).
560
561 Semantics of hPutBuf:
562
563     - hPutBuf writes data from the buffer to the handle 
564       until the buffer is empty.  It returns ().
565
566       If the handle is a pipe or socket, and the reading end is
567       closed, hPutBuf will raise a ResourceVanished exception.
568       (If this is a POSIX system, and the program has not 
569       asked to ignore SIGPIPE, then a SIGPIPE may be delivered
570       instead, whose default action is to terminate the program).
571 -}
572
573 -- ---------------------------------------------------------------------------
574 -- hPutBuf
575
576 hPutBuf :: Handle                       -- handle to write to
577         -> Ptr a                        -- address of buffer
578         -> Int                          -- number of bytes of data in buffer
579         -> IO ()
580 hPutBuf handle ptr count
581   | count <= 0 = illegalBufferSize handle "hPutBuf" count
582   | otherwise = 
583     wantWritableHandle "hPutBuf" handle $ 
584       \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
585
586         old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
587           <- readIORef ref
588
589         -- enough room in handle buffer?
590         if (size - w > count)
591                 -- There's enough room in the buffer:
592                 -- just copy the data in and update bufWPtr.
593             then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
594                     writeIORef ref old_buf{ bufWPtr = w + count }
595                     return ()
596
597                 -- else, we have to flush
598             else do flushed_buf <- flushWriteBuffer fd old_buf
599                     writeIORef ref flushed_buf
600                     -- ToDo: should just memcpy instead of writing if possible
601                     writeChunk fd ptr count
602
603 writeChunk :: FD -> Ptr a -> Int -> IO ()
604 writeChunk fd ptr bytes = loop 0 bytes 
605  where
606   loop :: Int -> Int -> IO ()
607   loop _   bytes | bytes <= 0 = return ()
608   loop off bytes = do
609     r <- fromIntegral `liftM`
610            throwErrnoIfMinus1RetryMayBlock "writeChunk"
611             (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
612             (threadWaitWrite fd)
613     -- write can't return 0
614     loop (off + r) (bytes - r)
615
616 -- ---------------------------------------------------------------------------
617 -- hGetBuf
618
619 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
620 hGetBuf handle ptr count
621   | count <= 0 = illegalBufferSize handle "hGetBuf" count
622   | otherwise = 
623       wantReadableHandle "hGetBuf" handle $ 
624         \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
625         buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
626         if bufferEmpty buf
627            then readChunk fd ptr count
628            else do 
629                 let avail = w - r
630                 copied <- if (count >= avail)
631                             then do 
632                                 memcpy_ptr_baoff ptr raw r (fromIntegral avail)
633                                 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
634                                 return avail
635                             else do
636                                 memcpy_ptr_baoff ptr raw r (fromIntegral count)
637                                 writeIORef ref buf{ bufRPtr = r + count }
638                                 return count
639
640                 let remaining = count - copied
641                 if remaining > 0 
642                    then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
643                            return (rest + count)
644                    else return count
645                 
646 readChunk :: FD -> Ptr a -> Int -> IO Int
647 readChunk fd ptr bytes = loop 0 bytes 
648  where
649   loop :: Int -> Int -> IO Int
650   loop off bytes | bytes <= 0 = return off
651   loop off bytes = do
652     r <- fromIntegral `liftM`
653            throwErrnoIfMinus1RetryMayBlock "readChunk"
654             (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
655             (threadWaitRead fd)
656     if r == 0
657         then return off
658         else loop (off + r) (bytes - r)
659
660 slurpFile :: FilePath -> IO (Ptr (), Int)
661 slurpFile fname = do
662   handle <- openFile fname ReadMode
663   sz     <- hFileSize handle
664   if sz > fromIntegral (maxBound::Int) then 
665     ioError (userError "slurpFile: file too big")
666    else do
667     let sz_i = fromIntegral sz
668     chunk <- mallocBytes sz_i
669     r <- hGetBuf handle chunk sz_i
670     hClose handle
671     return (chunk, r)
672
673 -- ---------------------------------------------------------------------------
674 -- hGetBufBA
675
676 hGetBufBA :: Handle -> MutableByteArray RealWorld a -> Int -> IO Int
677 hGetBufBA handle (MutableByteArray _ _ ptr) count
678   | count <= 0 = illegalBufferSize handle "hGetBuf" count
679   | otherwise = 
680       wantReadableHandle "hGetBuf" handle $ 
681         \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
682         buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
683         if bufferEmpty buf
684            then readChunkBA fd ptr 0 count
685            else do 
686                 let avail = w - r
687                 copied <- if (count >= avail)
688                             then do 
689                                 memcpy_ba_baoff ptr raw r (fromIntegral avail)
690                                 writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
691                                 return avail
692                             else do 
693                                 memcpy_ba_baoff ptr raw r (fromIntegral count)
694                                 writeIORef ref buf{ bufRPtr = r + count }
695                                 return count
696
697                 let remaining = count - copied
698                 if remaining > 0 
699                    then do rest <- readChunkBA fd ptr copied remaining
700                            return (rest + count)
701                    else return count
702                 
703 readChunkBA :: FD -> RawBuffer -> Int -> Int -> IO Int
704 readChunkBA fd ptr init_off bytes = loop init_off bytes 
705  where
706   loop :: Int -> Int -> IO Int
707   loop off bytes | bytes <= 0 = return (off - init_off)
708   loop off bytes = do
709     r <- fromIntegral `liftM`
710            throwErrnoIfMinus1RetryMayBlock "readChunk"
711             (readBA (fromIntegral fd) ptr 
712                 (fromIntegral off) (fromIntegral bytes))
713             (threadWaitRead fd)
714     if r == 0
715         then return (off - init_off)
716         else loop (off + r) (bytes - r)
717
718 foreign import "read_ba_wrap" unsafe
719    readBA :: FD -> RawBuffer -> Int -> CInt -> IO CInt
720 #def inline \
721 int read_ba_wrap(int fd, void *ptr, HsInt off, int size) \
722 { return read(fd, ptr + off, size); }
723
724 -- -----------------------------------------------------------------------------
725 -- hPutBufBA
726
727 hPutBufBA
728         :: Handle                       -- handle to write to
729         -> MutableByteArray RealWorld a -- buffer
730         -> Int                          -- number of bytes of data in buffer
731         -> IO ()
732
733 hPutBufBA handle (MutableByteArray _ _ raw) count
734   | count <= 0 = illegalBufferSize handle "hPutBufBA" count
735   | otherwise = do
736     wantWritableHandle "hPutBufBA" handle $ 
737       \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
738
739         old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
740           <- readIORef ref
741
742         -- enough room in handle buffer?
743         if (size - w > count)
744                 -- There's enough room in the buffer:
745                 -- just copy the data in and update bufWPtr.
746             then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
747                     writeIORef ref old_buf{ bufWPtr = w + count }
748                     return ()
749
750                 -- else, we have to flush
751             else do flushed_buf <- flushWriteBuffer fd old_buf
752                     writeIORef ref flushed_buf
753                     let this_buf = 
754                             Buffer{ bufBuf=raw, bufState=WriteBuffer, 
755                                     bufRPtr=0, bufWPtr=count, bufSize=count }
756                     flushWriteBuffer fd this_buf
757                     return ()
758
759 -- ---------------------------------------------------------------------------
760 -- memcpy wrappers
761
762 foreign import "memcpy_wrap_src_off" unsafe 
763    memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
764 foreign import "memcpy_wrap_src_off" unsafe 
765    memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
766 foreign import "memcpy_wrap_dst_off" unsafe 
767    memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
768 foreign import "memcpy_wrap_dst_off" unsafe 
769    memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
770
771 #def inline \
772 void *memcpy_wrap_dst_off(char *dst, int dst_off, char *src, size_t sz) \
773 { return memcpy(dst+dst_off, src, sz); }
774
775 #def inline \
776 void *memcpy_wrap_src_off(char *dst, char *src, int src_off, size_t sz) \
777 { return memcpy(dst, src+src_off, sz); }
778
779 -----------------------------------------------------------------------------
780 -- Internal Utils
781
782 illegalBufferSize :: Handle -> String -> Int -> IO a
783 illegalBufferSize handle fn (sz :: Int) = 
784         ioException (IOError (Just handle)
785                             InvalidArgument  fn
786                             ("illegal buffer size " ++ showsPrec 9 sz [])
787                             Nothing)