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

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
 

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

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)
 

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

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
-

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)
 

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

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.
+"""]]

git-annex.cabal

@@ -836,6 +836,7 @@ Executable git-annex
     Database.Keys.SQL
     Database.Queue
     Database.Types
+    Database.Utility
     Git
     Git.AutoCorrect
     Git.Branch