* [bug#34060] [PATCH 02/10] guix package: Avoid 'find-newest-available-packages'.
2019-01-13 15:47 ` [bug#34060] [PATCH 01/10] profiling: Add a "gc" profiling component Ludovic Courtès
@ 2019-01-13 15:47 ` Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 03/10] packages: Remove 'find-newest-available-packages' Ludovic Courtès
` (7 subsequent siblings)
8 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-01-13 15:47 UTC (permalink / raw)
To: 34060
* 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@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@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
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#34060] [PATCH 03/10] packages: Remove 'find-newest-available-packages'.
2019-01-13 15:47 ` [bug#34060] [PATCH 01/10] profiling: Add a "gc" profiling component Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 02/10] guix package: Avoid 'find-newest-available-packages' Ludovic Courtès
@ 2019-01-13 15:47 ` Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 04/10] inferior: Add 'gexp->derivation-in-inferior' Ludovic Courtès
` (6 subsequent siblings)
8 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-01-13 15:47 UTC (permalink / raw)
To: 34060
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@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016, 2017 Alex Kost <alezost@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))))))
\f
(define %sigint-prompt
--
2.20.1
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#34060] [PATCH 04/10] inferior: Add 'gexp->derivation-in-inferior'.
2019-01-13 15:47 ` [bug#34060] [PATCH 01/10] profiling: Add a "gc" profiling component Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 02/10] guix package: Avoid 'find-newest-available-packages' Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 03/10] packages: Remove 'find-newest-available-packages' Ludovic Courtès
@ 2019-01-13 15:47 ` Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 05/10] discovery: Add 'fold-module-public-variables*' Ludovic Courtès
` (5 subsequent siblings)
8 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-01-13 15:47 UTC (permalink / raw)
To: 34060
* 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))
+
\f
;;;
;;; Manifest entries.
--
2.20.1
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#34060] [PATCH 05/10] discovery: Add 'fold-module-public-variables*'.
2019-01-13 15:47 ` [bug#34060] [PATCH 01/10] profiling: Add a "gc" profiling component Ludovic Courtès
` (2 preceding siblings ...)
2019-01-13 15:47 ` [bug#34060] [PATCH 04/10] inferior: Add 'gexp->derivation-in-inferior' Ludovic Courtès
@ 2019-01-13 15:47 ` Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 06/10] pull: Build profile with 'channel-instances->derivation' Ludovic Courtès
` (4 subsequent siblings)
8 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-01-13 15:47 UTC (permalink / raw)
To: 34060
* 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@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@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
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#34060] [PATCH 06/10] pull: Build profile with 'channel-instances->derivation'.
2019-01-13 15:47 ` [bug#34060] [PATCH 01/10] profiling: Add a "gc" profiling component Ludovic Courtès
` (3 preceding siblings ...)
2019-01-13 15:47 ` [bug#34060] [PATCH 05/10] discovery: Add 'fold-module-public-variables*' Ludovic Courtès
@ 2019-01-13 15:47 ` Ludovic Courtès
2019-01-15 19:27 ` Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 07/10] channels: Compute a package cache and use it Ludovic Courtès
` (3 subsequent siblings)
8 siblings, 1 reply; 13+ messages in thread
From: Ludovic Courtès @ 2019-01-13 15:47 UTC (permalink / raw)
To: 34060
* 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
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#34060] [PATCH 06/10] pull: Build profile with 'channel-instances->derivation'.
2019-01-13 15:47 ` [bug#34060] [PATCH 06/10] pull: Build profile with 'channel-instances->derivation' Ludovic Courtès
@ 2019-01-15 19:27 ` Ludovic Courtès
0 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-01-15 19:27 UTC (permalink / raw)
To: 34060
Ludovic Courtès <ludo@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’.
^ permalink raw reply [flat|nested] 13+ messages in thread
* [bug#34060] [PATCH 07/10] channels: Compute a package cache and use it.
2019-01-13 15:47 ` [bug#34060] [PATCH 01/10] profiling: Add a "gc" profiling component Ludovic Courtès
` (4 preceding siblings ...)
2019-01-13 15:47 ` [bug#34060] [PATCH 06/10] pull: Build profile with 'channel-instances->derivation' Ludovic Courtès
@ 2019-01-13 15:47 ` Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 08/10] edit: Use 'specification->location' to read information from the cache Ludovic Courtès
` (2 subsequent siblings)
8 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-01-13 15:47 UTC (permalink / raw)
To: 34060
* 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)
+
\f
(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
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#34060] [PATCH 08/10] edit: Use 'specification->location' to read information from the cache.
2019-01-13 15:47 ` [bug#34060] [PATCH 01/10] profiling: Add a "gc" profiling component Ludovic Courtès
` (5 preceding siblings ...)
2019-01-13 15:47 ` [bug#34060] [PATCH 07/10] channels: Compute a package cache and use it Ludovic Courtès
@ 2019-01-13 15:47 ` Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 09/10] guix package: '--list-available' can use data " Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 10/10] status: Distinguish 'package-cache' profile hook Ludovic Courtès
8 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-01-13 15:47 UTC (permalink / raw)
To: 34060
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@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@gnu.org>
+;;; Copyright © 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mathieu Lirzin <mthl@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))))
\f
(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@2"))
+ (specification->location "guile@2"))
+
(test-end "packages")
;;; Local Variables:
--
2.20.1
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#34060] [PATCH 09/10] guix package: '--list-available' can use data from the cache.
2019-01-13 15:47 ` [bug#34060] [PATCH 01/10] profiling: Add a "gc" profiling component Ludovic Courtès
` (6 preceding siblings ...)
2019-01-13 15:47 ` [bug#34060] [PATCH 08/10] edit: Use 'specification->location' to read information from the cache Ludovic Courtès
@ 2019-01-13 15:47 ` Ludovic Courtès
2019-01-13 15:47 ` [bug#34060] [PATCH 10/10] status: Distinguish 'package-cache' profile hook Ludovic Courtès
8 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-01-13 15:47 UTC (permalink / raw)
To: 34060
* 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
^ permalink raw reply related [flat|nested] 13+ messages in thread* [bug#34060] [PATCH 10/10] status: Distinguish 'package-cache' profile hook.
2019-01-13 15:47 ` [bug#34060] [PATCH 01/10] profiling: Add a "gc" profiling component Ludovic Courtès
` (7 preceding siblings ...)
2019-01-13 15:47 ` [bug#34060] [PATCH 09/10] guix package: '--list-available' can use data " Ludovic Courtès
@ 2019-01-13 15:47 ` Ludovic Courtès
8 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2019-01-13 15:47 UTC (permalink / raw)
To: 34060
* 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
^ permalink raw reply related [flat|nested] 13+ messages in thread