From 313a61d546f55bb2c098ecd0ebb42e15d943201e Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Wed, 12 Apr 2000 17:33:17 +0000
Subject: [PATCH] [project @ 2000-04-12 17:33:16 by simonmar] This commit
 fixes the trace/stderr problem, and also fixes some other
 problems with the I/O library.

	- handles now contain a list of free buffers, which are
	  guaranteed to be the same size as the primary handle buffer.

	- hPutStr now doesn't evaluate any part of the input string with
	  the handle locked.  Instead, it acquires a buffer from the handle
	  copies characters into it, then commits the buffer.  This is
	  better for concurrency too, because the handle is only locked
	  while we're actually reading/writing, not while evaluating.

	- there were an even number of off-by-one errors in the I/O system
	  which compensated for each other.  This has been fixed.

	- made the I/O subsystem a little more exception-safe.  It still
	  isn't totally exception-safe, but I can't face doing that
	  without a complete rewrite of this thing in Haskell.

	- add hPutBufFull and hGetBufFull.  The compiler probably needs to
	  be updated to use these too.
---
 ghc/lib/std/PrelHandle.lhs     |  191 +++++++++-----------
 ghc/lib/std/PrelIO.lhs         |  379 +++++++++++++++++++++++-----------------
 ghc/lib/std/PrelIOBase.lhs     |    7 +-
 ghc/lib/std/cbits/Makefile     |   11 +-
 ghc/lib/std/cbits/fileObject.c |    3 +-
 ghc/lib/std/cbits/fileObject.h |   13 +-
 ghc/lib/std/cbits/flushFile.c  |    6 +-
 ghc/lib/std/cbits/openFile.c   |    5 +-
 ghc/lib/std/cbits/readFile.c   |   28 ++-
 ghc/lib/std/cbits/stgio.h      |    3 +-
 ghc/lib/std/cbits/writeFile.c  |   46 ++++-
 11 files changed, 379 insertions(+), 313 deletions(-)

diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index f9ce8bc..8d02b32 100644
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -36,7 +36,7 @@ import PrelWeak		( addForeignFinalizer )
 import PrelConc
 
 #ifndef __PARALLEL_HASKELL__
-import PrelForeign  ( makeForeignObj )
+import PrelForeign  ( makeForeignObj, mkForeignObj )
 #endif
 
 #endif /* ndef(__HUGS__) */
@@ -99,7 +99,8 @@ but we might want to revisit this in the future --SDM ].
 \begin{code}
 withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
 {-# INLINE withHandle #-}
-withHandle (Handle h) act = do
+withHandle (Handle h) act =
+   blockAsyncExceptions $ do
    h_ <- takeMVar h
    (h',v)  <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
    putMVar h h'
@@ -107,7 +108,8 @@ withHandle (Handle h) act = do
 
 withHandle_ :: Handle -> (Handle__ -> IO a) -> IO a
 {-# INLINE withHandle_ #-}
-withHandle_ (Handle h) act = do
+withHandle_ (Handle h) act =
+   blockAsyncExceptions $ do
    h_ <- takeMVar h
    v  <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
    putMVar h h_
@@ -115,7 +117,8 @@ withHandle_ (Handle h) act = do
    
 withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO ()
 {-# INLINE withHandle__ #-}
-withHandle__ (Handle h) act = do
+withHandle__ (Handle h) act =
+   blockAsyncExceptions $ do
    h_ <- takeMVar h
    h'  <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
    putMVar h h'
@@ -137,19 +140,21 @@ nullFile__ =
 
 mkClosedHandle__ :: Handle__
 mkClosedHandle__ = 
-  Handle__ 
-	   nullFile__
-	   ClosedHandle 
-	   NoBuffering
-	   "closed file"
+  Handle__ { haFO__         = nullFile__,
+	     haType__       = ClosedHandle,
+	     haBufferMode__ = NoBuffering,
+	     haFilePath__   = "closed file",
+	     haBuffers__    = []
+	   }
 
 mkErrorHandle__ :: IOError -> Handle__
 mkErrorHandle__ ioe =
-  Handle__
-           nullFile__ 
-	   (ErrorHandle ioe)
-	   NoBuffering
-	   "error handle"
+  Handle__ { haFO__         =  nullFile__,
+	     haType__       = (ErrorHandle ioe),
+	     haBufferMode__ = NoBuffering,
+	     haFilePath__   = "error handle",
+	     haBuffers__    = []
+	   }
 \end{code}
 
 %*********************************************************
@@ -159,11 +164,29 @@ mkErrorHandle__ ioe =
 %*********************************************************
 
 \begin{code}
+stdHandleFinalizer :: Handle -> IO ()
+stdHandleFinalizer (Handle hdl) = do
+  handle <- takeMVar hdl
+  let fo = haFO__ handle
+  freeStdFileObject fo
+  freeBuffers (haBuffers__ handle)
+
+handleFinalizer :: Handle -> IO ()
+handleFinalizer (Handle hdl) = do
+  handle <- takeMVar hdl
+  let fo = haFO__ handle
+  freeFileObject fo
+  freeBuffers (haBuffers__ handle)
+
+freeBuffers [] = return ()
+freeBuffers (b:bs) = do { free b; freeBuffers bs }
+
 foreign import "libHS_cbits" "freeStdFileObject" unsafe
-        freeStdFileObject :: Addr -> IO ()
+        freeStdFileObject :: FILE_OBJECT -> IO ()
 foreign import "libHS_cbits" "freeFileObject" unsafe
-        freeFileObject :: Addr -> IO ()
-
+        freeFileObject :: FILE_OBJECT -> IO ()
+foreign import "free" unsafe 
+	free :: Addr -> IO ()
 \end{code}
 
 %*********************************************************
@@ -190,7 +213,10 @@ stdout = unsafePerformIO (do
 			      (0::Int){-writeable-}  -- ConcHask: SAFE, won't block
 
 #ifndef __PARALLEL_HASKELL__
-            fo <- makeForeignObj fo (freeStdFileObject fo)
+	    fo <- mkForeignObj fo
+	  	-- I know this is deprecated, but I couldn't bring myself
+		-- to move fixIO into the prelude just so I could use makeForeignObj.
+		--      --SDM
 #endif
 
 #ifdef __HUGS__
@@ -202,7 +228,13 @@ stdout = unsafePerformIO (do
 	    (bm, bf_size)  <- getBMode__ fo
 	    mkBuffer__ fo bf_size
 #endif
-	    newHandle (Handle__ fo WriteHandle bm "stdout")
+	    hdl <- newHandle (Handle__ fo WriteHandle bm "stdout" [])
+
+#ifndef __PARALLEL_HASKELL__
+	    addForeignFinalizer fo (stdHandleFinalizer hdl)
+#endif
+	    return hdl
+
        _ -> do ioError <- constructError "stdout"
                newHandle (mkErrorHandle__ ioError)
   )
@@ -216,14 +248,17 @@ stdin = unsafePerformIO (do
 			      (1::Int){-readable-}  -- ConcHask: SAFE, won't block
 
 #ifndef __PARALLEL_HASKELL__
-            fo <- makeForeignObj fo (freeStdFileObject fo)
+            fo <- mkForeignObj fo
 #endif
 	    (bm, bf_size) <- getBMode__ fo
 	    mkBuffer__ fo bf_size
-	    hdl <- newHandle (Handle__ fo ReadHandle bm "stdin")
+	    hdl <- newHandle (Handle__ fo ReadHandle bm "stdin" [])
 	     -- when stdin and stdout are both connected to a terminal, ensure
-	     -- that anything buffered on stdout is flushed prior to reading from stdin.
-	     -- 
+	     -- that anything buffered on stdout is flushed prior to reading from 
+	     -- stdin.
+#ifndef __PARALLEL_HASKELL__
+	    addForeignFinalizer fo (stdHandleFinalizer hdl)
+#endif
 	    hConnectTerms stdout hdl
 	    return hdl
        _ -> do ioError <- constructError "stdin"
@@ -240,12 +275,15 @@ stderr = unsafePerformIO (do
 			      (0::Int){-writeable-} -- ConcHask: SAFE, won't block
 
 #ifndef __PARALLEL_HASKELL__
-            fo <- makeForeignObj fo (freeStdFileObject fo)
+            fo <- mkForeignObj fo
 #endif
-            hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
+            hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr" [])
 	    -- when stderr and stdout are both connected to a terminal, ensure
 	    -- that anything buffered on stdout is flushed prior to writing to
 	    -- stderr.
+#ifndef __PARALLEL_HASKELL__
+	    addForeignFinalizer fo (stdHandleFinalizer hdl)
+#endif
 	    hConnectTo stdout hdl
 	    return hdl
 
@@ -280,11 +318,15 @@ openFileEx f m = do
 		       (binary::Int)     -- ConcHask: SAFE, won't block
     if fo /= nullAddr then do
 #ifndef __PARALLEL_HASKELL__
-	fo  <- makeForeignObj fo (freeFileObject fo)
+	fo  <- mkForeignObj fo
 #endif
 	(bm, bf_size)  <- getBMode__ fo
         mkBuffer__ fo bf_size
-	newHandle (Handle__ fo htype bm f)
+	hdl <- newHandle (Handle__ fo htype bm f [])
+#ifndef __PARALLEL_HASKELL__
+	addForeignFinalizer fo (handleFinalizer hdl)
+#endif
+	return hdl
       else do
 	constructErrorAndFailWithInfo "openFile" f
   where
@@ -712,7 +754,7 @@ getBMode__ fo = do
     n  -> return (BlockBuffering (Just n), n)
  where
    default_buffer_size :: Int
-   default_buffer_size = (const_BUFSIZ - 1)
+   default_buffer_size = const_BUFSIZ
 \end{code}
 
 Querying how a handle buffers its data:
@@ -866,73 +908,6 @@ slurpFile fname = do
 	 then constructErrorAndFail "slurpFile"
 	 else return (chunk, rc)
 
-#ifndef __HUGS__ /* Hugs' Prelude doesn't need this */
-hFillBufBA :: Handle -> MutableByteArray RealWorld a -> Int -> IO Int
-hFillBufBA handle buf sz
-  | sz <= 0 = ioError (IOError (Just handle)
-			    InvalidArgument
-		            "hFillBufBA"
-			    ("illegal buffer size " ++ showsPrec 9 sz []))  -- 9 => should be parens'ified.
-  | otherwise = hFillBuf' sz 0
-  where
-  hFillBuf' sz len = do
-	r <- mayBlockRead "hFillBufBA" handle (\fo -> readChunkBA fo buf len sz)
-    	if r >= sz || r == 0  -- r == 0 indicates EOF
-	    then return (len+r)
-	    else hFillBuf' (sz-r) (len+r)
-#endif
-
-hFillBuf :: Handle -> Addr -> Int -> IO Int
-hFillBuf handle buf sz
-  | sz <= 0 = ioError (IOError (Just handle)
-			    InvalidArgument
-		            "hFillBuf"
-			    ("illegal buffer size " ++ showsPrec 9 sz [])) 
-					-- 9 => should be parens'ified.
-  | otherwise = hFillBuf' sz 0
-  where
-  hFillBuf' sz len = do
-	r <- mayBlockRead "hFillBuf" handle (\fo -> readChunk fo buf len sz)
-    	if r >= sz || r == 0  -- r == 0 indicates EOF
-	    then return (len+r)
-	    else hFillBuf' (sz-r) (len+r)
-\end{code}
-
-The @hPutBuf hdl buf len@ action writes an already packed sequence of
-bytes to the file/channel managed by @hdl@ - non-standard.
-
-\begin{code}
-hPutBuf :: Handle -> Addr -> Int -> IO ()
-hPutBuf handle buf sz
-  | sz <= 0 = ioError (IOError (Just handle)
-			    InvalidArgument
-		            "hPutBuf"
-			    ("illegal buffer size " ++ showsPrec 9 sz [])) 
-					-- 9 => should be parens'ified.
-  | otherwise = hPutBuf' sz 0
-  where
-  hPutBuf' sz len = do
-	r <- mayBlockWrite "hPutBuf" handle (\fo -> writeBuf fo buf len sz)
-    	if r >= sz
-	    then return ()
-	    else hPutBuf' (sz-r) (len+r) -- <= sz indicates blocking
-
-#ifndef __HUGS__ /* An_ one Hugs doesn't provide */
-hPutBufBA :: Handle -> MutableByteArray RealWorld a -> Int -> IO ()
-hPutBufBA handle buf sz
-  | sz <= 0 = ioError (IOError (Just handle)
-			    InvalidArgument
-		            "hPutBufBA"
-			    ("illegal buffer size " ++ showsPrec 9 sz [])) 
-					-- 9 => should be parens'ified.
-  | otherwise = hPutBuf' sz 0
-  where
-  hPutBuf' sz len = do
-	r <- mayBlockWrite "hPutBufBA" handle (\fo -> writeBufBA fo buf len sz)
-    	if r >= sz
-	    then return ()
-	    else hPutBuf' (sz-r) (len+r) -- <= sz indicates blocking
-#endif
 \end{code}
 
 Sometimes it's useful to get at the file descriptor that
@@ -1051,13 +1026,21 @@ wantReadableHandle fun handle act =
 
 wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
 wantWriteableHandle fun handle act = 
-    withHandle_ handle $ \ handle_ -> do
-    case haType__ handle_ of 
+    withHandle_ handle $ \ handle_ ->
+	checkWriteableHandle fun handle handle_ (act handle_)
+
+wantWriteableHandle_ :: String -> Handle -> (Handle__ -> IO (Handle__, a)) -> IO a
+wantWriteableHandle_ fun handle act = 
+    withHandle handle $ \ handle_ -> 
+	checkWriteableHandle fun handle handle_ (act handle_)
+
+checkWriteableHandle fun handle handle_ act
+  = case haType__ handle_ of 
       ErrorHandle theError -> ioError theError
       ClosedHandle 	   -> ioe_closedHandle fun handle
       SemiClosedHandle 	   -> ioe_closedHandle fun handle
       ReadHandle 	   -> ioError not_writeable_error
-      _ 		   -> act handle_
+      _ 		   -> act
   where
    not_writeable_error = 
 	   IOError (Just handle) IllegalOperation fun
@@ -1207,10 +1190,14 @@ foreign import "libHS_cbits" "writeFileObject" unsafe
            writeFileObject  :: FILE_OBJECT -> Int -> IO Int{-ret code-}
 foreign import "libHS_cbits" "filePutc" unsafe
            filePutc         :: FILE_OBJECT -> Char -> IO Int{-ret code-}
+foreign import "libHS_cbits" "write_" unsafe
+           write_           :: FILE_OBJECT -> Addr -> Int -> IO Int{-ret code-}
 foreign import "libHS_cbits" "getBufStart" unsafe
            getBufStart      :: FILE_OBJECT -> Int -> IO Addr
 foreign import "libHS_cbits" "getWriteableBuf" unsafe
            getWriteableBuf  :: FILE_OBJECT -> IO Addr
+foreign import "libHS_cbits" "getBuf" unsafe
+           getBuf           :: FILE_OBJECT -> IO Addr
 foreign import "libHS_cbits" "getBufWPtr" unsafe
            getBufWPtr       :: FILE_OBJECT -> IO Int
 foreign import "libHS_cbits" "setBufWPtr" unsafe
@@ -1249,14 +1236,6 @@ foreign import "libHS_cbits" "ungetChar" unsafe
            ungetChar        :: FILE_OBJECT -> Char -> IO Int{-ret code-}
 foreign import "libHS_cbits" "readChunk" unsafe
            readChunk        :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-}
-foreign import "libHS_cbits" "readChunk" unsafe
-           readChunkBA      :: FILE_OBJECT -> MutableByteArray s a -> Int -> Int -> IO Int{-ret code-}
-foreign import "libHS_cbits" "writeBuf" unsafe
-           writeBuf         :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-}
-#ifndef __HUGS__
-foreign import "libHS_cbits" "writeBufBA" unsafe
-           writeBufBA       :: FILE_OBJECT -> MutableByteArray s a -> Int -> Int -> IO Int{-ret code-}
-#endif
 foreign import "libHS_cbits" "getFileFd" unsafe
            getFileFd        :: FILE_OBJECT -> IO Int{-fd-}
 #ifdef __HUGS__
diff --git a/ghc/lib/std/PrelIO.lhs b/ghc/lib/std/PrelIO.lhs
index 237b333..321a664 100644
--- a/ghc/lib/std/PrelIO.lhs
+++ b/ghc/lib/std/PrelIO.lhs
@@ -19,20 +19,20 @@ import PrelBase
 import PrelIOBase
 import PrelHandle	-- much of the real stuff is in here
 
+import PrelNum
 import PrelRead         ( readParen, Read(..), reads, lex,
 			  readIO 
 			)
 import PrelShow
 import PrelMaybe	( Either(..), Maybe(..) )
-import PrelAddr		( Addr(..), nullAddr )
+import PrelAddr		( Addr(..), AddrOff(..), nullAddr, plusAddr )
 import PrelByteArr	( ByteArray )
 import PrelPack		( unpackNBytesAccST )
-import PrelException    ( ioError, catch )
+import PrelException    ( ioError, catch, catchException, throw, blockAsyncExceptions )
 import PrelConc
 \end{code}
 
 
-
 %*********************************************************
 %*							 *
 \subsection{Standard IO}
@@ -304,38 +304,188 @@ buffering is enabled for @hdl@
 \begin{code}
 hPutChar :: Handle -> Char -> IO ()
 hPutChar handle c = 
+    c `seq` do   -- must evaluate c before grabbing the handle lock
     wantWriteableHandle "hPutChar" handle $ \ handle_  -> do
     let fo = haFO__ handle_
     flushConnectedBuf fo
-    rc       <- mayBlock fo (filePutc fo c)   -- ConcHask: UNSAFE, may block.
+    rc <- mayBlock fo (filePutc fo c)   -- ConcHask: UNSAFE, may block.
     if rc == 0
      then return ()
      else constructErrorAndFail "hPutChar"
 
+hPutChars :: Handle -> [Char] -> IO ()
+hPutChars handle [] = return ()
+hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
 \end{code}
 
 @hPutStr hdl s@ writes the string @s@ to the file or
 channel managed by @hdl@, buffering the output if needs be.
 
+
 \begin{code}
 hPutStr :: Handle -> String -> IO ()
-hPutStr handle str = 
-    wantWriteableHandle "hPutStr" handle $ \ handle_ -> do
-    let fo = haFO__ handle_
-    flushConnectedBuf fo
-    case haBufferMode__ handle_ of
-       LineBuffering -> do
-	    buf <- getWriteableBuf fo
-	    pos <- getBufWPtr fo
-	    bsz <- getBufSize fo
-	    writeLines fo buf bsz pos str
-       BlockBuffering _ -> do
-	    buf <- getWriteableBuf fo
-	    pos <- getBufWPtr fo
-	    bsz <- getBufSize fo
-            writeBlocks fo buf bsz pos str
-       NoBuffering -> do
-	    writeChars fo str
+hPutStr handle str = do
+    buffer_mode <- wantWriteableHandle_ "hPutStr" handle 
+			(\ handle_ -> do getBuffer handle_)
+    case buffer_mode of
+       (NoBuffering, _, _) -> do
+	    hPutChars handle str	-- v. slow, but we don't care
+       (LineBuffering, buf, bsz) -> do
+	    writeLines handle buf bsz str
+       (BlockBuffering _, buf, bsz) -> do
+            writeBlocks handle buf bsz str
+	-- ToDo: async exceptions during writeLines & writeBlocks will cause
+	-- the buffer to get lost in the void.  Using ByteArrays instead of
+	-- malloced buffers is one way around this, but we really ought to
+	-- be able to handle it with exception handlers/block/unblock etc.
+
+getBuffer :: Handle__ -> IO (Handle__, (BufferMode, Addr, Int))
+getBuffer handle_ = do
+   let bufs = haBuffers__ handle_
+       fo   = haFO__ handle_
+       mode = haBufferMode__ handle_	
+   sz <- getBufSize fo
+   case mode of
+	NoBuffering -> return (handle_, (mode, nullAddr, 0))
+	_ -> case bufs of
+		[] -> do  buf <- allocMemory__ sz
+			  return (handle_, (mode, buf, sz))
+		(b:bs) -> return (handle_{ haBuffers__ = bs }, (mode, b, sz))
+
+freeBuffer :: Handle__ -> Addr -> Int -> IO Handle__
+freeBuffer handle_ buf sz = do
+   fo_sz <- getBufSize (haFO__ handle_)
+   if (sz /= fo_sz) 
+	then do { free buf; return handle_ }
+	else do { return handle_{ haBuffers__ = buf : haBuffers__ handle_ } }
+
+swapBuffers :: Handle__ -> Addr -> Int -> IO Handle__
+swapBuffers handle_ buf sz = do
+   let fo = haFO__ handle_
+   fo_buf <- getBuf fo
+   setBuf fo buf sz
+   return (handle_{ haBuffers__ = fo_buf : haBuffers__ handle_ })
+
+-- commitBuffer handle buf sz count flush
+-- 
+-- Write the contents of the buffer 'buf' ('sz' bytes long, containing
+-- 'count' bytes of data) to handle (handle must be block or line buffered).
+-- 
+-- Implementation:
+-- 
+--    for block/line buffering,
+-- 	 1. If there isn't room in the handle buffer, flush the handle
+-- 	    buffer.
+-- 
+-- 	 2. If the handle buffer is empty,
+-- 		 if flush, 
+-- 		     then write buf directly to the device.
+-- 		     else swap the handle buffer with buf.
+-- 
+-- 	 3. If the handle buffer is non-empty, copy buf into the
+-- 	    handle buffer.  Then, if flush != 0, flush
+-- 	    the buffer.
+
+commitAndReleaseBuffer
+	:: Handle			-- handle to commit to
+	-> Addr -> Int			-- address and size (in bytes) of buffer
+	-> Int				-- number of bytes of data in buffer
+	-> Bool				-- flush the handle afterward?
+	-> IO ()
+commitAndReleaseBuffer hdl@(Handle h) buf sz count flush = do
+      h_ <- takeMVar h
+
+	-- First deal with any possible exceptions by freeing the buffer.
+	-- Async exceptions are blocked, but there are still some interruptible
+	-- ops below.
+
+	-- note that commit doesn't *always* free the buffer, it might
+	-- swap it for the current handle buffer instead.  This makes things
+	-- a whole lot more complicated, because we can't just do 
+	-- "finally (... free buffer ...)" here.
+      catchException (commit hdl h_) 
+		     (\e -> do { h_ <- freeBuffer h_ buf sz; putMVar h h_ })
+
+  where
+   commit hdl@(Handle h) handle_ = 
+     checkWriteableHandle "commitAndReleaseBuffer" hdl handle_ $ do
+      let fo = haFO__ handle_
+      flushConnectedBuf fo		-- ????  -SDM
+      getWriteableBuf fo		-- flush read buf if necessary
+      fo_buf     <- getBuf fo
+      fo_wptr    <- getBufWPtr fo
+      fo_bufSize <- getBufSize fo
+
+      let ok    h_ = putMVar h h_ >> return ()
+
+      if (fo_bufSize - fo_wptr < count)	-- not enough room in handle buffer?
+
+	    then do rc <- mayBlock fo (flushFile fo)
+		    if (rc < 0) 
+			then constructErrorAndFail "commitBuffer"
+			else
+		     if flush || sz /= fo_bufSize
+			then do rc <- write_buf fo buf count
+		    		if (rc < 0)
+					then constructErrorAndFail "commitBuffer"
+			      		else do handle_ <- freeBuffer handle_ buf sz
+					        ok handle_
+
+			-- don't have to flush, and the new buffer is the
+			-- same size as the old one, so just swap them...
+			else do handle_ <- swapBuffers handle_ buf sz
+				setBufWPtr fo count
+				ok handle_
+
+	    else do memcpy (plusAddr fo_buf (AddrOff# fo_wptr)) buf count
+		    setBufWPtr fo (fo_wptr + count)
+		    if flush 
+			then do rc <- mayBlock fo (flushFile fo)
+				if (rc < 0) 
+					then constructErrorAndFail "commitBuffer"
+					else do handle_ <- freeBuffer handle_ buf sz
+						ok handle_
+			else do handle_ <- freeBuffer handle_ buf sz
+				ok handle_
+
+commitBuffer
+	:: Handle			-- handle to commit to
+	-> Addr -> Int			-- address and size (in bytes) of buffer
+	-> Int				-- number of bytes of data in buffer
+	-> Bool				-- flush the handle afterward?
+	-> IO ()
+commitBuffer handle buf sz count flush = do
+    wantWriteableHandle "commitBuffer" handle $ \handle_ -> do
+      let fo = haFO__ handle_
+      flushConnectedBuf fo		-- ????  -SDM
+      getWriteableBuf fo		-- flush read buf if necessary
+      fo_buf     <- getBuf fo
+      fo_wptr    <- getBufWPtr fo
+      fo_bufSize <- getBufSize fo
+
+      (if (fo_bufSize - fo_wptr < count)  -- not enough room in handle buffer?
+	    then mayBlock fo (flushFile fo)
+	    else return 0)
+
+      if (fo_bufSize < count)		-- committed buffer too large?
+
+	    then do rc <- write_buf fo buf count
+		    if rc < 0 then constructErrorAndFail "commitBuffer"
+			      else return ()
+
+	    else do memcpy (plusAddr fo_buf (AddrOff# fo_wptr)) buf count
+		    setBufWPtr fo (fo_wptr + count)
+		    (if flush then mayBlock fo (flushFile fo) else return 0)
+		    return ()
+
+write_buf fo buf 0 = return 0
+write_buf fo buf count = do
+  rc <- mayBlock fo (write_ fo buf count)
+  if (rc > 0)
+	then  write_buf fo buf (count - rc) -- partial write
+	else  return rc
+
+foreign import "memcpy" unsafe memcpy :: Addr -> Addr -> Int -> IO ()
 \end{code}
 
 Going across the border between Haskell and C is relatively costly,
@@ -350,193 +500,100 @@ before passing the external write routine a pointer to the buffer.
 #warning delayed update of buffer disnae work with killThread
 #endif
 
-#ifndef __PARALLEL_HASKELL__
-writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
-#else
-writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
-#endif
-writeLines obj buf bufLen initPos s =
+writeLines :: Handle -> Addr -> Int -> String -> IO ()
+writeLines handle buf bufLen s =
   let
    shoveString :: Int -> [Char] -> IO ()
    shoveString n ls = 
      case ls of
-      [] ->   
-	  {-
-	    At the end of a buffer write, update the buffer position
-	    in the underlying file object, so that if the handle
-	    is subsequently dropped by the program, the whole
-	    buffer will be properly flushed.
-
-	    There's one case where this delayed up-date of the buffer
-	    position can go wrong: if a thread is killed, it might be
-	    in the middle of filling up a buffer, with the result that
-	    the partial buffer update is lost upon finalisation. Not
-	    that killing of threads is supported at the moment.
-
-	  -}
-	  setBufWPtr obj n
+      [] -> commitAndReleaseBuffer handle buf buflen n False{-no need to flush-}
 
       (x:xs) -> do
         primWriteCharOffAddr buf n x
           {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
-	if n == bufLen || x == '\n'
+	let next_n = n + 1
+	if next_n == bufLen || x == '\n'
 	 then do
-	   rc <-  mayBlock obj (writeFileObject obj (n + 1))  -- ConcHask: UNSAFE, may block.
-	   if rc == 0 
-	    then shoveString 0 xs
-	    else constructErrorAndFail "writeLines"
+	   commitBuffer hdl buf len next_n True{-needs flush-} 
+	   shoveString 0 xs
          else
-	   shoveString (n + 1) xs
+	   shoveString next_n xs
   in
-  shoveString initPos s
+  shoveString 0 s
+
 #else /* ndef __HUGS__ */
-#ifndef __PARALLEL_HASKELL__
-writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
-#else
-writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
-#endif
-writeLines obj buf (I# bufLen) (I# initPos#) s =
-  let
-   write_char :: Addr -> Int# -> Char# -> IO ()
-   write_char (A# buf#) n# c# =
-      IO $ \ s# ->
-      case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
 
+writeLines :: Handle -> Addr -> Int -> String -> IO ()
+writeLines hdl buf len@(I# bufLen) s =
+  let
    shoveString :: Int# -> [Char] -> IO ()
    shoveString n ls = 
      case ls of
-      [] ->   
-	  {-
-	    At the end of a buffer write, update the buffer position
-	    in the underlying file object, so that if the handle
-	    is subsequently dropped by the program, the whole
-	    buffer will be properly flushed.
-
-	    There's one case where this delayed up-date of the buffer
-	    position can go wrong: if a thread is killed, it might be
-	    in the middle of filling up a buffer, with the result that
-	    the partial buffer update is lost upon finalisation. Not
-	    that killing of threads is supported at the moment.
-
-	  -}
-	  setBufWPtr obj (I# n)
+      [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-}
 
       ((C# x):xs) -> do
         write_char buf n x
-          {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
-	if n ==# bufLen || x `eqChar#` '\n'#
+          -- Flushing on buffer exhaustion or newlines 
+	  -- (even if it isn't the last one)
+	let next_n = n +# 1#
+	if next_n ==# bufLen || x `eqChar#` '\n'#
 	 then do
-	   rc <-  mayBlock obj (writeFileObject obj (I# (n +# 1#)))  -- ConcHask: UNSAFE, may block.
-	   if rc == 0 
-	    then shoveString 0# xs
-	    else constructErrorAndFail "writeLines"
+	   commitBuffer hdl buf len (I# next_n) True{-needs flush-} 
+	   shoveString 0# xs
          else
-	   shoveString (n +# 1#) xs
+	   shoveString next_n xs
   in
-  shoveString initPos# s
+  shoveString 0# s
 #endif /* ndef __HUGS__ */
 
 #ifdef __HUGS__
-#ifndef __PARALLEL_HASKELL__
-writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
-#else
-writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
-#endif
-writeBlocks obj buf bufLen initPos s =
+writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
+writeBlocks hdl buf bufLen s =
   let
    shoveString :: Int -> [Char] -> IO ()
    shoveString n ls = 
      case ls of
-      [] ->   
-	  {-
-	    At the end of a buffer write, update the buffer position
-	    in the underlying file object, so that if the handle
-	    is subsequently dropped by the program, the whole
-	    buffer will be properly flushed.
-
-	    There's one case where this delayed up-date of the buffer
-	    position can go wrong: if a thread is killed, it might be
-	    in the middle of filling up a buffer, with the result that
-	    the partial buffer update is lost upon finalisation. However,
-	    by the time killThread is supported, Haskell finalisers are also
-	    likely to be in, which means the 'IOFileObject' hack can go
-	    alltogether.
-
-	  -}
-	  setBufWPtr obj n
+      [] -> commitAndReleaseBuffer hdl buf len n False{-no need to flush-} 
 
       (x:xs) -> do
         primWriteCharOffAddr buf n x
-	if n == bufLen
+	let next_n = n + 1
+	if next_n == bufLen
 	 then do
-	   rc <-  mayBlock obj (writeFileObject obj (n + 1))   -- ConcHask: UNSAFE, may block.
-	   if rc == 0 
-            then shoveString 0 xs
-	    else constructErrorAndFail "writeChunks"
+	   commitBuffer hdl buf len next_n True{-needs flush-}
+	   shoveString 0 xs
          else
-	   shoveString (n + 1) xs
+	   shoveString next_n xs
   in
-  shoveString initPos s
+  shoveString 0 s
+
 #else /* ndef __HUGS__ */
-#ifndef __PARALLEL_HASKELL__
-writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
-#else
-writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
-#endif
-writeBlocks obj buf (I# bufLen) (I# initPos#) s =
-  let
-   write_char :: Addr -> Int# -> Char# -> IO ()
-   write_char (A# buf#) n# c# =
-      IO $ \ s# ->
-      case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
 
+writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
+writeBlocks hdl buf len@(I# bufLen) s =
+  let
    shoveString :: Int# -> [Char] -> IO ()
    shoveString n ls = 
      case ls of
-      [] ->   
-	  {-
-	    At the end of a buffer write, update the buffer position
-	    in the underlying file object, so that if the handle
-	    is subsequently dropped by the program, the whole
-	    buffer will be properly flushed.
-
-	    There's one case where this delayed up-date of the buffer
-	    position can go wrong: if a thread is killed, it might be
-	    in the middle of filling up a buffer, with the result that
-	    the partial buffer update is lost upon finalisation. However,
-	    by the time killThread is supported, Haskell finalisers are also
-	    likely to be in, which means the 'IOFileObject' hack can go
-	    alltogether.
-
-	  -}
-	  setBufWPtr obj (I# n)
+      [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-} 
 
       ((C# x):xs) -> do
         write_char buf n x
-	if n ==# bufLen
+	let next_n = n +# 1#
+	if next_n ==# bufLen
 	 then do
-	   rc <-  mayBlock obj (writeFileObject obj (I# (n +# 1#)))   -- ConcHask: UNSAFE, may block.
-	   if rc == 0 
-	    then shoveString 0# xs
-	    else constructErrorAndFail "writeChunks"
+	   commitBuffer hdl buf len (I# next_n) True{-needs flush-}
+	   shoveString 0# xs
          else
-	   shoveString (n +# 1#) xs
+	   shoveString next_n xs
   in
-  shoveString initPos# s
-#endif /* ndef __HUGS__ */
-
-#ifndef __PARALLEL_HASKELL__
-writeChars :: ForeignObj -> String -> IO ()
-#else
-writeChars :: Addr -> String -> IO ()
-#endif
-writeChars _fo ""    = return ()
-writeChars fo (c:cs) = do
-  rc <- mayBlock fo (filePutc fo c)   -- ConcHask: UNSAFE, may block.
-  if rc == 0 
-   then writeChars fo cs
-   else constructErrorAndFail "writeChars"
+  shoveString 0# s
 
+write_char :: Addr -> Int# -> Char# -> IO ()
+write_char (A# buf#) n# c# =
+   IO $ \ s# ->
+   case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
+#endif /* ndef __HUGS__ */
 \end{code}
 
 Computation @hPrint hdl t@ writes the string representation of {\em t}
diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs
index 7782c2a..e83ddd5 100644
--- a/ghc/lib/std/PrelIOBase.lhs
+++ b/ghc/lib/std/PrelIOBase.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.21 2000/04/10 16:02:58 simonpj Exp $
+% $Id: PrelIOBase.lhs,v 1.22 2000/04/12 17:33:16 simonmar Exp $
 % 
 % (c) The AQUA Project, Glasgow University, 1994-1998
 %
@@ -434,8 +434,9 @@ data Handle__
       haFO__	      :: FILE_OBJECT,
       haType__        :: Handle__Type,
       haBufferMode__  :: BufferMode,
-      haFilePath__    :: FilePath
-    }      
+      haFilePath__    :: FilePath,
+      haBuffers__     :: [Addr]
+    }
 
 {-
   Internally, we classify handles as being one
diff --git a/ghc/lib/std/cbits/Makefile b/ghc/lib/std/cbits/Makefile
index 391a09d..abb7f00 100644
--- a/ghc/lib/std/cbits/Makefile
+++ b/ghc/lib/std/cbits/Makefile
@@ -1,4 +1,4 @@
-# $Id: Makefile,v 1.14 2000/03/17 17:05:27 rrt Exp $
+# $Id: Makefile,v 1.15 2000/04/12 17:33:16 simonmar Exp $
 
 TOP = ../../..
 include $(TOP)/mk/boilerplate.mk
@@ -43,6 +43,15 @@ CC=$(GHC_INPLACE)
 SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR)
 
 # -----------------------------------------------------------------------------
+
+SO_OBJS  = $(C_SRCS:.c=.$(way_)so)
+
+libHS_cbits.so : $(SO_OBJS)
+	$(CC) -shared -o libHS_cbits.so $(SO_OBJS)
+
+CC = $(WhatGccIsCalled)
+
+# -----------------------------------------------------------------------------
 # Installation
 
 INSTALL_LIBS+=$(LIBRARY)
diff --git a/ghc/lib/std/cbits/fileObject.c b/ghc/lib/std/cbits/fileObject.c
index 30bfe17..617fca2 100644
--- a/ghc/lib/std/cbits/fileObject.c
+++ b/ghc/lib/std/cbits/fileObject.c
@@ -1,7 +1,7 @@
 /* 
  * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
  *
- * $Id: fileObject.c,v 1.8 1999/11/26 16:25:56 simonmar Exp $
+ * $Id: fileObject.c,v 1.9 2000/04/12 17:33:16 simonmar Exp $
  *
  * hPutStr Runtime Support
  */
@@ -155,5 +155,6 @@ fill_up_line_buffer(IOFileObject* fo)
       }
   }
   fo->bufWPtr += count;
+/* TODO: ipos doesn't change???? what's it for??? --SDM */
   return (fo->bufWPtr - ipos);
 }
diff --git a/ghc/lib/std/cbits/fileObject.h b/ghc/lib/std/cbits/fileObject.h
index 4c36977..df97061 100644
--- a/ghc/lib/std/cbits/fileObject.h
+++ b/ghc/lib/std/cbits/fileObject.h
@@ -14,18 +14,6 @@ typedef struct _IOFileObject {
    int     fd;
    void*   buf;
 
-   int     bufStart; /* offset of start of data waiting to
-			be written.  This may be non-zero in
-			the case where we wrote out some of the
-			buffer, and then blocked.
-
-			NOTE: this field should be non-zero *only*
-			when we just blocked on a call to writeBuffer,
-			and we're going to restart the call when
-			we unblock.  It should be zero at all other
-			times.
-		     */
-
    int     bufWPtr;  /* points to next position to write,
    			  bufRPtr >= bufWPtr <= bufSize.
 			  
@@ -44,6 +32,7 @@ typedef struct _IOFileObject {
    int     bufSize;
    int     flags;
    struct _IOFileObject*   connectedTo;
+
 } IOFileObject;
 
 #define FILEOBJ_LB       2
diff --git a/ghc/lib/std/cbits/flushFile.c b/ghc/lib/std/cbits/flushFile.c
index 4416559..5631f38 100644
--- a/ghc/lib/std/cbits/flushFile.c
+++ b/ghc/lib/std/cbits/flushFile.c
@@ -1,7 +1,7 @@
 /* 
  * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
  *
- * $Id: flushFile.c,v 1.6 1999/11/25 16:54:14 simonmar Exp $
+ * $Id: flushFile.c,v 1.7 2000/04/12 17:33:16 simonmar Exp $
  *
  * hFlush Runtime Support
  */
@@ -38,6 +38,10 @@ flushBuffer(StgForeignPtr ptr)
        if (rc<0) return rc;
     }
     
+    /* TODO: shouldn't we do the lseek stuff from flushReadBuffer
+     * here???? --SDM
+     */
+
     /* Reset read & write pointer for input buffers */
     if ( (fo->flags & FILEOBJ_READ) ) {
        fo->bufRPtr=0;
diff --git a/ghc/lib/std/cbits/openFile.c b/ghc/lib/std/cbits/openFile.c
index 3b827e5..8930fe5 100644
--- a/ghc/lib/std/cbits/openFile.c
+++ b/ghc/lib/std/cbits/openFile.c
@@ -1,7 +1,7 @@
 /* 
  * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
  *
- * $Id: openFile.c,v 1.15 1999/12/14 14:26:14 simonmar Exp $
+ * $Id: openFile.c,v 1.16 2000/04/12 17:33:16 simonmar Exp $
  *
  * openFile Runtime Support
  */
@@ -44,7 +44,6 @@ openStdFile(StgInt fd, StgInt rd)
     fo->buf      = NULL;
     fo->bufWPtr  = 0;
     fo->bufRPtr  = 0;
-    fo->bufStart = 0;
     fo->flags    = FILEOBJ_STD | ( rd ? FILEOBJ_READ : FILEOBJ_WRITE);
     fo->connectedTo = NULL;
  
@@ -281,7 +280,6 @@ openFile(StgByteArray file, StgInt how, StgInt binary)
 
     fo->fd       = fd;
     fo->buf      = NULL;
-    fo->bufStart = 0;
     fo->bufWPtr  = 0;
     fo->bufRPtr  = 0;
     fo->flags    = flags;
@@ -318,7 +316,6 @@ openFd(StgInt fd, StgInt oflags, StgInt flags)
        return NULL;
     fo->fd       = fd;
     fo->buf      = NULL;
-    fo->bufStart = 0;
     fo->bufWPtr  = 0;
     fo->bufRPtr  = 0;
     fo->flags    = flags | ( oflags & O_RDONLY ? FILEOBJ_READ 
diff --git a/ghc/lib/std/cbits/readFile.c b/ghc/lib/std/cbits/readFile.c
index 5c9256c..8393d07 100644
--- a/ghc/lib/std/cbits/readFile.c
+++ b/ghc/lib/std/cbits/readFile.c
@@ -1,7 +1,7 @@
 /* 
  * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
  *
- * $Id: readFile.c,v 1.14 2000/04/04 11:01:33 simonmar Exp $
+ * $Id: readFile.c,v 1.15 2000/04/12 17:33:16 simonmar Exp $
  *
  * hGetContents Runtime Support
  */
@@ -114,6 +114,7 @@ readBlock(StgForeignPtr ptr)
  *                                 buffer of connected handle.
  *  FILEOBJ_BLOCKED_READ           didn't read anything; would block
  *  n, where n > 0                 read n bytes into buffer.
+ *  0				   EOF has been reached
  */
 
 StgInt
@@ -134,9 +135,7 @@ readChunk(StgForeignPtr ptr, StgAddr buf, StgInt off, StgInt len)
        return -2;
 
     if ( FILEOBJ_IS_EOF(fo) ) {
-	ghc_errtype = ERR_EOF;
-	ghc_errstr = "";
-	return -1;
+        return 0;
     }
 
     /* if input stream is connect to an output stream, flush it first */
@@ -191,24 +190,20 @@ readChunk(StgForeignPtr ptr, StgAddr buf, StgInt off, StgInt len)
         /* EOF */
 	if ( count == 0 ) {
             FILEOBJ_SET_EOF(fo);
-            if ( total_count == 0 ) {
-                ghc_errtype = ERR_EOF;
-	        ghc_errstr = "";
-	        return -1;
-	    } else {
-                return total_count;
-	    }
+            return total_count;
+	}
 
         /* Blocking */
-	} else if ( count == -1 && errno == EAGAIN) {
+	else if ( count == -1 && errno == EAGAIN) {
 	    errno = 0;
             if (total_count > 0) 
                return total_count; /* partial read */
 	    else
 	       return FILEOBJ_BLOCKED_READ;
+	}
 
         /* Error */
-	} else if ( count == -1 && errno != EINTR) {
+	else if ( count == -1 && errno != EINTR) {
 	    cvtErrno();
 	    stdErrno();
 	    return -1;
@@ -268,9 +263,10 @@ readLine(StgForeignPtr ptr)
     fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
 
     if ( fo->bufRPtr < 0 || fo->bufRPtr >= fo->bufWPtr ) { /* Buffer is empty */
-       fo->bufRPtr=0; fo->bufWPtr=0;
-       rc = fill_up_line_buffer(fo);
-       if (rc < 0) return rc;
+        fo->bufRPtr=0; 
+	fo->bufWPtr=0;
+        rc = fill_up_line_buffer(fo);
+        if (rc < 0) return rc;
     }
 
     while (1) {
diff --git a/ghc/lib/std/cbits/stgio.h b/ghc/lib/std/cbits/stgio.h
index 6c784da..0906380 100644
--- a/ghc/lib/std/cbits/stgio.h
+++ b/ghc/lib/std/cbits/stgio.h
@@ -1,5 +1,5 @@
 /* -----------------------------------------------------------------------------
- * $Id: stgio.h,v 1.18 2000/04/11 20:44:18 panne Exp $
+ * $Id: stgio.h,v 1.19 2000/04/12 17:33:16 simonmar Exp $
  *
  * (c) The GRASP/AQUA Project, Glasgow University, 1994-1999
  *
@@ -233,6 +233,7 @@ StgInt	writeBuf  (StgForeignPtr, StgAddr, StgInt, StgInt);
 StgInt	writeBufBA  (StgForeignPtr, StgByteArray, StgInt, StgInt);
 StgInt	writeFileObject (StgForeignPtr, StgInt);
 StgInt	writeBuffer (StgForeignPtr, StgInt);
+StgInt  write_ (StgForeignPtr ptr, StgAddr buf, StgInt len);
 
 #endif /* ! STGIO_H */
 
diff --git a/ghc/lib/std/cbits/writeFile.c b/ghc/lib/std/cbits/writeFile.c
index eed60e9..383ec52 100644
--- a/ghc/lib/std/cbits/writeFile.c
+++ b/ghc/lib/std/cbits/writeFile.c
@@ -1,7 +1,7 @@
 /* 
  * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
  *
- * $Id: writeFile.c,v 1.13 2000/03/10 15:23:40 simonmar Exp $
+ * $Id: writeFile.c,v 1.14 2000/04/12 17:33:16 simonmar Exp $
  *
  * hPutStr Runtime Support
  */
@@ -41,13 +41,13 @@ writeBuffer(StgForeignPtr ptr, StgInt bytes)
     int count;
     IOFileObject* fo = (IOFileObject*)ptr;
 
-    char *pBuf = (char *) fo->buf + fo->bufStart;
+    char *pBuf = (char *) fo->buf + fo->bufRPtr;
 
-    bytes -= fo->bufStart;
+    bytes -= fo->bufRPtr;
 
     /* Disallow short writes */
     if (bytes == 0  || fo->buf == NULL) {
-        fo->bufStart = 0;
+        fo->bufRPtr = 0;
 	return 0;
     }
 
@@ -72,12 +72,12 @@ writeBuffer(StgForeignPtr ptr, StgInt bytes)
         else {
 	    bytes -= count;
 	    pBuf  += count;
-            fo->bufStart += count;
+            fo->bufRPtr += count;
         }
     }
     /* Signal that we've emptied the buffer */
-    fo->bufStart = 0;
-    fo->bufWPtr  = 0;
+    fo->bufRPtr = 0;
+    fo->bufWPtr = 0;
     return 0;
 }
 
@@ -164,3 +164,35 @@ writeBufBA(StgForeignPtr ptr, StgByteArray buf, StgInt off, StgInt len)
 { 
     return (writeBuf(ptr,(StgAddr)buf, off, len)); 
 }
+
+/* -----------------------------------------------------------------------------
+ * write_  is just a simple wrapper around write/2 that restarts
+ * on EINTR and returns FILEOBJ_BLOCKED_WRITE on EAGAIN.
+ * -------------------------------------------------------------------------- */
+
+StgInt
+write_(StgForeignPtr ptr, StgAddr buf, StgInt len)
+{
+    IOFileObject* fo = (IOFileObject*)ptr;
+    int rc;
+
+    while ((rc = 
+               (
+#ifdef USE_WINSOCK
+	         fo->flags & FILEOBJ_WINSOCK ?
+		 send(fo->fd,  buf, (int)len, 0) :
+		 write(fo->fd, buf, (int)len))) < 0 ) {
+#else
+		 write(fo->fd, buf, (int)len))) < 0 ) {
+#endif
+	if ( errno == EAGAIN ) {
+            errno = 0;
+            return FILEOBJ_BLOCKED_WRITE;
+	} else if ( errno != EINTR ) {
+	    cvtErrno();
+	    stdErrno();
+	    return -1;
+	}
+    }
+    return rc;
+}  
-- 
1.7.10.4