channels: Compute a package cache and use it.

* gnu/packages.scm (cache-is-authoritative?, load-package-cache)
(cache-lookup, generate-package-cache): New procedures.
(%package-cache-file): New variable.
(find-packages-by-name): Rename to...
(find-packages-by-name/direct): ... this.
(find-packages-by-name): Rewrite to use the package cache when
'cache-is-authoritative?' returns true.
* tests/packages.scm ("find-packages-by-name + version, with cache")
("find-packages-by-name with cache"): New tests.
* guix/channels.scm (package-cache-file): New procedure.
(%channel-profile-hooks): New variable.
(channel-instances->derivation): Use it in #:hooks.
* guix/scripts/package.scm (build-and-use-profile): Add #:hooks and
honor it.
* guix/scripts/pull.scm (build-and-install): Pass #:hooks to
UPDATE-PROFILE.

5 files changed, 181 insertions, 9 deletions

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 4a85cf4b877..6796db80a47 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -28,11 +28,14 @@
   #:use-module (guix memoization)
   #:use-module ((guix build utils)
                 #:select ((package-name->name+version
-                           . hyphen-separated-name->name+version)))
+                           . hyphen-separated-name->name+version)
+                          mkdir-p))
   #:autoload   (guix profiles) (packages->manifest)
   #:use-module (guix describe)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
+  #:autoload   (ice-9 binary-ports) (put-bytevector)
+  #:autoload   (system base compile) (compile)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -56,7 +59,9 @@
 
             specification->package
             specification->package+output
-            specifications->manifest))
+            specifications->manifest
+
+            generate-package-cache))
 
 ;;; Commentary:
 ;;;
@@ -135,6 +140,14 @@ for system '~a'")
   ;; Default search path for package modules.
   `((,%distro-root-directory . "gnu/packages")))
 
+(define (cache-is-authoritative?)
+  "Return true if the pre-computed package cache is authoritative.  It is not
+authoritative when entries have been added via GUIX_PACKAGE_PATH or '-L'
+flags."
+  (equal? (%package-module-path)
+          (append %default-package-module-path
+                  (package-path-entries))))
+
 (define %package-module-path
   ;; Search path for package modules.  Each item must be either a directory
   ;; name or a pair whose car is a directory and whose cdr is a sub-directory
@@ -183,7 +196,35 @@ is guaranteed to never traverse the same package twice."
                                 init
                                 modules))
 
-(define find-packages-by-name
+(define %package-cache-file
+  ;; Location of the package cache.
+  "/lib/guix/package.cache")
+
+(define load-package-cache
+  (mlambda (profile)
+    "Attempt to load the package cache.  On success return a vhash keyed by
+package names.  Return #f on failure."
+    (match profile
+      (#f #f)
+      (profile
+       (catch 'system-error
+         (lambda ()
+           (define lst
+             (load-compiled (string-append profile %package-cache-file)))
+           (fold (lambda (item vhash)
+                   (match item
+                     (#(name version module symbol outputs
+                             supported? deprecated?
+                             file line column)
+                      (vhash-cons name item vhash))))
+                 vlist-null
+                 lst))
+         (lambda args
+           (if (= ENOENT (system-error-errno args))
+               #f
+               (apply throw args))))))))
+
+(define find-packages-by-name/direct              ;bypass the cache
   (let ((packages (delay
                     (fold-packages (lambda (p r)
                                      (vhash-cons (package-name p) p r))
@@ -202,6 +243,37 @@ decreasing version order."
                     matching)
             matching)))))
 
+(define (cache-lookup cache name)
+  "Lookup package NAME in CACHE.  Return a list sorted in increasing version
+order."
+  (define (package-version<? v1 v2)
+    (version>? (vector-ref v2 1) (vector-ref v1 1)))
+
+  (sort (vhash-fold* cons '() name cache)
+        package-version<?))
+
+(define* (find-packages-by-name name #:optional version)
+  "Return the list of packages with the given NAME.  If VERSION is not #f,
+then only return packages whose version is prefixed by VERSION, sorted in
+decreasing version order."
+  (define cache
+    (load-package-cache (current-profile)))
+
+  (if (and (cache-is-authoritative?) cache)
+      (match (cache-lookup cache name)
+        (#f #f)
+        ((#(_ versions modules symbols _ _ _ _ _ _) ...)
+         (fold (lambda (version* module symbol result)
+                 (if (or (not version)
+                         (version-prefix? version version*))
+                     (cons (module-ref (resolve-interface module)
+                                       symbol)
+                           result)
+                     result))
+               '()
+               versions modules symbols)))
+      (find-packages-by-name/direct name version)))
+
 (define (find-best-packages-by-name name version)
   "If version is #f, return the list of packages named NAME with the highest
 version numbers; otherwise, return the list of packages named NAME and at
@@ -218,6 +290,55 @@ VERSION."
                          (string=? (package-version p) highest))
                        matches))))))
 
+(define (generate-package-cache directory)
+  "Generate under DIRECTORY a cache of all the available packages.
+
+The primary purpose of the cache is to speed up package lookup by name such
+that we don't have to traverse and load all the package modules, thereby also
+reducing the memory footprint."
+  (define cache-file
+    (string-append directory %package-cache-file))
+
+  (define (expand-cache module symbol variable result)
+    (match (false-if-exception (variable-ref variable))
+      ((? package? package)
+       (if (hidden-package? package)
+           result
+           (cons `#(,(package-name package)
+                    ,(package-version package)
+                    ,(module-name module)
+                    ,symbol
+                    ,(package-outputs package)
+                    ,(->bool (member (%current-system)
+                                     (package-supported-systems package)))
+                    ,(->bool (package-superseded package))
+                    ,@(let ((loc (package-location package)))
+                        (if loc
+                            `(,(location-file loc)
+                              ,(location-line loc)
+                              ,(location-column loc))
+                            '(#f #f #f))))
+                 result)))
+      (_
+       result)))
+
+  (define exp
+    (fold-module-public-variables* expand-cache '()
+                                   (all-modules (%package-module-path)
+                                                #:warn
+                                                warn-about-load-error)))
+
+  (mkdir-p (dirname cache-file))
+  (call-with-output-file cache-file
+    (lambda (port)
+      ;; Store the cache as a '.go' file.  This makes loading fast and reduces
+      ;; heap usage since some of the static data is directly mmapped.
+      (put-bytevector port
+                      (compile `'(,@exp)
+                               #:to 'bytecode
+                               #:opts '(#:to-file? #t)))))
+  cache-file)
+
 
 (define %sigint-prompt
   ;; The prompt to jump to upon SIGINT.
diff --git a/guix/channels.scm b/guix/channels.scm
index 6b860f3bd81..cd8a0131bd8 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -21,6 +21,7 @@
   #:use-module (guix git)
   #:use-module (guix records)
   #:use-module (guix gexp)
+  #:use-module (guix modules)
   #:use-module (guix discovery)
   #:use-module (guix monads)
   #:use-module (guix profiles)
@@ -31,7 +32,8 @@
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
-  #:autoload   (guix self) (whole-package)
+  #:autoload   (guix self) (whole-package make-config.scm)
+  #:autoload   (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
   #:use-module (ice-9 match)
   #:export (channel
             channel?
@@ -52,6 +54,7 @@
             checkout->channel-instance
             latest-channel-derivation
             channel-instances->manifest
+            %channel-profile-hooks
             channel-instances->derivation))
 
 ;;; Commentary:
@@ -416,11 +419,40 @@ channel instances."
                                           (zip instances derivations))))
     (return (manifest entries))))
 
+(define (package-cache-file manifest)
+  "Build a package cache file for the instance in MANIFEST.  This is meant to
+be used as a profile hook."
+  (mlet %store-monad ((profile (profile-derivation manifest
+                                                   #:hooks '())))
+
+    (define build
+      #~(begin
+          (use-modules (gnu packages))
+
+          (if (defined? 'generate-package-cache)
+              (begin
+                ;; Delegate package cache generation to the inferior.
+                (format (current-error-port)
+                        "Generating package cache for '~a'...~%"
+                        #$profile)
+                (generate-package-cache #$output))
+              (mkdir #$output))))
+
+    (gexp->derivation-in-inferior "guix-package-cache" build
+                                  profile
+                                  #:properties '((type . profile-hook)
+                                                 (hook . package-cache)))))
+
+(define %channel-profile-hooks
+  ;; The default channel profile hooks.
+  (cons package-cache-file %default-profile-hooks))
+
 (define (channel-instances->derivation instances)
   "Return the derivation of the profile containing INSTANCES, a list of
 channel instances."
   (mlet %store-monad ((manifest (channel-instances->manifest instances)))
-    (profile-derivation manifest)))
+    (profile-derivation manifest
+                        #:hooks %channel-profile-hooks)))
 
 (define latest-channel-instances*
   (store-lift latest-channel-instances))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index ba33790edaa..e9bed0be1ed 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -120,21 +120,21 @@ denote ranges as interpreted by 'matching-generations'."
 
 (define* (build-and-use-profile store profile manifest
                                 #:key
+                                (hooks %default-profile-hooks)
                                 allow-collisions?
                                 bootstrap? use-substitutes?
                                 dry-run?)
   "Build a new generation of PROFILE, a file name, using the packages
 specified in MANIFEST, a manifest object.  When ALLOW-COLLISIONS? is true,
-do not treat collisions in MANIFEST as an error."
+do not treat collisions in MANIFEST as an error.  HOOKS is a list of \"profile
+hooks\" run when building the profile."
   (when (equal? profile %current-profile)
     (ensure-default-profile))
 
   (let* ((prof-drv (run-with-store store
                      (profile-derivation manifest
                                          #:allow-collisions? allow-collisions?
-                                         #:hooks (if bootstrap?
-                                                     '()
-                                                     %default-profile-hooks)
+                                         #:hooks (if bootstrap? '() hooks)
                                          #:locales? (not bootstrap?))))
          (prof     (derivation->output-path prof-drv)))
     (show-what-to-build store (list prof-drv)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 0339b149fa8..513434c5f16 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -188,6 +188,7 @@ true, display what would be built without actually building it."
   (mlet %store-monad ((manifest (channel-instances->manifest instances)))
     (mbegin %store-monad
       (update-profile profile manifest
+                      #:hooks %channel-profile-hooks
                       #:dry-run? dry-run?)
       (munless dry-run?
         (return (display-profile-news profile))))))
diff --git a/tests/packages.scm b/tests/packages.scm
index eb8ede3207b..2720ba5a155 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1005,6 +1005,24 @@
     (((? (cut eq? hello <>))) #t)
     (wrong (pk 'find-packages-by-name wrong #f))))
 
+(test-equal "find-packages-by-name with cache"
+  (find-packages-by-name "guile")
+  (call-with-temporary-directory
+   (lambda (cache)
+     (generate-package-cache cache)
+     (mock ((guix describe) current-profile (const cache))
+           (mock ((gnu packages) cache-is-authoritative? (const #t))
+                 (find-packages-by-name "guile"))))))
+
+(test-equal "find-packages-by-name + version, with cache"
+  (find-packages-by-name "guile" "2")
+  (call-with-temporary-directory
+   (lambda (cache)
+     (generate-package-cache cache)
+     (mock ((guix describe) current-profile (const cache))
+           (mock ((gnu packages) cache-is-authoritative? (const #t))
+                 (find-packages-by-name "guile" "2"))))))
+
 (test-assert "--search-paths with pattern"
   ;; Make sure 'guix package --search-paths' correctly reports environment
   ;; variables when file patterns are used (in particular, it must follow