Add debug code for file lock/unlock

libraries/base/GHC/IO/Device.hs

@@ -60,7 +60,7 @@ class RawIO a where
 
 
 -- | I/O operations required for implementing a 'System.IO.Handle'.
-class IODevice a where
+class Show a => IODevice a where
   -- | @ready dev write msecs@ returns 'True' if the device has data
   -- to read (if @write@ is 'False') or space to write new data (if
   -- @write@ is 'True').  @msecs@ specifies how long to wait, in
@@ -125,6 +125,9 @@ class IODevice a where
   dup2 :: a -> a -> IO a
   dup2 _ _ = ioe_unsupportedOperation
 
+  showDev :: a -> String
+  showDev a = show a
+
 ioe_unsupportedOperation :: IO a
 ioe_unsupportedOperation = throwIO unsupportedOperation
 

libraries/base/GHC/IO/FD.hs

@@ -418,6 +418,8 @@ close fd =
              c_closesocket (fromIntegral realFd)
            else
 #endif
+            do
+             -- putsE ("FD calling c_close: " ++ show fd ++ "\n")
              c_close (fromIntegral realFd)
 
      -- release the lock *first*, because otherwise if we're preempted

libraries/base/GHC/IO/Handle/Internals.hs

@@ -667,6 +667,7 @@ mkHandleMVar :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
 mkHandleMVar dev filepath ha_type buffered mb_codec nl other_side =
    openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do
 
+   traceIOE $ "mKHandleMVar fd :" ++ IODevice.showDev dev ++ " : " ++ filepath
    let !buf_state = initBufferState ha_type
    !bbuf_no_offset <- (Buffered.newBuffer dev buf_state)
    !buf_offset <- initHandleOffset
@@ -945,6 +946,12 @@ traceIO s = do
                   \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)
          return ()
 
+traceIOE :: String -> IO ()
+traceIOE s = do
+         _ <- withCStringLen (s ++ "\n") $
+                  \(p, len) -> c_write 2 (castPtr p) (fromIntegral len)
+         return ()
+
 -- ----------------------------------------------------------------------------
 -- Text input/output
 

libraries/base/System/Posix/Internals.hs

@@ -62,6 +62,12 @@ puts s = withCAStringLen (s ++ "\n") $ \(p, len) -> do
            _ <- c_write 1 (castPtr p) (fromIntegral len)
            return ()
 
+putsE :: String -> IO ()
+putsE s = withCAStringLen (s ++ "\n") $ \(p, len) -> do
+            -- In reality should be withCString, but assume ASCII to avoid loop
+            -- if this is called by GHC.Foreign
+           _ <- c_write 2 (castPtr p) (fromIntegral len)
+           return ()
 
 -- ---------------------------------------------------------------------------
 -- Types

rts/FileLock.c

@@ -17,6 +17,9 @@
 #include <unistd.h>
 #include <errno.h>
 
+#include <sys/stat.h>
+#include <sys/syscall.h>
+
 typedef struct {
     StgWord64 device;
     StgWord64 inode;
@@ -34,6 +37,30 @@ static HashTable *key_hash;
 static Mutex file_lock_mutex;
 #endif
 
+static pid_t gettid(void)
+{
+    return syscall(SYS_gettid);
+}
+
+int close(int fd)
+{
+    Lock *lock;
+
+    ACQUIRE_LOCK(&file_lock_mutex);
+    lock = lookupHashTable(key_hash, (long)fd);
+    RELEASE_LOCK(&file_lock_mutex);
+
+    if (lock != NULL) {
+        pid_t pid, tid;
+        pid = getpid();
+        tid = gettid();
+        barf ("close: lock exists: pid %d, tid %d, fd %d\n", pid, tid, fd);
+    }
+
+    long ret = syscall(SYS_close, fd);
+    return (int)ret;
+}
+
 STATIC_INLINE int cmpLocks(StgWord w1, StgWord w2)
 {
     Lock *l1 = (Lock *)w1;
@@ -80,6 +107,26 @@ lockFile(StgWord64 id, StgWord64 dev, StgWord64 ino, int for_writing)
 {
     Lock key, *lock;
 
+    int fd = (int)id;
+    struct stat buf;
+    int retval;
+    pid_t pid, tid;
+
+    pid = getpid();
+    tid = gettid();
+
+    retval = fstat(fd, &buf);
+    if (retval == -1) {
+      barf ("lockFile: fstat failed\n");
+    } else {
+      if (ino != 0 && ino != buf.st_ino) {
+        barf ("lockFile: pid %d, tid %d, incorrect inode: passed:%lu st_ino:%lu\n", pid, tid, ino, buf.st_ino);
+      }
+      if (dev != 0 && dev != buf.st_dev) {
+        barf ("lockFile: pid %d, tid %d, incorrect dev: passed:%lu st_ino:%lu\n", pid, tid, dev, buf.st_dev);
+      }
+    }
+
     ACQUIRE_LOCK(&file_lock_mutex);
 
     key.device = dev;
@@ -96,18 +143,23 @@ lockFile(StgWord64 id, StgWord64 dev, StgWord64 ino, int for_writing)
         insertHashTable_(obj_hash, (StgWord)lock, (void *)lock, hashLock);
         insertHashTable(key_hash, id, lock);
         RELEASE_LOCK(&file_lock_mutex);
+        fprintf (stderr, "lockFile: first lock: pid %d, tid %d, id %lu dev %lu ino %lu write %d\n", pid, tid, id, dev, ino, for_writing);
         return 0;
     }
     else
     {
         // single-writer/multi-reader locking:
         if (for_writing || lock->readers < 0) {
             RELEASE_LOCK(&file_lock_mutex);
+            fprintf (stderr, "lockFile: pid %d, tid %d, already locked, reader/write conflict: "
+                "id %lu dev %lu ino %lu write %d\n", pid, tid, id, dev, ino, for_writing);
             return -1;
         }
         insertHashTable(key_hash, id, lock);
         lock->readers++;
         RELEASE_LOCK(&file_lock_mutex);
+        fprintf (stderr, "lockFile: pid %d, tid %d, already locked, reader++: "
+                "id %lu dev %lu ino %lu write %d\n", pid, tid, id, dev, ino, for_writing);
         return 0;
     }
 }
@@ -116,6 +168,11 @@ int
 unlockFile(StgWord64 id)
 {
     Lock *lock;
+    int status;
+    pid_t pid, tid;
+
+    pid = getpid();
+    tid = gettid();
 
     ACQUIRE_LOCK(&file_lock_mutex);
 
@@ -125,21 +182,26 @@ unlockFile(StgWord64 id)
         // This is normal: we didn't know when calling unlockFile
         // whether this FD referred to a locked file or not.
         RELEASE_LOCK(&file_lock_mutex);
+        //fprintf (stderr, "unlockFile: not locked: id %lu\n", id);
         return 1;
     }
 
     if (lock->readers < 0) {
         lock->readers++;
+        status = 0;
     } else {
         lock->readers--;
+        status = 1;
     }
 
     if (lock->readers == 0) {
         removeHashTable_(obj_hash, (StgWord)lock, NULL, hashLock, cmpLocks);
         stgFree(lock);
+        status = 2;
     }
     removeHashTable(key_hash, id, NULL);
 
     RELEASE_LOCK(&file_lock_mutex);
+    fprintf (stderr, "unlockFile: pid %d, tid %d, unlocked: id %lu, status %d\n", pid, tid, id, status);
     return 0;
 }