X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=4b0fa9f934e451abd1fa222cd7f9d9a8088687b6;hb=bc9366635bdecd7a3476f33fb4118b4976a5ebd8;hp=801e683366cac0a96a299eb8c0c00687c9748e63;hpb=260e7f2ed9a43c6ecf5a556d77817f39ed2893ab;p=ghc-base.git

diff --git a/GHC/IO.hs b/GHC/IO.hs
index 801e683..4b0fa9f 100644
--- a/GHC/IO.hs
+++ b/GHC/IO.hs
@@ -1,45 +1,49 @@
-{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-}
+{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
 
 #undef DEBUG_DUMP
 
--- -----------------------------------------------------------------------------
--- $Id: IO.hs,v 1.1 2001/12/21 15:07:23 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
-
--- This module defines all basic IO operations.
--- These are needed for the IO operations exported by Prelude,
--- but as it happens they also do everything required by library
--- module IO.
+-----------------------------------------------------------------------------
 
 module GHC.IO ( 
-   putChar, putStr, putStrLn, print, getChar, getLine, getContents,
-   interact, readFile, writeFile, appendFile, readLn, readIO, hReady,
    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
-   hPutStrLn, hPrint,
    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
 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
 
 -- ---------------------------------------------------------------------------
@@ -55,7 +59,7 @@ import GHC.Conc
 
 hWaitForInput :: Handle -> Int -> IO Bool
 hWaitForInput h msecs = do
-  wantReadableHandle "hReady" h $ \ handle_ -> do
+  wantReadableHandle "hWaitForInput" h $ \ handle_ -> do
   let ref = haBuffer handle_
   buf <- readIORef ref
 
@@ -63,11 +67,11 @@ hWaitForInput h msecs = do
 	then return True
 	else do
 
-  r <- throwErrnoIfMinus1Retry "hReady"
+  r <- throwErrnoIfMinus1Retry "hWaitForInput"
 	  (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_))
   return (r /= 0)
 
-foreign import "inputReady" unsafe
+foreign import ccall unsafe "inputReady"
   inputReady :: CInt -> CInt -> Bool -> IO CInt
 
 -- ---------------------------------------------------------------------------
@@ -99,9 +103,7 @@ hGetChar handle =
     NoBuffering -> do
 	-- make use of the minimal buffer we already have
 	let raw = bufBuf buf
-	r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
-	        (read_off (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
@@ -164,10 +166,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_)
@@ -175,10 +180,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)
 
@@ -190,18 +197,18 @@ 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]
 unpack buf r 0   = return ""
-unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
+unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
    where
     unpack acc i s
-     | i <## r  = (## s, acc ##)
+     | i <# r  = (# s, acc #)
      | otherwise = 
-          case readCharArray## buf i s of
-	    (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
+          case readCharArray# buf i s of
+	    (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
 
 
 hGetLineUnBuffered :: Handle -> IO String
@@ -279,9 +286,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 (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_, "")
@@ -312,14 +317,14 @@ lazyReadHaveBuffer h handle_ fd ref buf = do
 
 
 unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
-unpackAcc buf r 0 acc  = return ""
-unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
+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
-     | i <## r  = (## s, acc ##)
+     | i <# r  = (# s, acc #)
      | otherwise = 
-          case readCharArray## buf i s of
-	    (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
+          case readCharArray# buf i s of
+	    (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
 
 -- ---------------------------------------------------------------------------
 -- hPutChar
@@ -337,11 +342,9 @@ hPutChar handle c =
 	LineBuffering    -> hPutcBuffered handle_ True  c
 	BlockBuffering _ -> hPutcBuffered handle_ False c
 	NoBuffering      ->
-		withObject (castCharToCChar c) $ \buf ->
-		throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
-		   (c_write (fromIntegral fd) buf 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_
@@ -429,7 +432,7 @@ writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
 	return ()
    shoveString n (c:cs) = do
 	n' <- writeCharIntoBuffer raw n c
-      if (c == '\n') 
+        if (c == '\n') 
          then do 
               new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
               writeLines hdl new_buf cs
@@ -484,7 +487,7 @@ commitBuffer
 	-> Bool 			-- release the buffer?
 	-> IO Buffer
 
-commitBuffer hdl raw sz@(I## _) count@(I## _) flush release = do
+commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
   wantWritableHandle "commitAndReleaseBuffer" hdl $
      commitBuffer' hdl raw sz count flush release
 
@@ -499,7 +502,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' hdl raw sz@(I# _) count@(I# _) flush release
   handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
 
 #ifdef DEBUG_DUMP
@@ -603,10 +606,11 @@ 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 } -> do
+      \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
 
         old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
 	  <- readIORef ref
@@ -620,21 +624,20 @@ hPutBuf handle ptr count
 		    return ()
 
 		-- else, we have to flush
-	    else do flushed_buf <- flushWriteBuffer fd old_buf
+	    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)
 
@@ -643,13 +646,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)
@@ -664,20 +668,19 @@ hGetBuf handle ptr count
 
 		let remaining = count - copied
 		if remaining > 0 
-		   then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
-			   return (rest + count)
+		   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)
@@ -690,6 +693,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
@@ -698,13 +702,13 @@ slurpFile fname = do
 -- ---------------------------------------------------------------------------
 -- memcpy wrappers
 
-foreign import "__hscore_memcpy_src_off" unsafe 
+foreign import ccall unsafe "__hscore_memcpy_src_off"
    memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
-foreign import "__hscore_memcpy_src_off" unsafe 
+foreign import ccall unsafe "__hscore_memcpy_src_off"
    memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
-foreign import "__hscore_memcpy_dst_off" unsafe 
+foreign import ccall unsafe "__hscore_memcpy_dst_off"
    memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
-foreign import "__hscore_memcpy_dst_off" unsafe 
+foreign import ccall unsafe "__hscore_memcpy_dst_off"
    memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
 
 -----------------------------------------------------------------------------