From 09edb07ac5982edc8fe2987a8b477405fe9f982b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 3 Jun 2022 14:10:24 -0400 Subject: [PATCH] add debugLocks around database operations to track down a blocked indefinitely on MVar that seems to occur after sqlite throws ErrorBusy but that I have not been able to reproduce when I made commits synthetically throw ErrorBusy. Sponsored-by: Dartmouth College's Datalad project --- Database/Handle.hs | 11 ++++++----- Database/Keys/Handle.hs | 9 +++++---- Database/Queue.hs | 11 ++++++----- Makefile | 2 +- ...nt_13_bdfbcb8b6052a3c904e46678fce6adeb._comment | 14 ++++++++++++++ 5 files changed, 32 insertions(+), 15 deletions(-) create mode 100644 doc/bugs/get_is_busy_doing_nothing/comment_13_bdfbcb8b6052a3c904e46678fce6adeb._comment diff --git a/Database/Handle.hs b/Database/Handle.hs index 9eb32b4e27..cc3d7c35f9 100644 --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -19,6 +19,7 @@ module Database.Handle ( import Utility.Exception import Utility.FileSystemEncoding +import Utility.DebugLocks import Database.Persist.Sqlite import qualified Database.Sqlite as Sqlite @@ -57,7 +58,7 @@ openDb db tablename = do - auto-close. -} closeDb :: DbHandle -> IO () closeDb (DbHandle worker jobs) = do - putMVar jobs CloseJob + debugLocks $ putMVar jobs CloseJob wait worker {- Makes a query using the DbHandle. This should not be used to make @@ -74,8 +75,8 @@ queryDb :: DbHandle -> SqlPersistM a -> IO a queryDb (DbHandle _ jobs) a = do res <- newEmptyMVar putMVar jobs $ QueryJob $ - liftIO . putMVar res =<< tryNonAsync a - (either throwIO return =<< takeMVar res) + debugLocks $ liftIO . putMVar res =<< tryNonAsync a + debugLocks $ (either throwIO return =<< takeMVar res) `catchNonAsync` (\e -> error $ "sqlite query crashed: " ++ show e) {- Writes a change to the database. @@ -101,8 +102,8 @@ commitDb' :: DbHandle -> SqlPersistM () -> IO (Either SomeException ()) commitDb' (DbHandle _ jobs) a = do res <- newEmptyMVar putMVar jobs $ ChangeJob $ - liftIO . putMVar res =<< tryNonAsync a - takeMVar res + debugLocks $ liftIO . putMVar res =<< tryNonAsync a + debugLocks $ takeMVar res data Job = QueryJob (SqlPersistM ()) diff --git a/Database/Keys/Handle.hs b/Database/Keys/Handle.hs index 801a9ed530..ed7cc6e6c8 100644 --- a/Database/Keys/Handle.hs +++ b/Database/Keys/Handle.hs @@ -16,6 +16,7 @@ module Database.Keys.Handle ( import qualified Database.Queue as H import Utility.Exception +import Utility.DebugLocks import Control.Concurrent import Control.Monad.IO.Class (liftIO, MonadIO) @@ -42,16 +43,16 @@ withDbState -> (DbState -> m (v, DbState)) -> m v withDbState (DbHandle mvar) a = do - st <- liftIO $ takeMVar mvar - go st `onException` (liftIO $ putMVar mvar st) + st <- liftIO $ debugLocks $ takeMVar mvar + go st `onException` (liftIO $ debugLocks $ putMVar mvar st) where go st = do (v, st') <- a st - liftIO $ putMVar mvar st' + liftIO $ debugLocks $ putMVar mvar st' return v flushDbQueue :: DbHandle -> IO () -flushDbQueue (DbHandle mvar) = go =<< readMVar mvar +flushDbQueue (DbHandle mvar) = go =<< debugLocks (readMVar mvar) where go (DbOpen qh) = H.flushDbQueue qh go _ = return () diff --git a/Database/Queue.hs b/Database/Queue.hs index 7793904365..46418ef1d8 100644 --- a/Database/Queue.hs +++ b/Database/Queue.hs @@ -19,6 +19,7 @@ module Database.Queue ( import Utility.Monad import Utility.RawFilePath +import Utility.DebugLocks import Database.Handle import Database.Persist.Sqlite @@ -51,12 +52,12 @@ closeDbQueue h@(DQ hdl _) = do {- Blocks until all queued changes have been written to the database. -} flushDbQueue :: DbQueue -> IO () flushDbQueue (DQ hdl qvar) = do - q@(Queue sz _ qa) <- takeMVar qvar + q@(Queue sz _ qa) <- debugLocks $ takeMVar qvar if sz > 0 then do commitDb hdl qa - putMVar qvar =<< emptyQueue - else putMVar qvar q + debugLocks $ putMVar qvar =<< emptyQueue + else debugLocks $ putMVar qvar q {- Makes a query using the DbQueue's database connection. - This should not be used to make changes to the database! @@ -95,10 +96,10 @@ queueDb -> SqlPersistM () -> IO () queueDb (DQ hdl qvar) commitchecker a = do - Queue sz lastcommittime qa <- takeMVar qvar + Queue sz lastcommittime qa <- debugLocks $ takeMVar qvar let !sz' = sz + 1 let qa' = qa >> a - let enqueue = putMVar qvar + let enqueue = debugLocks . putMVar qvar ifM (commitchecker sz' lastcommittime) ( do r <- commitDb' hdl qa' diff --git a/Makefile b/Makefile index 73dffe3847..834a0a701f 100644 --- a/Makefile +++ b/Makefile @@ -35,7 +35,7 @@ install-home: tmp/configure-stamp: Build/TestConfig.hs Build/Configure.hs if [ "$(BUILDER)" = ./Setup ]; then $(GHC) --make Setup; fi if [ "$(BUILDER)" != stack ]; then \ - $(BUILDER) configure $(BUILDERCOMMONOPTIONS) --ghc-options="$(shell Build/collect-ghc-options.sh)"; \ + $(BUILDER) configure -f debuglocks $(BUILDERCOMMONOPTIONS) --ghc-options="$(shell Build/collect-ghc-options.sh)"; \ else \ $(BUILDER) setup $(BUILDERCOMMONOPTIONS); \ fi diff --git a/doc/bugs/get_is_busy_doing_nothing/comment_13_bdfbcb8b6052a3c904e46678fce6adeb._comment b/doc/bugs/get_is_busy_doing_nothing/comment_13_bdfbcb8b6052a3c904e46678fce6adeb._comment new file mode 100644 index 0000000000..781d182d41 --- /dev/null +++ b/doc/bugs/get_is_busy_doing_nothing/comment_13_bdfbcb8b6052a3c904e46678fce6adeb._comment @@ -0,0 +1,14 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 13""" + date="2022-06-03T17:52:12Z" + content=""" +To hopefully find out what MVar operation is blocking, I have added lock +debugging instrumentation to all database calls. This will need a special +build of git-annex with the DebugLocks build flag enabled. + +I have made a standalone tarball built that way available here: + + +It should display a backtrace on stderr when the MVar deadlock happens. +"""]]