From: simonmar <unknown>
Date: Fri, 11 Apr 2003 14:24:07 +0000 (+0000)
Subject: [project @ 2003-04-11 14:24:07 by simonmar]
X-Git-Tag: nhc98-1-18-release~692
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=07eff4a801f1a578a1903d061604ee5fa65633fb;p=ghc-base.git

[project @ 2003-04-11 14:24:07 by simonmar]
Plug a file descriptor leak: when finalizing a handle, we should
ignore errors in the flushing operation and go ahead and close the
handle anyway.

Spotted by: Keean [k.schupke@ic.ac.uk]
---

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 0716477..f739e84 100644
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -319,9 +319,14 @@ stdHandleFinalizer m = do
 
 handleFinalizer :: MVar Handle__ -> IO ()
 handleFinalizer m = do
-  h_ <- takeMVar m
-  hClose_help h_
-  return ()
+  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
@@ -856,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
+      Just _  -> return ()
 
-	  -- 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
-			 })
+    -- 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