X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=914a55a9178a8378fcd3e5b36e72461c27e92ce2;hb=f0d03cbf416d6c3beb984b313f0c7196ec32a929;hp=110ae688aea7197c89f75f40c0b56d58fdebc682;hpb=7de50399a42ee49b0473b7b6eea2b44a2f941a12;p=haskell-directory.git

diff --git a/GHC/IO.hs b/GHC/IO.hs
index 110ae68..914a55a 100644
--- a/GHC/IO.hs
+++ b/GHC/IO.hs
@@ -1,18 +1,30 @@
-{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-}
+{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
 
 #undef DEBUG_DUMP
 
--- -----------------------------------------------------------------------------
--- $Id: IO.hs,v 1.3 2002/02/05 17:32:26 simonmar Exp $
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.IO
+-- Copyright   :  (c) The University of Glasgow, 1992-2001
+-- License     :  see libraries/base/LICENSE
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable
 --
--- (c) The University of Glasgow, 1992-2001
+-- String I\/O functions
 --
+-----------------------------------------------------------------------------
 
 module GHC.IO ( 
    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
    commitBuffer',	-- hack, see below
    hGetcBuffered,	-- needed by ghc/compiler/utils/StringBuffer.lhs
-   hGetBuf, hPutBuf, slurpFile
+   hGetBuf, hPutBuf, slurpFile,
+   memcpy_ba_baoff,
+   memcpy_ptr_baoff,
+   memcpy_baoff_ba,
+   memcpy_baoff_ptr,
  ) where
 
 import Foreign
@@ -21,17 +33,17 @@ import Foreign.C
 import System.IO.Error
 import Data.Maybe
 import Control.Monad
+import System.Posix.Internals
 
 import GHC.Enum
 import GHC.Base
-import GHC.Posix
 import GHC.IOBase
 import GHC.Handle	-- much of the real stuff is in here
 import GHC.Real
 import GHC.Num
 import GHC.Show
 import GHC.List
-import GHC.Exception    ( ioError, catch, throw )
+import GHC.Exception    ( ioError, catch )
 import GHC.Conc
 
 -- ---------------------------------------------------------------------------
@@ -86,14 +98,14 @@ hGetChar handle =
 	new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
 	hGetcBuffered fd ref new_buf
     BlockBuffering _ -> do
-	new_buf <- fillReadBuffer fd False (haIsStream handle_) buf
+	new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
+		--		     ^^^^
+		-- don't wait for a completely full buffer.
 	hGetcBuffered fd ref new_buf
     NoBuffering -> do
 	-- make use of the minimal buffer we already have
 	let raw = bufBuf buf
-	r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
-	        (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
-	        (threadWaitRead fd)
+	r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
 	if r == 0
 	   then ioe_EOF
 	   else do (c,_) <- readCharFromBuffer raw 0
@@ -156,10 +168,13 @@ hGetLineBufferedLoop handle_ ref
 #endif
 
   xs <- unpack raw r off
+
+  -- if eol == True, then off is the offset of the '\n'
+  -- otherwise off == w and the buffer is now empty.
   if eol
-	then do if w == off + 1
-		   then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
-		   else writeIORef ref buf{ bufRPtr = off + 1 }
+	then do if (w == off + 1)
+	    		then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
+		   	else writeIORef ref buf{ bufRPtr = off + 1 }
 	        return (concat (reverse (xs:xss)))
 	else do
 	     maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
@@ -167,10 +182,12 @@ hGetLineBufferedLoop handle_ ref
 	     case maybe_buf of
 		-- Nothing indicates we caught an EOF, and we may have a
 		-- partial line to return.
-		Nothing -> let str = concat (reverse (xs:xss)) in
-		     	   if not (null str)
-			      then return str
-			      else ioe_EOF
+		Nothing -> do
+		     writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
+		     let str = concat (reverse (xs:xss))
+		     if not (null str)
+		        then return str
+		        else ioe_EOF
 		Just new_buf -> 
 		     hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
 
@@ -182,7 +199,7 @@ maybeFillReadBuffer fd is_line is_stream buf
      )
      (\e -> do if isEOFError e 
 		  then return Nothing 
-		  else throw e)
+		  else ioError e)
 
 
 unpack :: RawBuffer -> Int -> Int -> IO [Char]
@@ -271,9 +288,7 @@ lazyRead' h handle_ = do
      NoBuffering      -> do
 	-- make use of the minimal buffer we already have
 	let raw = bufBuf buf
-	r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
-	        (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1)
-	        (threadWaitRead fd)
+	r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
 	if r == 0
 	   then do handle_ <- hClose_help handle_ 
 		   return (handle_, "")
@@ -304,7 +319,7 @@ lazyReadHaveBuffer h handle_ fd ref buf = do
 
 
 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
-unpackAcc buf r 0 acc  = return ""
+unpackAcc buf r 0 acc  = return acc
 unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
    where
     unpack acc i s
@@ -329,11 +344,9 @@ hPutChar handle c =
 	LineBuffering    -> hPutcBuffered handle_ True  c
 	BlockBuffering _ -> hPutcBuffered handle_ False c
 	NoBuffering      ->
-		withObject (castCharToCChar c) $ \buf ->
-		throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
-		   (write_off (fromIntegral fd) (haIsStream handle_) buf 0 1)
-		   (threadWaitWrite fd)
-
+		withObject (castCharToCChar c) $ \buf -> do
+  		  writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
+		  return ()
 
 hPutcBuffered handle_ is_line c = do
   let ref = haBuffer handle_
@@ -595,7 +608,8 @@ hPutBuf :: Handle			-- handle to write to
 	-> Int				-- number of bytes of data in buffer
 	-> IO ()
 hPutBuf handle ptr count
-  | count <= 0 = illegalBufferSize handle "hPutBuf" count
+  | count == 0 = return ()
+  | count <  0 = illegalBufferSize handle "hPutBuf" count
   | otherwise = 
     wantWritableHandle "hPutBuf" handle $ 
       \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
@@ -615,18 +629,17 @@ hPutBuf handle ptr count
 	    else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
 		    writeIORef ref flushed_buf
 		    -- ToDo: should just memcpy instead of writing if possible
-		    writeChunk fd ptr count
+		    writeChunk fd is_stream (castPtr ptr) count
 
-writeChunk :: FD -> Ptr a -> Int -> IO ()
-writeChunk fd ptr bytes = loop 0 bytes 
+writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
+writeChunk fd is_stream ptr bytes = loop 0 bytes 
  where
   loop :: Int -> Int -> IO ()
   loop _   bytes | bytes <= 0 = return ()
   loop off bytes = do
     r <- fromIntegral `liftM`
-	   throwErrnoIfMinus1RetryMayBlock "writeChunk"
-	    (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
-	    (threadWaitWrite fd)
+    	   writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
+	   		     off (fromIntegral bytes)
     -- write can't return 0
     loop (off + r) (bytes - r)
 
@@ -635,13 +648,14 @@ writeChunk fd ptr bytes = loop 0 bytes
 
 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
 hGetBuf handle ptr count
-  | count <= 0 = illegalBufferSize handle "hGetBuf" count
+  | count == 0 = return 0
+  | count <  0 = illegalBufferSize handle "hGetBuf" count
   | otherwise = 
       wantReadableHandle "hGetBuf" handle $ 
-	\ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
+	\ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
 	buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
 	if bufferEmpty buf
-	   then readChunk fd ptr count
+	   then readChunk fd is_stream ptr count
 	   else do 
 		let avail = w - r
 		copied <- if (count >= avail)
@@ -656,20 +670,19 @@ hGetBuf handle ptr count
 
 		let remaining = count - copied
 		if remaining > 0 
-		   then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
+		   then do rest <- readChunk fd is_stream (ptr `plusPtr` copied) remaining
 			   return (rest + copied)
 		   else return count
 		
-readChunk :: FD -> Ptr a -> Int -> IO Int
-readChunk fd ptr bytes = loop 0 bytes 
+readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
+readChunk fd is_stream ptr bytes = loop 0 bytes 
  where
   loop :: Int -> Int -> IO Int
   loop off bytes | bytes <= 0 = return off
   loop off bytes = do
     r <- fromIntegral `liftM`
-	   throwErrnoIfMinus1RetryMayBlock "readChunk"
-	    (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
-	    (threadWaitRead fd)
+           readRawBufferPtr "readChunk" (fromIntegral fd) is_stream 
+	   		    (castPtr ptr) off (fromIntegral bytes)
     if r == 0
 	then return off
 	else loop (off + r) (bytes - r)
@@ -682,6 +695,7 @@ slurpFile fname = do
     ioError (userError "slurpFile: file too big")
    else do
     let sz_i = fromIntegral sz
+    if sz_i == 0 then return (nullPtr, 0) else do
     chunk <- mallocBytes sz_i
     r <- hGetBuf handle chunk sz_i
     hClose handle