18/20: squash! Optimize 'insert-package'.

[guix-commits]

civodul pushed a commit to branch wip-guix-index
in repository guix.

commit df59924abb90d565aff818fc7ee5d697bd87aa37
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Jun 4 22:26:20 2023 +0200

    squash! Optimize 'insert-package'.
    
    That makes 'guix locate -m store -u' slightly faster by not computing
    the derivation of an already-indexed package.
---
 guix/scripts/locate.scm | 49 ++++++++++++++++++++++++++++++++++---------------
 1 file changed, 34 insertions(+), 15 deletions(-)

diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm
index a8a8f96be5..bc30b5269f 100644
--- a/guix/scripts/locate.scm
+++ b/guix/scripts/locate.scm
@@ -217,13 +217,12 @@ VALUES (:name, :basename, :directory);"
   (sqlite-exec db "begin immediate;")
   ;; 1 record per output
   (for-each (lambda (output)
-              (let ((out (if (string=? "out" output) "" output)))
-                (sqlite-reset stmt-insert-package)
-                (sqlite-bind-arguments stmt-insert-package
-                                       #:name package
-                                       #:version version
-                                       #:output out)
-                (sqlite-fold (const #t) #t stmt-insert-package)))
+              (sqlite-reset stmt-insert-package)
+              (sqlite-bind-arguments stmt-insert-package
+                                     #:name package
+                                     #:version version
+                                     #:output output)
+              (sqlite-fold (const #t) #t stmt-insert-package))
             outputs)
   (sqlite-bind-arguments stmt-select-package
                          #:name package
@@ -274,14 +273,34 @@ VALUES (:name, :basename, :directory);"
 
 (define (insert-package db package)
   "Insert all the files of PACKAGE into DB."
-  (mlet %store-monad ((drv (package->derivation package #:graft? #f)))
-    (match (derivation->output-paths drv)
-      (((labels . directories) ...)
-       (when (every file-exists? directories)
-         (insert-files
-          db (package-name package) (package-version package) (package-outputs 
package)
-          directories))
-       (return #t)))))
+  (define stmt-select-package-output
+    (sqlite-prepare db "\
+SELECT output FROM Packages WHERE name = :name AND version = :version"
+                    #:cache? #t))
+
+  (define (known-outputs package)
+    ;; Return the list of outputs of PACKAGE already in DB.
+    (sqlite-bind-arguments stmt-select-package-output
+                           #:name (package-name package)
+                           #:version (package-version package))
+    (match (sqlite-fold cons '() stmt-select-package-output)
+      ((#(outputs ...)) outputs)
+      (() '())))
+
+  (with-monad %store-monad
+    ;; Since calling 'package->derivation' is expensive, do not call it if the
+    ;; outputs of PACKAGE at VERSION are already in DB.
+    (munless (lset= string=?
+                    (known-outputs package)
+                    (package-outputs package))
+      (mlet %store-monad ((drv (package->derivation package #:graft? #f)))
+        (match (derivation->output-paths drv)
+          (((labels . directories) ...)
+           (when (every file-exists? directories)
+             (insert-files
+              db (package-name package) (package-version package) 
(package-outputs package)
+              directories))
+           (return #t)))))))
 
 (define (insert-packages-with-progress db packages insert-package)
   "Insert PACKAGES into DB with progress bar reporting, calling INSERT-PACKAGE