From 5fbdc9a5aa63fd51c65d30fe3d30608d01fe1bc8 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 11 Jan 2019 17:23:39 +0100
Subject: 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.
---
 gnu/packages.scm | 127 +++++++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 124 insertions(+), 3 deletions(-)

(limited to 'gnu/packages.scm')

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 4a85cf4b87..6796db80a4 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -28,11 +28,14 @@ (define-module (gnu packages)
   #: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 @@ (define-module (gnu packages)
 
             specification->package
             specification->package+output
-            specifications->manifest))
+            specifications->manifest
+
+            generate-package-cache))
 
 ;;; Commentary:
 ;;;
@@ -135,6 +140,14 @@ (define %default-package-module-path
   ;; 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 @@ (define* (fold-packages proc init
                                 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 @@ (define find-packages-by-name
                     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 @@ (define (find-best-packages-by-name name 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.
-- 
cgit v1.2.3