Move file locking into the RTS, fixing #629, #1109

File locking (of the Haskell 98 variety) was previously done using a
static table with linear search, which had two problems: the array had
a fixed size and was sometimes too small (#1109), and performance of
lockFile/unlockFile was suboptimal due to the linear search.
Also the algorithm failed to count readers as required by Haskell 98
(#629).

Now it's done using a hash table (provided by the RTS).  Furthermore I
avoided the extra fstat() for every open file by passing the dev_t and
ino_t into lockFile.  This and the improvements to the locking
algorithm result in a healthy 20% or so performance increase for
opening/closing files (see openFile008 test).

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 37d78e6..fa57fce 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -62,6 +62,7 @@ import Foreign
 import Foreign.C
 import System.IO.Error
 import System.Posix.Internals
+import System.Posix.Types
 
 import GHC.Real
 
@@ -875,9 +876,9 @@ openFile' filepath mode binary =
     fd <- throwErrnoIfMinus1Retry "openFile"
                (c_open f (fromIntegral oflags) 0o666)
 
-    fd_type <- fdType fd
+    stat@(fd_type,_,_) <- fdStat fd
 
-    h <- fdToHandle' fd (Just fd_type) False filepath mode binary
+    h <- fdToHandle' fd (Just stat) False filepath mode binary
             `catchException` \e -> do c_close fd; throw e
        -- NB. don't forget to close the FD if fdToHandle' fails, otherwise
        -- this FD leaks.
@@ -907,8 +908,15 @@ append_flags = write_flags  .|. o_APPEND
 -- ---------------------------------------------------------------------------
 -- fdToHandle'
 
-fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle
-fdToHandle' fd mb_fd_type is_socket filepath mode binary = do
+fdToHandle' :: FD
+            -> Maybe (FDType, CDev, CIno)
+            -> Bool
+            -> FilePath
+            -> IOMode
+            -> Bool
+            -> IO Handle
+
+fdToHandle' fd mb_stat is_socket filepath mode binary = do
     -- turn on non-blocking mode
     setNonBlockingFD fd
 
@@ -929,10 +937,10 @@ fdToHandle' fd mb_fd_type is_socket filepath mode binary = do
 
     -- open() won't tell us if it was a directory if we only opened for
     -- reading, so check again.
-    fd_type <- 
-      case mb_fd_type of
+    (fd_type,dev,ino) <- 
+      case mb_stat of
         Just x  -> return x
-       Nothing -> fdType fd
+       Nothing -> fdStat fd
 
     case fd_type of
        Directory -> 
@@ -942,7 +950,7 @@ fdToHandle' fd mb_fd_type is_socket filepath mode binary = do
        -- regular files need to be locked
        RegularFile -> do
 #ifndef mingw32_HOST_OS
-          r <- lockFile fd (fromBool write) 1{-exclusive-}
+          r <- lockFile fd dev ino (fromBool write)
           when (r == -1)  $
                ioException (IOError Nothing ResourceBusy "openFile"
                                   "file is locked" Nothing)
@@ -969,7 +977,7 @@ fdToHandle fd = do
 
 #ifndef mingw32_HOST_OS
 foreign import ccall unsafe "lockFile"
-  lockFile :: CInt -> CInt -> CInt -> IO CInt
+  lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt
 
 foreign import ccall unsafe "unlockFile"
   unlockFile :: CInt -> IO CInt

diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs
index 11ee6ee..6173140 100644 (file)
--- a/System/Posix/Internals.hs
+++ b/System/Posix/Internals.hs
@@ -98,12 +98,18 @@ fileType file =
 
 -- NOTE: On Win32 platforms, this will only work with file descriptors
 -- referring to file handles. i.e., it'll fail for socket FDs.
-fdType :: FD -> IO FDType
-fdType fd = 
+fdStat :: FD -> IO (FDType, CDev, CIno)
+fdStat fd = 
   allocaBytes sizeof_stat $ \ p_stat -> do
     throwErrnoIfMinus1Retry "fdType" $
        c_fstat fd p_stat
-    statGetType p_stat
+    ty <- statGetType p_stat
+    dev <- st_dev p_stat
+    ino <- st_ino p_stat
+    return (ty,dev,ino)
+    
+fdType :: FD -> IO FDType
+fdType fd = do (ty,_,_) <- fdStat fd; return ty
 
 statGetType p_stat = do
   c_mode <- st_mode p_stat :: IO CMode
@@ -476,6 +482,8 @@ foreign import ccall unsafe "HsBase.h __hscore_sizeof_stat" sizeof_stat :: Int
 foreign import ccall unsafe "HsBase.h __hscore_st_mtime" st_mtime :: Ptr CStat -> IO CTime
 foreign import ccall unsafe "HsBase.h __hscore_st_size" st_size :: Ptr CStat -> IO COff
 foreign import ccall unsafe "HsBase.h __hscore_st_mode" st_mode :: Ptr CStat -> IO CMode
+foreign import ccall unsafe "HsBase.h __hscore_st_dev" st_dev :: Ptr CStat -> IO CDev
+foreign import ccall unsafe "HsBase.h __hscore_st_ino" st_ino :: Ptr CStat -> IO CIno
 
 foreign import ccall unsafe "HsBase.h __hscore_echo"         const_echo :: CInt
 foreign import ccall unsafe "HsBase.h __hscore_tcsanow"      const_tcsanow :: CInt

diff --git a/base.cabal b/base.cabal
index cf14de2..74ca3ba 100644 (file)
--- a/base.cabal
+++ b/base.cabal
@@ -159,7 +159,6 @@ Library {
         cbits/consUtils.c
         cbits/dirUtils.c
         cbits/inputReady.c
-        cbits/lockFile.c
         cbits/longlong.c
         cbits/selectUtils.c
     include-dirs: include

diff --git a/cbits/lockFile.c b/cbits/lockFile.c
deleted file mode 100644 (file)
index 721246b..0000000
--- a/cbits/lockFile.c
+++ /dev/null
@@ -1,112 +0,0 @@
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-2004
- *
- * $Id: lockFile.c,v 1.5 2005/01/28 13:36:32 simonmar Exp $
- *
- * stdin/stout/stderr Runtime Support
- */
-
-#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))
-
-#include "HsBase.h"
-#include "Rts.h"
-#include "RtsUtils.h"
-
-typedef struct {
-    dev_t device;
-    ino_t inode;
-    int fd;
-} Lock;
-
-static Lock readLock[FD_SETSIZE];
-static Lock writeLock[FD_SETSIZE];
-
-static int readLocks = 0;
-static int writeLocks = 0;
-
-int
-lockFile(int fd, int for_writing, int exclusive)
-{
-    struct stat sb;
-    int i;
-
-    if (fd > FD_SETSIZE) {
-       barf("lockFile: fd out of range");
-    }
-
-    while (fstat(fd, &sb) < 0) {
-       if (errno != EINTR)
-           return -1;
-    }
-
-    if (for_writing) {
-      /* opening a file for writing, check to see whether
-         we don't have any read locks on it already.. */
-      for (i = 0; i < readLocks; i++) {
-        if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev)
-           return -1;
-      }
-      /* If we're determined that there is only a single
-         writer to the file, check to see whether the file
-        hasn't already been opened for writing..
-      */
-      if (exclusive) {
-       for (i = 0; i < writeLocks; i++) {
-         if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) {
-            return -1;
-         }
-        }
-      }
-      /* OK, everything is cool lock-wise, record it and leave. */
-      i = writeLocks++;
-      writeLock[i].device = sb.st_dev;
-      writeLock[i].inode = sb.st_ino;
-      writeLock[i].fd = fd;
-      return 0;
-    } else {
-      /* For reading, it's simpler - just check to see
-         that there's no-one writing to the underlying file. */
-      for (i = 0; i < writeLocks; i++) {
-       if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev)
-            return -1;
-      }
-      /* Fit in new entry, reusing an existing table entry, if possible. */
-      for (i = 0; i < readLocks; i++) {
-        if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev) {
-          return 0;
-        }
-      }
-      i = readLocks++;
-      readLock[i].device = sb.st_dev;
-      readLock[i].inode = sb.st_ino;
-      readLock[i].fd = fd;
-      return 0;
-    }
-
-}
-
-int
-unlockFile(int fd)
-{
-    int i;
-
-    for (i = 0; i < readLocks; i++)
-       if (readLock[i].fd == fd) {
-           while (++i < readLocks)
-               readLock[i - 1] = readLock[i];
-           readLocks--;
-           return 0;
-       }
-
-    for (i = 0; i < writeLocks; i++)
-       if (writeLock[i].fd == fd) {
-           while (++i < writeLocks)
-               writeLock[i - 1] = writeLock[i];
-           writeLocks--;
-           return 0;
-       }
-     /* Signal that we did not find an entry */
-    return 1;
-}
-
-#endif

diff --git a/include/HsBase.h b/include/HsBase.h
index dfe6840..e067c25 100644 (file)
--- a/include/HsBase.h
+++ b/include/HsBase.h
@@ -125,7 +125,6 @@
 #if HAVE_VFORK_H
 #include <vfork.h>
 #endif
-#include "lockFile.h"
 #include "dirUtils.h"
 #include "WCsubst.h"
 
@@ -502,6 +501,8 @@ INLINE time_t __hscore_st_mtime ( struct stat* st ) { return st->st_mtime; }
 INLINE off_t  __hscore_st_size  ( struct stat* st ) { return st->st_size; }
 #if !defined(_MSC_VER)
 INLINE mode_t __hscore_st_mode  ( struct stat* st ) { return st->st_mode; }
+INLINE mode_t __hscore_st_dev  ( struct stat* st ) { return st->st_dev; }
+INLINE mode_t __hscore_st_ino  ( struct stat* st ) { return st->st_ino; }
 #endif
 
 #if HAVE_TERMIOS_H

diff --git a/include/lockFile.h b/include/lockFile.h
deleted file mode 100644 (file)
index b6deaf4..0000000
--- a/include/lockFile.h
+++ /dev/null
@@ -1,14 +0,0 @@
-/*
- * (c) The University of Glasgow 2001
- *
- * $Id: lockFile.h,v 1.3 2005/01/28 13:36:34 simonmar Exp $
- *
- * lockFile header
- */
-
-#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32))
-
-int lockFile(int fd, int for_writing, int exclusive);
-int unlockFile(int fd);
-
-#endif