X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=f24891429cb534ad139cbe70382ab4165a8b7043;hb=7a499a50c676e36e3d4562652e94fbcabf22e594;hp=24a06533a20d99003342df754fd871143a074c72;hpb=23ca6b8a9e91256cc39ad823cdd7a0fc1fdf3ac5;p=ghc-base.git

diff --git a/GHC/IO.hs b/GHC/IO.hs
index 24a0653..f248914 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,6 +16,7 @@
 --
 -----------------------------------------------------------------------------
 
+-- #hide
 module GHC.IO ( 
    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
    commitBuffer',	-- hack, see below
@@ -27,8 +28,6 @@ module GHC.IO (
    memcpy_baoff_ptr,
  ) where
 
-#include "config.h"
-
 import Foreign
 import Foreign.C
 
@@ -47,7 +46,7 @@ import GHC.Show
 import GHC.List
 import GHC.Exception    ( ioError, catch )
 
-#ifdef mingw32_TARGET_OS
+#ifdef mingw32_HOST_OS
 import GHC.Conc
 #endif
 
@@ -93,7 +92,7 @@ hWaitForInput h msecs = do
 			   (fromIntegral msecs) (haIsStream handle_)
 		return (r /= 0)
 
-foreign import ccall unsafe "inputReady"
+foreign import ccall safe "inputReady"
   inputReady :: CInt -> CInt -> Bool -> IO CInt
 
 -- ---------------------------------------------------------------------------
@@ -402,15 +401,15 @@ 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
+		with (castCharToCChar c) $ \buf -> do
   		  writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1
 		  return ()
 
@@ -563,7 +562,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
@@ -576,7 +575,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
@@ -727,7 +726,7 @@ 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
+#ifndef mingw32_HOST_OS
     ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
     let r = fromIntegral ssize :: Int
     if (r == -1)
@@ -901,7 +900,7 @@ bufReadNonBlocking fd ref is_stream ptr so_far count =
 
 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
 readChunkNonBlocking fd is_stream ptr bytes = do
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
     ssize <- c_read (fromIntegral fd) (castPtr ptr) (fromIntegral bytes)
     let r = fromIntegral ssize :: Int
     if (r == -1)
@@ -911,12 +910,13 @@ readChunkNonBlocking fd is_stream ptr bytes = do
 		 else throwErrno "readChunk"
       else return r
 #else
-    (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream)
-   			       (fromIntegral bytes) ptr
-    let r = fromIntegral ssize :: Int
-    if r == (-1)
-     then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
-     else return r
+    fromIntegral `liftM`
+        readRawBufferPtr "readChunkNonBlocking" (fromIntegral 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)