X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=0a7416f461ec484a91483387a9011ffa15935d59;hb=4b26136ab82fb1ff12e49477c4833a9586d368c5;hp=b9b6a23caf0bc23920a74c78b1acd8b86560d483;hpb=bcc4d6b0ce599fe16aef6fabdf6bb0d49ad52617;p=haskell-directory.git

diff --git a/GHC/IO.hs b/GHC/IO.hs
index b9b6a23..0a7416f 100644
--- a/GHC/IO.hs
+++ b/GHC/IO.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
 
 #undef DEBUG_DUMP
 
@@ -16,22 +16,18 @@
 --
 -----------------------------------------------------------------------------
 
+-- #hide
 module GHC.IO ( 
    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
    commitBuffer',	-- hack, see below
    hGetcBuffered,	-- needed by ghc/compiler/utils/StringBuffer.lhs
    hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile,
-{- NOTE: As far as I can tell, not defined.
-   createPipe, createPipeEx,
--}
    memcpy_ba_baoff,
    memcpy_ptr_baoff,
    memcpy_baoff_ba,
    memcpy_baoff_ptr,
  ) where
 
-#include "config.h"
-
 import Foreign
 import Foreign.C
 
@@ -49,7 +45,10 @@ import GHC.Num
 import GHC.Show
 import GHC.List
 import GHC.Exception    ( ioError, catch )
+
+#ifdef mingw32_HOST_OS
 import GHC.Conc
+#endif
 
 -- ---------------------------------------------------------------------------
 -- Simple input operations
@@ -64,9 +63,16 @@ import GHC.Conc
 -- It returns 'True' as soon as input is available on @hdl@,
 -- or 'False' if no input is available within @t@ milliseconds.
 --
+-- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
+--
 -- This operation may fail with:
 --
 --  * 'isEOFError' if the end of file has been reached.
+--
+-- NOTE for GHC users: unless you use the @-threaded@ flag,
+-- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
+-- threads for the duration of the call.  It behaves like a
+-- @safe@ foreign call in this respect.
 
 hWaitForInput :: Handle -> Int -> IO Bool
 hWaitForInput h msecs = do
@@ -78,12 +84,19 @@ hWaitForInput h msecs = do
 	then return True
 	else do
 
-  r <- throwErrnoIfMinus1Retry "hWaitForInput"
-	  (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
-  return (r /= 0)
+  if msecs < 0 
+	then do buf' <- fillReadBuffer (haFD handle_) True 
+				(haIsStream handle_) buf
+	        writeIORef ref buf'
+		return True
+	else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $
+	             inputReady (haFD handle_)
+	                        (fromIntegral msecs)
+                                (fromIntegral $ fromEnum $ haIsStream handle_)
+		return (r /= 0)
 
-foreign import ccall unsafe "inputReady"
-  inputReady :: CInt -> CInt -> Bool -> IO CInt
+foreign import ccall safe "inputReady"
+  inputReady :: CInt -> CInt -> CInt -> IO CInt
 
 -- ---------------------------------------------------------------------------
 -- hGetChar
@@ -120,7 +133,7 @@ hGetChar handle =
     NoBuffering -> do
 	-- make use of the minimal buffer we already have
 	let raw = bufBuf buf
-	r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1
+	r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1
 	if r == 0
 	   then ioe_EOF
 	   else do (c,_) <- readCharFromBuffer raw 0
@@ -166,24 +179,25 @@ hGetLine h = do
 	Nothing -> hGetLineUnBuffered h
 	Just l  -> return l
 
-
+hGetLineBuffered :: Handle__ -> IO String
 hGetLineBuffered handle_ = do
   let ref = haBuffer handle_
   buf <- readIORef ref
   hGetLineBufferedLoop handle_ ref buf []
 
-
-hGetLineBufferedLoop handle_ ref 
-	buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
-  let 
-	-- find the end-of-line character, if there is one
-	loop raw r
-	   | r == w = return (False, w)
-	   | otherwise =  do
-		(c,r') <- readCharFromBuffer raw r
-		if c == '\n' 
-		   then return (True, r) -- NB. not r': don't include the '\n'
-		   else loop raw r'
+hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String]
+                     -> IO String
+hGetLineBufferedLoop handle_ ref
+        buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
+  let
+        -- find the end-of-line character, if there is one
+        loop raw r
+           | r == w = return (False, w)
+           | otherwise =  do
+                (c,r') <- readCharFromBuffer raw r
+                if c == '\n'
+                   then return (True, r) -- NB. not r': don't include the '\n'
+                   else loop raw r'
   in do
   (eol, off) <- loop raw r
 
@@ -196,24 +210,24 @@ hGetLineBufferedLoop handle_ ref
   -- 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 }
-	        return (concat (reverse (xs:xss)))
-	else do
-	     maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
-				buf{ bufWPtr=0, bufRPtr=0 }
-	     case maybe_buf of
-		-- Nothing indicates we caught an EOF, and we may have a
-		-- partial line to return.
-		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)
+        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_)
+                                buf{ bufWPtr=0, bufRPtr=0 }
+             case maybe_buf of
+                -- Nothing indicates we caught an EOF, and we may have a
+                -- partial line to return.
+                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)
 
 
 maybeFillReadBuffer fd is_line is_stream buf
@@ -337,7 +351,7 @@ lazyRead' h handle_ = do
      NoBuffering      -> do
 	-- make use of the minimal buffer we already have
 	let raw = bufBuf buf
-	r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1
+	r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1
 	if r == 0
 	   then do handle_ <- hClose_help handle_ 
 		   return (handle_, "")
@@ -391,16 +405,16 @@ unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
 --  * 'isPermissionError' if another system resource limit would be exceeded.
 
 hPutChar :: Handle -> Char -> IO ()
-hPutChar handle c = 
-    c `seq` do   -- must evaluate c before grabbing the handle lock
+hPutChar handle c = do
+    c `seq` return ()
     wantWritableHandle "hPutChar" handle $ \ handle_  -> do
     let fd = haFD handle_
     case haBufferMode handle_ of
 	LineBuffering    -> hPutcBuffered handle_ True  c
 	BlockBuffering _ -> hPutcBuffered handle_ False c
 	NoBuffering      ->
-		withObject (castCharToCChar c) $ \buf -> do
-  		  writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
+		with (castCharToCChar c) $ \buf -> do
+  		  writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1
 		  return ()
 
 hPutcBuffered handle_ is_line c = do
@@ -552,7 +566,7 @@ commitBuffer
 
 commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
   wantWritableHandle "commitAndReleaseBuffer" hdl $
-     commitBuffer' hdl raw sz count flush release
+     commitBuffer' raw sz count flush release
 
 -- Explicitly lambda-lift this function to subvert GHC's full laziness
 -- optimisations, which otherwise tends to float out subexpressions
@@ -565,7 +579,7 @@ commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
 --
 -- This hack is a fairly big win for hPutStr performance.  --SDM 18/9/2001
 --
-commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
+commitBuffer' raw sz@(I# _) count@(I# _) flush release
   handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
 
 #ifdef DEBUG_DUMP
@@ -588,7 +602,7 @@ commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
 
 		-- not flushing, and there's enough room in the buffer:
 		-- just copy the data in and update bufWPtr.
-	    then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
+	    then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count)
 		    writeIORef ref old_buf{ bufWPtr = w + count }
 		    return (newEmptyBuffer raw WriteBuffer sz)
 
@@ -682,12 +696,13 @@ bufWrite fd ref is_stream ptr count can_block =
   if (size - w > count)
 	-- There's enough room in the buffer:
 	-- just copy the data in and update bufWPtr.
-	then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count)
+	then do memcpy_baoff_ptr old_raw (fromIntegral w) ptr (fromIntegral count)
 	        writeIORef ref old_buf{ bufWPtr = w + count }
 		return count
 
 	-- else, we have to flush
 	else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
+			-- TODO: we should do a non-blocking flush here
 		writeIORef ref flushed_buf
 		-- if we can fit in the buffer, then just loop	
 		if count < size
@@ -704,7 +719,7 @@ writeChunk fd is_stream ptr bytes = loop 0 bytes
   loop _   bytes | bytes <= 0 = return ()
   loop off bytes = do
     r <- fromIntegral `liftM`
-    	   writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr
+    	   writeRawBufferPtr "writeChunk" fd is_stream ptr
 	   		     off (fromIntegral bytes)
     -- write can't return 0
     loop (off + r) (bytes - r)
@@ -715,8 +730,8 @@ writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
   loop :: Int -> Int -> IO Int
   loop off bytes | bytes <= 0 = return off
   loop off bytes = do
-#ifndef mingw32_TARGET_OS
-    ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
+#ifndef mingw32_HOST_OS
+    ssize <- c_write fd (ptr `plusPtr` off) (fromIntegral bytes)
     let r = fromIntegral ssize :: Int
     if (r == -1)
       then do errno <- getErrno
@@ -725,7 +740,8 @@ writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
 		 else throwErrno "writeChunk"
       else loop (off + r) (bytes - r)
 #else
-    (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream)
+    (ssize, rc) <- asyncWrite (fromIntegral fd)
+                              (fromIntegral $ fromEnum is_stream)
     				 (fromIntegral bytes)
 				 (ptr `plusPtr` off)
     let r = fromIntegral ssize :: Int
@@ -750,64 +766,56 @@ writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
 -- is closed, 'hGetBuf' will behave as if EOF was reached.
 
 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
-hGetBuf h ptr count = hGetBuf' h ptr count True
-
-hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
-hGetBufNonBlocking h ptr count = hGetBuf' h ptr count False
-
-hGetBuf' :: Handle -> Ptr a -> Int -> Bool -> IO Int
-hGetBuf' handle ptr count can_block
+hGetBuf h ptr count
   | count == 0 = return 0
-  | count <  0 = illegalBufferSize handle "hGetBuf" count
+  | count <  0 = illegalBufferSize h "hGetBuf" count
   | otherwise = 
-      wantReadableHandle "hGetBuf" handle $ 
+      wantReadableHandle "hGetBuf" h $ 
 	\ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
-	    bufRead fd ref is_stream ptr 0 count can_block
+	    bufRead fd ref is_stream ptr 0 count
 
-bufRead fd ref is_stream ptr so_far count can_block =
+-- small reads go through the buffer, large reads are satisfied by
+-- taking data first from the buffer and then direct from the file
+-- descriptor.
+bufRead fd ref is_stream ptr so_far count =
   seq fd $ seq so_far $ seq count $ do -- strictness hack
   buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
   if bufferEmpty buf
-     then if count < sz
-	 	then do 
-		   mb_buf <- maybeFillReadBuffer fd (not can_block) is_stream buf
-		   case mb_buf of
-		       Nothing -> return 0
-		       Just new_buf -> do 
-			  writeIORef ref new_buf
-		   	  bufRead fd ref is_stream ptr so_far count can_block
-		else if can_block 
-			then readChunk fd is_stream ptr count
-			else readChunkNonBlocking fd is_stream ptr count
+     then if count > sz  -- small read?
+		then do rest <- readChunk fd is_stream ptr count
+			return (so_far + rest)
+	 	else do mb_buf <- maybeFillReadBuffer fd True is_stream buf
+			case mb_buf of
+		          Nothing -> return so_far -- got nothing, we're done
+		          Just buf' -> do
+			   	writeIORef ref buf'
+				bufRead fd ref is_stream ptr so_far count
      else do 
-	let avail = w - r
+  	let avail = w - r
 	if (count == avail)
 	   then do 
-		memcpy_ptr_baoff ptr raw r (fromIntegral count)
+		memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
 		writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
 		return (so_far + count)
 	   else do
 	if (count < avail)
 	   then do 
-		memcpy_ptr_baoff ptr raw r (fromIntegral count)
+		memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
 		writeIORef ref buf{ bufRPtr = r + count }
 		return (so_far + count)
 	   else do
-
-	memcpy_ptr_baoff ptr raw r (fromIntegral avail)
+  
+	memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
 	writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
-
 	let remaining = count - avail
 	    so_far' = so_far + avail
 	    ptr' = ptr `plusPtr` avail
 
 	if remaining < sz
-	   then bufRead fd ref is_stream ptr' so_far' remaining can_block
+	   then bufRead fd ref is_stream ptr' so_far' remaining
 	   else do 
 
-	rest <- if can_block 
-			then readChunk fd is_stream ptr' remaining
-			else readChunkNonBlocking fd is_stream ptr' remaining
+	rest <- readChunk fd is_stream ptr' remaining
 	return (so_far' + rest)
 
 readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
@@ -817,39 +825,103 @@ readChunk fd is_stream ptr bytes = loop 0 bytes
   loop off bytes | bytes <= 0 = return off
   loop off bytes = do
     r <- fromIntegral `liftM`
-           readRawBufferPtr "readChunk" (fromIntegral fd) is_stream 
+           readRawBufferPtr "readChunk" fd is_stream 
 	   		    (castPtr ptr) off (fromIntegral bytes)
     if r == 0
 	then return off
 	else loop (off + r) (bytes - r)
 
+
+-- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
+-- into the buffer @buf@ until either EOF is reached, or
+-- @count@ 8-bit bytes have been read, or there is no more data available
+-- to read immediately.
+--
+-- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
+-- never block waiting for data to become available, instead it returns
+-- only whatever data is available.  To wait for data to arrive before
+-- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
+--
+-- If the handle is a pipe or socket, and the writing end
+-- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
+--
+hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
+hGetBufNonBlocking h ptr count
+  | count == 0 = return 0
+  | count <  0 = illegalBufferSize h "hGetBufNonBlocking" count
+  | otherwise = 
+      wantReadableHandle "hGetBufNonBlocking" h $ 
+	\ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
+	    bufReadNonBlocking fd ref is_stream ptr 0 count
+
+bufReadNonBlocking fd ref is_stream ptr so_far count =
+  seq fd $ seq so_far $ seq count $ do -- strictness hack
+  buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
+  if bufferEmpty buf
+     then if count > sz  -- large read?
+		then do rest <- readChunkNonBlocking fd is_stream ptr count
+			return (so_far + rest)
+	 	else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
+			case buf' of { Buffer{ bufWPtr=w }  ->
+			if (w == 0) 
+			   then return so_far
+			   else do writeIORef ref buf'
+				   bufReadNonBlocking fd ref is_stream ptr
+					 so_far (min count w)
+				  -- NOTE: new count is 'min count w'
+				  -- so we will just copy the contents of the
+				  -- buffer in the recursive call, and not
+				  -- loop again.
+			}
+     else do
+  	let avail = w - r
+	if (count == avail)
+	   then do 
+		memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
+		writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
+		return (so_far + count)
+	   else do
+	if (count < avail)
+	   then do 
+		memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count)
+		writeIORef ref buf{ bufRPtr = r + count }
+		return (so_far + count)
+	   else do
+
+	memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail)
+	writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
+	let remaining = count - avail
+	    so_far' = so_far + avail
+	    ptr' = ptr `plusPtr` avail
+
+	-- we haven't attempted to read anything yet if we get to here.
+	if remaining < sz
+	   then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining
+	   else do 
+
+	rest <- readChunkNonBlocking fd is_stream ptr' remaining
+	return (so_far' + rest)
+
+
 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
-readChunkNonBlocking 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
-#ifndef mingw32_TARGET_OS
-    ssize <- c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
+readChunkNonBlocking fd is_stream ptr bytes = do
+#ifndef mingw32_HOST_OS
+    ssize <- c_read fd (castPtr ptr) (fromIntegral bytes)
     let r = fromIntegral ssize :: Int
     if (r == -1)
       then do errno <- getErrno
 	      if (errno == eAGAIN || errno == eWOULDBLOCK)
-		 then return off
+		 then return 0
 		 else throwErrno "readChunk"
-      else if (r == 0)
-		then return off
-		else loop (off + r) (bytes - r)
+      else return r
 #else
-    (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream)
-   			       (fromIntegral bytes)
-   			       (ptr `plusPtr` off)
-    let r = fromIntegral ssize :: Int
-    if r == (-1)
-     then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
-     else if (r  == 0)
-       then return off
-       else loop (off + r) (bytes - r)
+    fromIntegral `liftM`
+        readRawBufferPtr "readChunkNonBlocking" fd is_stream 
+	   		    (castPtr ptr) 0 (fromIntegral bytes)
+
+    -- we don't have non-blocking read support on Windows, so just invoke
+    -- the ordinary low-level read which will block until data is available,
+    -- but won't wait for the whole buffer to fill.
 #endif
 
 slurpFile :: FilePath -> IO (Ptr (), Int)
@@ -870,13 +942,13 @@ slurpFile fname = do
 -- memcpy wrappers
 
 foreign import ccall unsafe "__hscore_memcpy_src_off"
-   memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
+   memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
 foreign import ccall unsafe "__hscore_memcpy_src_off"
-   memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
+   memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ())
 foreign import ccall unsafe "__hscore_memcpy_dst_off"
-   memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
+   memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ())
 foreign import ccall unsafe "__hscore_memcpy_dst_off"
-   memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
+   memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ())
 
 -----------------------------------------------------------------------------
 -- Internal Utils