Sped up sqlite inserts 2x when built with persistent 2.14.5.0

https://github.com/yesodweb/persistent/issues/1457

Sponsored-by: Dartmouth College's DANDI project

diff --git a/CHANGELOG b/CHANGELOG
index 699331bfc3d3b5024e88a8e785e6e150635c2fe6..ff8ffdeb2ab3e8efd75519562c02012dbe3d2945 100644 (file)
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -2,6 +2,7 @@ git-annex (10.20230330) UNRELEASED; urgency=medium
 
   * git-annex.cabal: Prevent building with unix-compat 0.7 which
     removed System.PosixCompat.User.
+  * Sped up sqlite inserts 2x when built with persistent 2.14.5.0
 
  -- Joey Hess <id@joeyh.name>  Fri, 31 Mar 2023 12:48:54 -0400
 

diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs
index aa595a98ce39870290441b534d0f06c742838b2c..e304dca58f1ae0e4095fd491ac1975250df0a332 100644 (file)
--- a/Database/ContentIdentifier.hs
+++ b/Database/ContentIdentifier.hs
@@ -36,6 +36,7 @@ module Database.ContentIdentifier (
 import Database.Types
 import qualified Database.Queue as H
 import Database.Init
+import Database.Utility
 import Annex.Locations
 import Annex.Common hiding (delete)
 import qualified Annex.Branch
@@ -109,7 +110,7 @@ flushDbQueue (ContentIdentifierHandle h) = H.flushDbQueue h
 -- Be sure to also update the git-annex branch when using this.
 recordContentIdentifier :: ContentIdentifierHandle -> RemoteStateHandle -> ContentIdentifier -> Key -> IO ()
 recordContentIdentifier h (RemoteStateHandle u) cid k = queueDb h $ do
-       void $ insertUnique $ ContentIdentifiers u cid k
+       void $ insertUniqueFast $ ContentIdentifiers u cid k
 
 getContentIdentifiers :: ContentIdentifierHandle -> RemoteStateHandle -> Key -> IO [ContentIdentifier]
 getContentIdentifiers (ContentIdentifierHandle h) (RemoteStateHandle u) k = 
@@ -132,7 +133,7 @@ getContentIdentifierKeys (ContentIdentifierHandle h) (RemoteStateHandle u) cid =
 recordAnnexBranchTree :: ContentIdentifierHandle -> Sha -> IO ()
 recordAnnexBranchTree h s = queueDb h $ do
         deleteWhere ([] :: [Filter AnnexBranch])
-        void $ insertUnique $ AnnexBranch $ toSSha s
+        void $ insertUniqueFast $ AnnexBranch $ toSSha s
 
 getAnnexBranchTree :: ContentIdentifierHandle -> IO Sha
 getAnnexBranchTree (ContentIdentifierHandle h) = H.queryDbQueue h $ do

diff --git a/Database/Export.hs b/Database/Export.hs
index b5c58afd0bd7e9d545b6c5514bc19d4dffd72621..4e01752d9ba42063924d0a6d99c0a9411114693e 100644 (file)
--- a/Database/Export.hs
+++ b/Database/Export.hs
@@ -49,6 +49,7 @@ module Database.Export (
 import Database.Types
 import qualified Database.Queue as H
 import Database.Init
+import Database.Utility
 import Annex.Locations
 import Annex.Common hiding (delete)
 import Types.Export
@@ -124,7 +125,7 @@ flushDbQueue (ExportHandle h _) = H.flushDbQueue h
 recordExportTreeCurrent :: ExportHandle -> Sha -> IO ()
 recordExportTreeCurrent h s = queueDb h $ do
        deleteWhere ([] :: [Filter ExportTreeCurrent])
-       void $ insertUnique $ ExportTreeCurrent $ toSSha s
+       void $ insertUniqueFast $ ExportTreeCurrent $ toSSha s
 
 getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha)
 getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do
@@ -136,7 +137,7 @@ getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do
 
 addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
 addExportedLocation h k el = queueDb h $ do
-       void $ insertUnique $ Exported k ef
+       void $ insertUniqueFast $ Exported k ef
        let edirs = map
                (\ed -> ExportedDirectory (SFilePath (fromExportDirectory ed)) ef)
                (exportDirectories el)
@@ -186,7 +187,7 @@ getExportTreeKey (ExportHandle h _) el = H.queryDbQueue h $ do
 
 addExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
 addExportTree h k loc = queueDb h $
-       void $ insertUnique $ ExportTree k ef
+       void $ insertUniqueFast $ ExportTree k ef
   where
        ef = SFilePath (fromExportLocation loc)
 

diff --git a/Database/Fsck.hs b/Database/Fsck.hs
index 61e932e3da38660b4d717485385778d3035d0a9e..cccefefedafdb7f206468c404ca701c7dafa84c6 100644 (file)
--- a/Database/Fsck.hs
+++ b/Database/Fsck.hs
@@ -29,6 +29,7 @@ module Database.Fsck (
 
 import Database.Types
 import qualified Database.Queue as H
+import Database.Utility
 import Database.Init
 import Annex.Locations
 import Utility.Exception
@@ -88,7 +89,7 @@ closeDb (FsckHandle h u) = do
 
 addDb :: FsckHandle -> Key -> IO ()
 addDb (FsckHandle h _) k = H.queueDb h checkcommit $
-       void $ insertUnique $ Fscked k
+       void $ insertUniqueFast $ Fscked k
   where
        -- Commit queue after 1000 changes or 5 minutes, whichever comes first.
        -- The time based commit allows for an incremental fsck to be

diff --git a/Database/Handle.hs b/Database/Handle.hs
index c960375877ce17e3a461b1fd8498008bce23180b..da7a0e173a298a10ddde13532ff2dedbecc14155 100644 (file)
--- a/Database/Handle.hs
+++ b/Database/Handle.hs
@@ -5,7 +5,7 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, FlexibleContexts, OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies, FlexibleContexts, OverloadedStrings, CPP #-}
 
 module Database.Handle (
        DbHandle,
@@ -329,4 +329,3 @@ isDatabaseModified (DatabaseInodeCache a1 b1) (DatabaseInodeCache a2 b2) =
 
 takeMVarSafe :: MVar a -> IO (Either BlockedIndefinitelyOnMVar a)
 takeMVarSafe = try . takeMVar
-

diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs
index c97a4280b925ec2e2d7a9c6d0c5893a0b2b663aa..e190c90ab0e953c6d2a74cc8850d03ae92a852a5 100644 (file)
--- a/Database/Keys/SQL.hs
+++ b/Database/Keys/SQL.hs
@@ -21,6 +21,7 @@ module Database.Keys.SQL where
 
 import Database.Types
 import Database.Handle
+import Database.Utility
 import qualified Database.Queue as H
 import Utility.InodeCache
 import Git.FilePath
@@ -121,7 +122,7 @@ removeAssociatedFile k f = queueDb $
 
 addInodeCaches :: Key -> [InodeCache] -> WriteHandle -> IO ()
 addInodeCaches k is = queueDb $
-       forM_ is $ \i -> insertUnique $ Content k i 
+       forM_ is $ \i -> insertUniqueFast $ Content k i 
                (inodeCacheToFileSize i)
                (inodeCacheToEpochTime i)
 

diff --git a/Database/Utility.hs b/Database/Utility.hs
new file mode 100644 (file)
index 0000000..55943fc
--- /dev/null
+++ b/Database/Utility.hs
@@ -0,0 +1,27 @@
+{- Persistent sqlite database utilities.
+ -
+ - Copyright 2023 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, CPP #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+
+module Database.Utility (
+       insertUniqueFast,
+) where
+
+import Control.Monad
+import Database.Persist.Class
+
+{- insertUnique_ is 2x as fast as insertUnique, so use when available.
+ -
+ - It would be difficult to write the type signature here, since older
+ - versions of persistent have different constraints on insertUnique.
+ -}
+#if MIN_VERSION_persistent(2,14,5)
+insertUniqueFast x = void (insertUnique_ x)
+#else
+insertUniqueFast x = void (insertUnique x)
+#endif

diff --git a/doc/bugs/performance_regression__63___init_takes_times_more/comment_18_13ce5ec87207d553388ec23663d9abcb._comment b/doc/bugs/performance_regression__63___init_takes_times_more/comment_18_13ce5ec87207d553388ec23663d9abcb._comment
new file mode 100644 (file)
index 0000000..0ce3682
--- /dev/null
+++ b/doc/bugs/performance_regression__63___init_takes_times_more/comment_18_13ce5ec87207d553388ec23663d9abcb._comment
@@ -0,0 +1,11 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 18"""
+ date="2023-03-31T18:36:56Z"
+ content="""
+Implemented support for
+<https://github.com/yesodweb/persistent/issues/1457> in git-annex,
+which does speed up sqlite inserts 2x. That will affect the scan in
+question, since that inserts to the keys database. It also will speed up
+some unrelated parts of git-annex.
+"""]]

diff --git a/git-annex.cabal b/git-annex.cabal
index 365d19ce4280890d0265c22fb5105ea010c0833c..1fb739cf26cec8801338f1d07c40010ad2020a34 100644 (file)
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -836,6 +836,7 @@ Executable git-annex
     Database.Keys.SQL
     Database.Queue
     Database.Types
+    Database.Utility
     Git
     Git.AutoCorrect
     Git.Branch