GNU bug report logs - #34060
[PATCH 00/10] Add a cache for package lookups

Previous Next

Package: guix-patches;

Reported by: Ludovic Courtès <ludo <at> gnu.org>

Date: Sun, 13 Jan 2019 15:46:01 UTC

Severity: normal

Tags: patch

Done: Ludovic Courtès <ludo <at> gnu.org>

Bug is archived. No further changes may be made.

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 34060 in the body.
You can then email your comments to 34060 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

View this report as an mbox folder, status mbox, maintainer mbox


Report forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Sun, 13 Jan 2019 15:46:01 GMT) Full text and rfc822 format available.

Acknowledgement sent to Ludovic Courtès <ludo <at> gnu.org>:
New bug report received and forwarded. Copy sent to guix-patches <at> gnu.org. (Sun, 13 Jan 2019 15:46:01 GMT) Full text and rfc822 format available.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: guix-patches <at> gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 00/10] Add a cache for package lookups
Date: Sun, 13 Jan 2019 16:45:32 +0100
Hello!

This patch adjust ‘guix pull’ & co. such that Guix comes with a
cache to speed up package lookups.  The end result is that:

  guix build coreutils

becomes equivalent to:

  guix build -e '(@ (gnu packages base) coreutils)'

That means we have fewer files to open (only the closure of
(gnu packages base) instead of all the (gnu packages …) modules),
and thus less I/O and a smaller memory footprint.  Without cache,
we have:

--8<---------------cut here---------------start------------->8---
$ GUIX_PROFILING=gc time ./pre-inst-env guix build coreutils -nd
/gnu/store/ddlgwpishzb8985gwg5fdrydvllg254a-coreutils-8.30.drv
Garbage collection statistics:
  heap size:        46.18 MiB
  allocated:        102.57 MiB
  GC times:         14
  time spent in GC: 0.25 seconds (25% of user time)
1.01user 0.06system 0:00.96elapsed 112%CPU (0avgtext+0avgdata 158916maxresident)k
0inputs+0outputs (0major+14602minor)pagefaults 0swaps
--8<---------------cut here---------------end--------------->8---

With the cache, we get:

--8<---------------cut here---------------start------------->8---
$ GUIX_PROFILING=gc time ./foo/bin/guix build coreutils -nd
/gnu/store/ddlgwpishzb8985gwg5fdrydvllg254a-coreutils-8.30.drv
Garbage collection statistics:
  heap size:        36.52 MiB
  allocated:        87.30 MiB
  GC times:         14
  time spent in GC: 0.24 seconds (27% of user time)
0.89user 0.06system 0:00.84elapsed 112%CPU (0avgtext+0avgdata 124168maxresident)k
0inputs+0outputs (0major+11423minor)pagefaults 0swaps
--8<---------------cut here---------------end--------------->8---

As a bonus, we take advantage of the cache to speed up ‘guix
package -A’ (which now runs in ~0.5s instead of ~1.7s) and
‘guix edit’.

The cache is populated by packages of all the channels specified
during ‘guix pull’.

The cache is *not* used at all when GUIX_PACKAGE_PATH is set or
a ‘-L’ flag is passed, or ./pre-inst-env is used.

Feedback welcome!

Ludo’.

Ludovic Courtès (10):
  profiling: Add a "gc" profiling component.
  guix package: Avoid 'find-newest-available-packages'.
  packages: Remove 'find-newest-available-packages'.
  inferior: Add 'gexp->derivation-in-inferior'.
  discovery: Add 'fold-module-public-variables*'.
  pull: Build profile with 'channel-instances->derivation'.
  channels: Compute a package cache and use it.
  edit: Use 'specification->location' to read information from the
    cache.
  guix package: '--list-available' can use data from the cache.
  status: Distinguish 'package-cache' profile hook.

 gnu/packages.scm         | 253 ++++++++++++++++++++++++++++++++++-----
 guix/channels.scm        |  32 ++++-
 guix/discovery.scm       |  28 ++++-
 guix/inferior.scm        |  26 ++++
 guix/profiling.scm       |  25 +++-
 guix/scripts/edit.scm    |  29 ++---
 guix/scripts/package.scm | 137 +++++++++++----------
 guix/scripts/pull.scm    |   4 +-
 guix/status.scm          |   2 +
 tests/packages.scm       |  77 ++++++++++--
 10 files changed, 491 insertions(+), 122 deletions(-)

-- 
2.20.1





Information forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Sun, 13 Jan 2019 15:48:01 GMT) Full text and rfc822 format available.

Message #8 received at 34060 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 01/10] profiling: Add a "gc" profiling component.
Date: Sun, 13 Jan 2019 16:47:24 +0100
* guix/profiling.scm (show-gc-stats): New procedure.
<top level>: Call 'register-profiling-hook!'.
---
 guix/profiling.scm | 25 ++++++++++++++++++++++++-
 1 file changed, 24 insertions(+), 1 deletion(-)

diff --git a/guix/profiling.scm b/guix/profiling.scm
index 753fc6c22e..e1c205a543 100644
--- a/guix/profiling.scm
+++ b/guix/profiling.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2017, 2019 Ludovic Courtès <ludo <at> gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,6 +18,7 @@
 
 (define-module (guix profiling)
   #:use-module (ice-9 match)
+  #:autoload   (ice-9 format) (format)
   #:export (profiled?
             register-profiling-hook!))
 
@@ -50,3 +51,25 @@
     (for-each (lambda (hook)
                 (add-hook! hook thunk))
               %profiling-hooks)))
+
+(define (show-gc-stats)
+  "Display garbage collection statistics."
+  (define MiB (* 1024 1024.))
+  (define stats (gc-stats))
+
+  (format (current-error-port) "Garbage collection statistics:
+  heap size:        ~,2f MiB
+  allocated:        ~,2f MiB
+  GC times:         ~a
+  time spent in GC: ~,2f seconds (~d% of user time)~%"
+          (/ (assq-ref stats 'heap-size) MiB)
+          (/ (assq-ref stats 'heap-total-allocated) MiB)
+          (assq-ref stats 'gc-times)
+          (/ (assq-ref stats 'gc-time-taken)
+             internal-time-units-per-second 1.)
+          (inexact->exact
+           (round (* (/ (assq-ref stats 'gc-time-taken)
+                        (tms:utime (times)) 1.)
+                     100)))))
+
+(register-profiling-hook! "gc" show-gc-stats)
-- 
2.20.1





Information forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Sun, 13 Jan 2019 15:48:02 GMT) Full text and rfc822 format available.

Message #11 received at 34060 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 02/10] guix package: Avoid 'find-newest-available-packages'.
Date: Sun, 13 Jan 2019 16:47:25 +0100
* guix/scripts/package.scm (transaction-upgrade-entry): Use
'find-best-packages-by-name' instead of
'find-newest-available-packages'.
* tests/packages.scm ("transaction-upgrade-entry, zero upgrades")
("transaction-upgrade-entry, one upgrade")
("transaction-upgrade-entry, superseded package"): Adjust accordingly.
---
 guix/scripts/package.scm | 51 ++++++++++++++++++++--------------------
 tests/packages.scm       | 14 +++++------
 2 files changed, 33 insertions(+), 32 deletions(-)

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 7ff6bfd6d8..872a7303fc 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -220,31 +220,32 @@ of relevance scores."
     ('dismiss
      transaction)
     (($ <manifest-entry> name version output (? string? path))
-     (match (vhash-assoc name (find-newest-available-packages))
-       ((_ candidate-version pkg . rest)
-        (match (package-superseded pkg)
-          ((? package? new)
-           (supersede entry new))
-          (#f
-           (case (version-compare candidate-version version)
-             ((>)
-              (manifest-transaction-install-entry
-               (package->manifest-entry* pkg output)
-               transaction))
-             ((<)
-              transaction)
-             ((=)
-              (let ((candidate-path (derivation->output-path
-                                     (package-derivation (%store) pkg))))
-                ;; XXX: When there are propagated inputs, assume we need to
-                ;; upgrade the whole entry.
-                (if (and (string=? path candidate-path)
-                         (null? (package-propagated-inputs pkg)))
-                    transaction
-                    (manifest-transaction-install-entry
-                     (package->manifest-entry* pkg output)
-                     transaction))))))))
-       (#f
+     (match (find-best-packages-by-name name #f)
+       ((pkg . rest)
+        (let ((candidate-version (package-version pkg)))
+          (match (package-superseded pkg)
+            ((? package? new)
+             (supersede entry new))
+            (#f
+             (case (version-compare candidate-version version)
+               ((>)
+                (manifest-transaction-install-entry
+                 (package->manifest-entry* pkg output)
+                 transaction))
+               ((<)
+                transaction)
+               ((=)
+                (let ((candidate-path (derivation->output-path
+                                       (package-derivation (%store) pkg))))
+                  ;; XXX: When there are propagated inputs, assume we need to
+                  ;; upgrade the whole entry.
+                  (if (and (string=? path candidate-path)
+                           (null? (package-propagated-inputs pkg)))
+                      transaction
+                      (manifest-transaction-install-entry
+                       (package->manifest-entry* pkg output)
+                       transaction)))))))))
+       (()
         (warning (G_ "package '~a' no longer exists~%") name)
         transaction)))))
 
diff --git a/tests/packages.scm b/tests/packages.scm
index 237feb7aba..eb8ede3207 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -96,8 +96,8 @@
 
 (test-assert "transaction-upgrade-entry, zero upgrades"
   (let* ((old (dummy-package "foo" (version "1")))
-         (tx  (mock ((gnu packages) find-newest-available-packages
-                     (const vlist-null))
+         (tx  (mock ((gnu packages) find-best-packages-by-name
+                     (const '()))
                     ((@@ (guix scripts package) transaction-upgrade-entry)
                      (manifest-entry
                        (inherit (package->manifest-entry old))
@@ -109,8 +109,8 @@
 (test-assert "transaction-upgrade-entry, one upgrade"
   (let* ((old (dummy-package "foo" (version "1")))
          (new (dummy-package "foo" (version "2")))
-         (tx  (mock ((gnu packages) find-newest-available-packages
-                     (const (vhash-cons "foo" (list "2" new) vlist-null)))
+         (tx  (mock ((gnu packages) find-best-packages-by-name
+                     (const (list new)))
                     ((@@ (guix scripts package) transaction-upgrade-entry)
                      (manifest-entry
                        (inherit (package->manifest-entry old))
@@ -126,8 +126,8 @@
   (let* ((old (dummy-package "foo" (version "1")))
          (new (dummy-package "bar" (version "2")))
          (dep (deprecated-package "foo" new))
-         (tx  (mock ((gnu packages) find-newest-available-packages
-                     (const (vhash-cons "foo" (list "2" dep) vlist-null)))
+         (tx  (mock ((gnu packages) find-best-packages-by-name
+                     (const (list dep)))
                     ((@@ (guix scripts package) transaction-upgrade-entry)
                      (manifest-entry
                        (inherit (package->manifest-entry old))
-- 
2.20.1





Information forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Sun, 13 Jan 2019 15:48:02 GMT) Full text and rfc822 format available.

Message #14 received at 34060 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 03/10] packages: Remove 'find-newest-available-packages'.
Date: Sun, 13 Jan 2019 16:47:26 +0100
Since commit 9ffc1c00e55eb7931846dbb3fafcf54716fff57c,
'find-newest-available-packages' and 'find-packages-by-name' were both
building a vhash mapping package names to packages.  This factorizes
this bit, also reducing I/O, CPU, and memory usage.

* gnu/packages.scm (find-best-packages-by-name): Remove.
(find-best-packages-by-name): Use 'find-packages-by-name' instead of
'find-newest-available-packages'.
---
 gnu/packages.scm | 38 ++++++++++----------------------------
 1 file changed, 10 insertions(+), 28 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 532297239d..4a85cf4b87 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw <at> netris.org>
 ;;; Copyright © 2014 Eric Bavier <bavier <at> member.fsf.org>
 ;;; Copyright © 2016, 2017 Alex Kost <alezost <at> gmail.com>
@@ -53,7 +53,6 @@
 
             find-packages-by-name
             find-best-packages-by-name
-            find-newest-available-packages
 
             specification->package
             specification->package+output
@@ -203,38 +202,21 @@ decreasing version order."
                     matching)
             matching)))))
 
-(define find-newest-available-packages
-  (mlambda ()
-    "Return a vhash keyed by package names, and with
-associated values of the form
-
-  (newest-version newest-package ...)
-
-where the preferred package is listed first."
-
-    ;; FIXME: Currently, the preferred package is whichever one
-    ;; was found last by 'fold-packages'.  Find a better solution.
-    (fold-packages (lambda (p r)
-                     (let ((name    (package-name p))
-                           (version (package-version p)))
-                       (match (vhash-assoc name r)
-                         ((_ newest-so-far . pkgs)
-                          (case (version-compare version newest-so-far)
-                            ((>) (vhash-cons name `(,version ,p) r))
-                            ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
-                            ((<) r)))
-                         (#f (vhash-cons name `(,version ,p) r)))))
-                   vlist-null)))
-
 (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
 VERSION."
   (if version
       (find-packages-by-name name version)
-      (match (vhash-assoc name (find-newest-available-packages))
-        ((_ version pkgs ...) pkgs)
-        (#f '()))))
+      (match (find-packages-by-name name)
+        (()
+         '())
+        ((matches ...)
+         ;; Return the subset of MATCHES with the higher version number.
+         (let ((highest (package-version (first matches))))
+           (take-while (lambda (p)
+                         (string=? (package-version p) highest))
+                       matches))))))
 
 
 (define %sigint-prompt
-- 
2.20.1





Information forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Sun, 13 Jan 2019 15:48:03 GMT) Full text and rfc822 format available.

Message #17 received at 34060 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 04/10] inferior: Add 'gexp->derivation-in-inferior'.
Date: Sun, 13 Jan 2019 16:47:27 +0100
* guix/inferior.scm (gexp->derivation-in-inferior): New procedure.
---
 guix/inferior.scm | 26 ++++++++++++++++++++++++++
 1 file changed, 26 insertions(+)

diff --git a/guix/inferior.scm b/guix/inferior.scm
index ba8d00866b..42b3545599 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -81,6 +81,8 @@
 
             inferior-package->manifest-entry
 
+            gexp->derivation-in-inferior
+
             %inferior-cache-directory
             inferior-for-channels))
 
@@ -484,6 +486,30 @@ PACKAGE must be live."
   ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET.
   (inferior-package->derivation package system #:target target))
 
+(define* (gexp->derivation-in-inferior name exp guix
+                                       #:rest rest)
+  "Return a derivation that evaluates EXP with GUIX, an instance of Guix as
+returned for example by 'channel-instances->derivation'.  Other arguments are
+passed as-is to 'gexp->derivation'."
+  (define trampoline
+    ;; This is a crude way to run EXP on GUIX.  TODO: use 'raw-derivation' and
+    ;; make 'guix repl' the "builder"; this will require "opening up" the
+    ;; mechanisms behind 'gexp->derivation', and adding '-l' to 'guix repl'.
+    #~(begin
+        (use-modules (ice-9 popen))
+
+        (let ((pipe (open-pipe* OPEN_WRITE
+                                #+(file-append guix "/bin/guix")
+                                "repl")))
+          ;; Unquote EXP right here so that its references to #$output
+          ;; propagate to the surrounding gexp.
+          (write '#$exp pipe)                     ;XXX: load path for EXP?
+
+          (unless (zero? (close-pipe pipe))
+            (error "inferior failed" #+guix)))))
+
+  (apply gexp->derivation name trampoline rest))
+
 
 ;;;
 ;;; Manifest entries.
-- 
2.20.1





Information forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Sun, 13 Jan 2019 15:48:03 GMT) Full text and rfc822 format available.

Message #20 received at 34060 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 05/10] discovery: Add 'fold-module-public-variables*'.
Date: Sun, 13 Jan 2019 16:47:28 +0100
* guix/discovery.scm (fold-module-public-variables*): New procedure.
---
 guix/discovery.scm | 28 ++++++++++++++++++++++++++--
 1 file changed, 26 insertions(+), 2 deletions(-)

diff --git a/guix/discovery.scm b/guix/discovery.scm
index 3fc6e2c9e7..ef5ae73973 100644
--- a/guix/discovery.scm
+++ b/guix/discovery.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo <at> gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -30,7 +30,8 @@
             scheme-modules*
             fold-modules
             all-modules
-            fold-module-public-variables))
+            fold-module-public-variables
+            fold-module-public-variables*))
 
 ;;; Commentary:
 ;;;
@@ -147,10 +148,33 @@ search.  Entries in PATH can be directory names (strings) or (DIRECTORY
 SUB-DIRECTORY."
   (fold-modules cons '() path #:warn warn))
 
+(define (fold-module-public-variables* proc init modules)
+  "Call (PROC MODULE SYMBOL VARIABLE) for each variable exported by one of MODULES,
+using INIT as the initial value of RESULT.  It is guaranteed to never traverse
+the same object twice."
+  ;; Here SEEN is populated by variables; if two different variables refer to
+  ;; the same object, we still let them through.
+  (identity                                       ;discard second return value
+   (fold2 (lambda (module result seen)
+            (fold2 (lambda (sym+var result seen)
+                     (match sym+var
+                       ((sym . var)
+                        (if (not (vhash-assq var seen))
+                            (values (proc module sym var result)
+                                    (vhash-consq var #t seen))
+                            (values result seen)))))
+                   result
+                   seen
+                   (module-map cons module)))
+          init
+          vlist-null
+          modules)))
+
 (define (fold-module-public-variables proc init modules)
   "Call (PROC OBJECT RESULT) for each variable exported by one of MODULES,
 using INIT as the initial value of RESULT.  It is guaranteed to never traverse
 the same object twice."
+  ;; Note: here SEEN is populated by objects, not by variables.
   (identity   ; discard second return value
    (fold2 (lambda (module result seen)
             (fold2 (lambda (var result seen)
-- 
2.20.1





Information forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Sun, 13 Jan 2019 15:48:04 GMT) Full text and rfc822 format available.

Message #23 received at 34060 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 06/10] pull: Build profile with
 'channel-instances->derivation'.
Date: Sun, 13 Jan 2019 16:47:29 +0100
* guix/scripts/package.scm (build-and-use-profile): Rename 'manifest' to
'manifest-or-derivation' and allow it to be a derivation.
* guix/scripts/pull.scm (build-and-install): Use
'channel-instances->derivation' instead of 'channel-instances->manifest'.
---
 guix/scripts/package.scm | 41 ++++++++++++++++++++++------------------
 guix/scripts/pull.scm    |  4 ++--
 2 files changed, 25 insertions(+), 20 deletions(-)

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 872a7303fc..4f483ac141 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -118,24 +118,27 @@ denote ranges as interpreted by 'matching-generations'."
           (else
            (leave (G_ "invalid syntax: ~a~%") pattern)))))
 
-(define* (build-and-use-profile store profile manifest
+(define* (build-and-use-profile store profile manifest-or-derivation
                                 #:key
                                 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."
+specified in MANIFEST-OR-DERIVATION, a manifest object or a profile
+derivation.  When ALLOW-COLLISIONS? is true, do not treat collisions in
+MANIFEST-OR-DERIVATION as an error."
   (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)
-                                         #:locales? (not bootstrap?))))
+  (let* ((prof-drv (if (derivation? manifest-or-derivation)
+                       manifest-or-derivation
+                       (run-with-store store
+                         (profile-derivation manifest-or-derivation
+                                             #:allow-collisions? allow-collisions?
+                                             #:hooks (if bootstrap?
+                                                         '()
+                                                         %default-profile-hooks)
+                                             #:locales? (not bootstrap?)))))
          (prof     (derivation->output-path prof-drv)))
     (show-what-to-build store (list prof-drv)
                         #:use-substitutes? use-substitutes?
@@ -153,18 +156,20 @@ do not treat collisions in MANIFEST as an error."
              ;; overwriting a "previous future generation".
              (name   (generation-file-name profile (+ 1 number))))
         (and (build-derivations store (list prof-drv))
-             (let* ((entries (manifest-entries manifest))
-                    (count   (length entries)))
+             (let* ((entries (and (manifest? manifest-or-derivation)
+                                  (manifest-entries manifest-or-derivation)))
+                    (count   (and entries (length entries))))
                (switch-symlinks name prof)
                (switch-symlinks profile (basename name))
                (unless (string=? profile %current-profile)
                  (register-gc-root store name))
-               (format #t (N_ "~a package in profile~%"
-                              "~a packages in profile~%"
-                              count)
-                       count)
-               (display-search-paths entries (list profile)
-                                     #:kind 'prefix)))
+               (when count
+                 (format #t (N_ "~a package in profile~%"
+                                "~a packages in profile~%"
+                                count)
+                         count)
+                 (display-search-paths entries (list profile)
+                                       #:kind 'prefix))))
 
         (warn-about-disk-space profile))))))
 
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 6d1914f7c2..ce3d24a7f7 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -186,9 +186,9 @@ true, display what would be built without actually building it."
   (define update-profile
     (store-lift build-and-use-profile))
 
-  (mlet %store-monad ((manifest (channel-instances->manifest instances)))
+  (mlet %store-monad ((drv (channel-instances->derivation instances)))
     (mbegin %store-monad
-      (update-profile profile manifest
+      (update-profile profile drv
                       #:dry-run? dry-run?)
       (munless dry-run?
         (return (display-profile-news profile))))))
-- 
2.20.1





Information forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Sun, 13 Jan 2019 15:48:04 GMT) Full text and rfc822 format available.

Message #26 received at 34060 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 08/10] edit: Use 'specification->location' to read information
 from the cache.
Date: Sun, 13 Jan 2019 16:47:31 +0100
That way 'guix edit' doesn't need to load any package module.

* gnu/packages.scm (find-package-locations, specification->location):
New procedures.
* guix/scripts/edit.scm (package->location-specification): Rename to...
(location->location-specification): ... this.  Expect a location object
instead of a package.
(guix-edit): Use 'specification->location' instead of
'specification->package'.
* tests/packages.scm ("find-package-locations")
("find-package-locations with cache")
("specification->location"): New tests.
---
 gnu/packages.scm      | 51 +++++++++++++++++++++++++++++++++++++++++++
 guix/scripts/edit.scm | 29 ++++++++++--------------
 tests/packages.scm    | 23 +++++++++++++++++++
 3 files changed, 85 insertions(+), 18 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index 6796db80a4..cf655e7448 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -55,10 +55,12 @@
             fold-packages
 
             find-packages-by-name
+            find-package-locations
             find-best-packages-by-name
 
             specification->package
             specification->package+output
+            specification->location
             specifications->manifest
 
             generate-package-cache))
@@ -274,6 +276,31 @@ decreasing version order."
                versions modules symbols)))
       (find-packages-by-name/direct name version)))
 
+(define* (find-package-locations name #:optional version)
+  "Return a list of version/location pairs corresponding to each package
+matching NAME and VERSION."
+  (define cache
+    (load-package-cache (current-profile)))
+
+  (if (and cache (cache-is-authoritative?))
+      (match (cache-lookup cache name)
+        (#f '())
+        ((#(name versions modules symbols outputs
+                 supported? deprecated?
+                 files lines columns) ...)
+         (fold (lambda (version* file line column result)
+                 (if (and file
+                          (or (not version)
+                              (version-prefix? version version*)))
+                     (alist-cons version* (location file line column)
+                                 result)
+                     result))
+               '()
+               versions files lines columns)))
+      (map (lambda (package)
+             (cons (package-version package) (package-location package)))
+           (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
@@ -393,6 +420,30 @@ present, return the preferred newest version."
   (let-values (((name version) (package-name->name+version spec)))
     (%find-package spec name version)))
 
+(define (specification->location spec)
+  "Return the location of the highest-numbered package matching SPEC, a
+specification such as \"guile <at> 2\" or \"emacs\"."
+  (let-values (((name version) (package-name->name+version spec)))
+    (match (find-package-locations name version)
+      (()
+       (if version
+           (leave (G_ "~A: package not found for version ~a~%") name version)
+           (leave (G_ "~A: unknown package~%") name)))
+      (lst
+       (let* ((highest   (match lst (((version . _) _ ...) version)))
+              (locations (take-while (match-lambda
+                                       ((version . location)
+                                        (string=? version highest)))
+                                     lst)))
+         (match locations
+           (((version . location) . rest)
+            (unless (null? rest)
+              (warning (G_ "ambiguous package specification `~a'~%") spec)
+              (warning (G_ "choosing ~a@~a from ~a~%")
+                       name version
+                       (location->string location)))
+            location)))))))
+
 (define* (specification->package+output spec #:optional (output "out"))
   "Return the package and output specified by SPEC, or #f and #f; SPEC may
 optionally contain a version number and an output name, as in these examples:
diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm
index 8b2b61d76a..da3d2775e8 100644
--- a/guix/scripts/edit.scm
+++ b/guix/scripts/edit.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2015, 2016, 2019 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2015 Mathieu Lirzin <mthl <at> gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -21,7 +21,6 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix utils)
-  #:use-module (guix packages)
   #:use-module (gnu packages)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-37)
@@ -63,14 +62,13 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n"))
              file path))
     absolute-file-name))
 
-(define (package->location-specification package)
-  "Return the location specification for PACKAGE for a typical editor command
+(define (location->location-specification location)
+  "Return the location specification for LOCATION for a typical editor command
 line."
-  (let ((loc (package-location package)))
-    (list (string-append "+"
-                         (number->string
-                          (location-line loc)))
-          (search-path* %load-path (location-file loc)))))
+  (list (string-append "+"
+                       (number->string
+                        (location-line location)))
+        (search-path* %load-path (location-file location))))
 
 
 (define (guix-edit . args)
@@ -83,18 +81,13 @@ line."
                 '()))
 
   (with-error-handling
-    (let* ((specs    (reverse (parse-arguments)))
-           (packages (map specification->package specs)))
-      (for-each (lambda (package)
-                  (unless (package-location package)
-                    (leave (G_ "source location of package '~a' is unknown~%")
-                           (package-full-name package))))
-                packages)
+    (let* ((specs     (reverse (parse-arguments)))
+           (locations (map specification->location specs)))
 
       (catch 'system-error
         (lambda ()
-          (let ((file-names (append-map package->location-specification
-                                        packages)))
+          (let ((file-names (append-map location->location-specification
+                                        locations)))
             ;; Use `system' instead of `exec' in order to sanely handle
             ;; possible command line arguments in %EDITOR.
             (exit (system (string-join (cons (%editor) file-names))))))
diff --git a/tests/packages.scm b/tests/packages.scm
index 2720ba5a15..8aa117a2e7 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1131,6 +1131,29 @@
     (lambda (key . args)
       key)))
 
+(test-equal "find-package-locations"
+  (map (lambda (package)
+         (cons (package-version package)
+               (package-location package)))
+       (find-packages-by-name "guile"))
+  (find-package-locations "guile"))
+
+(test-equal "find-package-locations with cache"
+  (map (lambda (package)
+         (cons (package-version package)
+               (package-location package)))
+       (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-package-locations "guile"))))))
+
+(test-equal "specification->location"
+  (package-location (specification->package "guile <at> 2"))
+  (specification->location "guile <at> 2"))
+
 (test-end "packages")
 
 ;;; Local Variables:
-- 
2.20.1





Information forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Sun, 13 Jan 2019 15:48:05 GMT) Full text and rfc822 format available.

Message #29 received at 34060 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 09/10] guix package: '--list-available' can use data from the
 cache.
Date: Sun, 13 Jan 2019 16:47:32 +0100
* gnu/packages.scm (fold-available-packages): New procedure.
* guix/scripts/package.scm (process-query): Use it instead of
'fold-packages'.
* tests/packages.scm ("fold-available-packages with/without cache"):
New test.
---
 gnu/packages.scm         | 45 ++++++++++++++++++++++++++++++++++++++++
 guix/scripts/package.scm | 45 ++++++++++++++++++++++------------------
 tests/packages.scm       | 22 ++++++++++++++++++++
 3 files changed, 92 insertions(+), 20 deletions(-)

diff --git a/gnu/packages.scm b/gnu/packages.scm
index cf655e7448..a1814205f9 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -53,6 +53,7 @@
             %default-package-module-path
 
             fold-packages
+            fold-available-packages
 
             find-packages-by-name
             find-package-locations
@@ -182,6 +183,50 @@ flags."
               directory))
         %load-path)))
 
+(define (fold-available-packages proc init)
+  "Fold PROC over the list of available packages.  For each available package,
+PROC is called along these lines:
+
+  (PROC NAME VERSION RESULT
+        #:outputs OUTPUTS
+        #:location LOCATION
+        …)
+
+PROC can use #:allow-other-keys to ignore the bits it's not interested in.
+When a package cache is available, this procedure does not actually load any
+package module."
+  (define cache
+    (load-package-cache (current-profile)))
+
+  (if (and cache (cache-is-authoritative?))
+      (vhash-fold (lambda (name vector result)
+                    (match vector
+                      (#(name version module symbol outputs
+                              supported? deprecated?
+                              file line column)
+                       (proc name version result
+                             #:outputs outputs
+                             #:location (and file
+                                             (location file line column))
+                             #:supported? supported?
+                             #:deprecated? deprecated?))))
+                  init
+                  cache)
+      (fold-packages (lambda (package result)
+                       (proc (package-name package)
+                             (package-version package)
+                             result
+                             #:outputs (package-outputs package)
+                             #:location (package-location package)
+                             #:supported?
+                             (->bool
+                              (member (%current-system)
+                                      (package-supported-systems package)))
+                             #:deprecated?
+                             (->bool
+                              (package-superseded package))))
+                     init)))
+
 (define* (fold-packages proc init
                         #:optional
                         (modules (all-modules (%package-module-path)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 4f483ac141..e6f633b630 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -741,29 +741,34 @@ processed, #f otherwise."
 
       (('list-available regexp)
        (let* ((regexp    (and regexp (make-regexp* regexp)))
-              (available (fold-packages
-                          (lambda (p r)
-                            (let ((n (package-name p)))
-                              (if (and (supported-package? p)
-                                       (not (package-superseded p)))
-                                  (if regexp
-                                      (if (regexp-exec regexp n)
-                                          (cons p r)
-                                          r)
-                                      (cons p r))
-                                  r)))
+              (available (fold-available-packages
+                          (lambda* (name version result
+                                         #:key outputs location
+                                         supported? superseded?
+                                         #:allow-other-keys)
+                            (if (and supported? (not superseded?))
+                                (if regexp
+                                    (if (regexp-exec regexp name)
+                                        (cons `(,name ,version
+                                                      ,outputs ,location)
+                                              result)
+                                        result)
+                                    (cons `(,name ,version
+                                                  ,outputs ,location)
+                                          result))
+                                result))
                           '())))
          (leave-on-EPIPE
-          (for-each (lambda (p)
-                      (format #t "~a\t~a\t~a\t~a~%"
-                              (package-name p)
-                              (package-version p)
-                              (string-join (package-outputs p) ",")
-                              (location->string (package-location p))))
+          (for-each (match-lambda
+                      ((name version outputs location)
+                       (format #t "~a\t~a\t~a\t~a~%"
+                               name version
+                               (string-join outputs ",")
+                               (location->string location))))
                     (sort available
-                          (lambda (p1 p2)
-                            (string<? (package-name p1)
-                                      (package-name p2))))))
+                          (match-lambda*
+                            (((name1 . _) (name2 . _))
+                             (string<? name1 name2))))))
          #t))
 
       (('search _)
diff --git a/tests/packages.scm b/tests/packages.scm
index 8aa117a2e7..ed635d9011 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -995,6 +995,28 @@
     ((one)
      (eq? one guile-2.0))))
 
+(test-assert "fold-available-packages with/without cache"
+  (let ()
+    (define no-cache
+      (fold-available-packages (lambda* (name version result #:rest rest)
+                                 (cons (cons* name version rest)
+                                       result))
+                               '()))
+
+    (define from-cache
+      (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))
+                     (fold-available-packages (lambda* (name version result
+                                                             #:rest rest)
+                                                (cons (cons* name version rest)
+                                                      result))
+                                              '()))))))
+
+    (lset= equal? no-cache from-cache)))
+
 (test-assert "find-packages-by-name"
   (match (find-packages-by-name "hello")
     (((? (cut eq? hello <>))) #t)
-- 
2.20.1





Information forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Sun, 13 Jan 2019 15:48:05 GMT) Full text and rfc822 format available.

Message #32 received at 34060 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 10/10] status: Distinguish 'package-cache' profile hook.
Date: Sun, 13 Jan 2019 16:47:33 +0100
* guix/status.scm (hook-message): Handle 'package-cache'.
---
 guix/status.scm | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/guix/status.scm b/guix/status.scm
index 2928733257..5b339bdec7 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -314,6 +314,8 @@ on."
      (G_ "building fonts directory..."))
     ('manual-database
      (G_ "building database for manual pages..."))
+    ('package-cache                    ;package cache generated by 'guix pull'
+     (G_ "building package cache..."))
     (_ #f)))
 
 (define* (print-build-event event old-status status
-- 
2.20.1





Information forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Sun, 13 Jan 2019 15:48:06 GMT) Full text and rfc822 format available.

Message #35 received at 34060 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 07/10] channels: Compute a package cache and use it.
Date: Sun, 13 Jan 2019 16:47:30 +0100
* 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-instances->derivation): Use it in #:hooks.
---
 gnu/packages.scm   | 127 +++++++++++++++++++++++++++++++++++++++++++--
 guix/channels.scm  |  32 +++++++++++-
 tests/packages.scm |  18 +++++++
 3 files changed, 172 insertions(+), 5 deletions(-)

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 @@
   #: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 6b860f3bd8..cf5edddf03 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?
@@ -416,11 +418,37 @@ 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-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 (cons package-cache-file
+                                      %default-profile-hooks))))
 
 (define latest-channel-instances*
   (store-lift latest-channel-instances))
diff --git a/tests/packages.scm b/tests/packages.scm
index eb8ede3207..2720ba5a15 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
-- 
2.20.1





Reply sent to Ludovic Courtès <ludo <at> gnu.org>:
You have taken responsibility. (Tue, 15 Jan 2019 19:27:01 GMT) Full text and rfc822 format available.

Notification sent to Ludovic Courtès <ludo <at> gnu.org>:
bug acknowledged by developer. (Tue, 15 Jan 2019 19:27:01 GMT) Full text and rfc822 format available.

Message #40 received at 34060-done <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060-done <at> debbugs.gnu.org
Subject: Re: [bug#34060] [PATCH 00/10] Add a cache for package lookups
Date: Tue, 15 Jan 2019 20:26:01 +0100
Pushed!

  b9da4b931d status: Distinguish 'package-cache' profile hook.
  0ea939fb79 guix package: '--list-available' can use data from the cache.
  ee8099f5b6 edit: Use 'specification->location' to read information from the cache.
  5fbdc9a5aa channels: Compute a package cache and use it.
  1d90e9d7c9 discovery: Add 'fold-module-public-variables*'.
  ae92782240 inferior: Add 'gexp->derivation-in-inferior'.
  e2a903c807 packages: Remove 'find-newest-available-packages'.
  465a0d65ae guix package: Avoid 'find-newest-available-packages'.
  461d6c2eff profiling: Add a "gc" profiling component.

Ludo’.




Information forwarded to guix-patches <at> gnu.org:
bug#34060; Package guix-patches. (Tue, 15 Jan 2019 19:29:02 GMT) Full text and rfc822 format available.

Message #43 received at 34060 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 34060 <at> debbugs.gnu.org
Subject: Re: [bug#34060] [PATCH 06/10] pull: Build profile with
 'channel-instances->derivation'.
Date: Tue, 15 Jan 2019 20:27:57 +0100
Ludovic Courtès <ludo <at> gnu.org> skribis:

> * guix/scripts/package.scm (build-and-use-profile): Rename 'manifest' to
> 'manifest-or-derivation' and allow it to be a derivation.
> * guix/scripts/pull.scm (build-and-install): Use
> 'channel-instances->derivation' instead of 'channel-instances->manifest'.
> ---
>  guix/scripts/package.scm | 41 ++++++++++++++++++++++------------------
>  guix/scripts/pull.scm    |  4 ++--
>  2 files changed, 25 insertions(+), 20 deletions(-)
>
> diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
> index 872a7303fc..4f483ac141 100644
> --- a/guix/scripts/package.scm
> +++ b/guix/scripts/package.scm
> @@ -118,24 +118,27 @@ denote ranges as interpreted by 'matching-generations'."
>            (else
>             (leave (G_ "invalid syntax: ~a~%") pattern)))))
>  
> -(define* (build-and-use-profile store profile manifest
> +(define* (build-and-use-profile store profile manifest-or-derivation

I realized that this hack could be avoided by simply adding a #:hooks
parameter here, which is what I ended up doing in commit
5fbdc9a5aa63fd51c65d30fe3d30608d01fe1bc8.

Ludo’.




bug archived. Request was from Debbugs Internal Request <help-debbugs <at> gnu.org> to internal_control <at> debbugs.gnu.org. (Wed, 13 Feb 2019 12:24:05 GMT) Full text and rfc822 format available.

This bug report was last modified 5 years and 66 days ago.

Previous Next


GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.