X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=eae9a3affdadfd33d68333fc831052f4c0aa2801;hb=75ea0fa2485c169f0546d5d40477d2f6747efe29;hp=260074d6b89c9494fdf0f2af7e877beacc67cbd4;hpb=967f7424d2713bbe35d2480d3f621f74305e539d;p=ghc-base.git

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 260074d..eae9a3a 100644
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -60,8 +60,8 @@ import Data.Maybe
 import Foreign
 import Foreign.C
 import System.IO.Error
+import System.Posix.Internals
 
-import GHC.Posix
 import GHC.Real
 
 import GHC.Arr
@@ -319,24 +319,14 @@ stdHandleFinalizer m = do
 
 handleFinalizer :: MVar Handle__ -> IO ()
 handleFinalizer m = do
-  h_ <- takeMVar m
-  let
-    -- hClose puts both the fd and the handle's type
-    -- into a closed state, so it's a bit excessive
-    -- to test for both here, but caution sometimes
-    -- pays off..
-   alreadyClosed = 
-     case haType h_ of { ClosedHandle{} -> True; _ -> False }
-   fd = fromIntegral (haFD h_)
-
-  when (not alreadyClosed && fd /= -1) $ do
-       flushWriteBufferOnly h_
-       unlockFile fd
-#ifdef mingw32_TARGET_OS
-       (closeFd (haIsStream h_) fd >> return ())
-#else
-       (c_close fd >> return ())
-#endif
+  handle_ <- takeMVar m
+  case haType handle_ of 
+      ClosedHandle -> return ()
+      _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
+		-- ignore errors and async exceptions, and close the
+		-- descriptor anyway...
+	      hClose_handle_ handle_
+	      return ()
 
 -- ---------------------------------------------------------------------------
 -- Grimy buffer operations
@@ -839,7 +829,7 @@ mkDuplexHandle fd is_stream filepath binary = do
 		      }
   read_side <- newMVar r_handle_
 
-  addMVarFinalizer read_side (handleFinalizer read_side)
+  addMVarFinalizer write_side (handleFinalizer write_side)
   return (DuplexHandle read_side write_side)
    
 
@@ -871,37 +861,38 @@ hClose_help :: Handle__ -> IO Handle__
 hClose_help handle_ =
   case haType handle_ of 
       ClosedHandle -> return handle_
-      _ -> do
-	  let fd = haFD handle_
-	      c_fd = fromIntegral fd
-
-	  flushWriteBufferOnly handle_
-
-	  -- close the file descriptor, but not when this is the read
-	  -- side of a duplex handle, and not when this is one of the
-	  -- std file handles.
-	  case haOtherSide handle_ of
-	    Nothing -> 
-		when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
-			throwErrnoIfMinus1Retry_ "hClose" 
+      _ -> do flushWriteBufferOnly handle_ -- interruptible
+	      hClose_handle_ handle_
+
+hClose_handle_ handle_ = do
+    let fd = haFD handle_
+        c_fd = fromIntegral fd
+
+    -- close the file descriptor, but not when this is the read
+    -- side of a duplex handle, and not when this is one of the
+    -- std file handles.
+    case haOtherSide handle_ of
+      Nothing -> 
+  	  when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
+  		  throwErrnoIfMinus1Retry_ "hClose" 
 #ifdef mingw32_TARGET_OS
 	    			(closeFd (haIsStream handle_) c_fd)
 #else
 	    			(c_close c_fd)
 #endif
-	    Just _  -> return ()
-
-	  -- free the spare buffers
-	  writeIORef (haBuffers handle_) BufferListNil
-
-	  -- unlock it
-	  unlockFile c_fd
+      Just _  -> return ()
 
-	  -- we must set the fd to -1, because the finalizer is going
-	  -- to run eventually and try to close/unlock it.
-	  return (handle_{ haFD        = -1, 
-		    	   haType      = ClosedHandle
-			 })
+    -- free the spare buffers
+    writeIORef (haBuffers handle_) BufferListNil
+  
+    -- unlock it
+    unlockFile c_fd
+  
+    -- we must set the fd to -1, because the finalizer is going
+    -- to run eventually and try to close/unlock it.
+    return (handle_{ haFD        = -1, 
+  		     haType      = ClosedHandle
+  		   })
 
 -----------------------------------------------------------------------------
 -- Detecting the size of a file
@@ -1257,10 +1248,9 @@ hIsSeekable handle =
 						|| tEXT_MODE_SEEK_ALLOWED))
 
 -- -----------------------------------------------------------------------------
--- Changing echo status
+-- Changing echo status (Non-standard GHC extensions)
 
--- Non-standard GHC extension is to allow the echoing status
--- of a handles connected to terminals to be reconfigured:
+-- | Set the echoing status of a handle connected to a terminal (GHC only).
 
 hSetEcho :: Handle -> Bool -> IO ()
 hSetEcho handle on = do
@@ -1273,6 +1263,8 @@ hSetEcho handle on = do
          ClosedHandle -> ioe_closedHandle
          _            -> setEcho (haFD handle_) on
 
+-- | Get the echoing status of a handle connected to a terminal (GHC only).
+
 hGetEcho :: Handle -> IO Bool
 hGetEcho handle = do
     isT   <- hIsTerminalDevice handle
@@ -1284,6 +1276,8 @@ hGetEcho handle = do
          ClosedHandle -> ioe_closedHandle
          _            -> getEcho (haFD handle_)
 
+-- | Is the handle connected to a terminal? (GHC only)
+
 hIsTerminalDevice :: Handle -> IO Bool
 hIsTerminalDevice handle = do
     withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do