summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/packages.scm127
-rw-r--r--guix/channels.scm36
-rw-r--r--guix/scripts/package.scm8
-rw-r--r--guix/scripts/pull.scm1
-rw-r--r--tests/packages.scm18
5 files changed, 181 insertions, 9 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..cd8a0131bd 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -21,6 +21,7 @@
#:use-module (guix git)
#:use-module (guix records)
#:use-module (guix gexp)
+ #:use-module (guix modules)
#:use-module (guix discovery)
#:use-module (guix monads)
#:use-module (guix profiles)
@@ -31,7 +32,8 @@
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
- #:autoload (guix self) (whole-package)
+ #:autoload (guix self) (whole-package make-config.scm)
+ #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
#:use-module (ice-9 match)
#:export (channel
channel?
@@ -52,6 +54,7 @@
checkout->channel-instance
latest-channel-derivation
channel-instances->manifest
+ %channel-profile-hooks
channel-instances->derivation))
;;; Commentary:
@@ -416,11 +419,40 @@ channel instances."
(zip instances derivations))))
(return (manifest entries))))
+(define (package-cache-file manifest)
+ "Build a package cache file for the instance in MANIFEST. This is meant to
+be used as a profile hook."
+ (mlet %store-monad ((profile (profile-derivation manifest
+ #:hooks '())))
+
+ (define build
+ #~(begin
+ (use-modules (gnu packages))
+
+ (if (defined? 'generate-package-cache)
+ (begin
+ ;; Delegate package cache generation to the inferior.
+ (format (current-error-port)
+ "Generating package cache for '~a'...~%"
+ #$profile)
+ (generate-package-cache #$output))
+ (mkdir #$output))))
+
+ (gexp->derivation-in-inferior "guix-package-cache" build
+ profile
+ #:properties '((type . profile-hook)
+ (hook . package-cache)))))
+
+(define %channel-profile-hooks
+ ;; The default channel profile hooks.
+ (cons package-cache-file %default-profile-hooks))
+
(define (channel-instances->derivation instances)
"Return the derivation of the profile containing INSTANCES, a list of
channel instances."
(mlet %store-monad ((manifest (channel-instances->manifest instances)))
- (profile-derivation manifest)))
+ (profile-derivation manifest
+ #:hooks %channel-profile-hooks)))
(define latest-channel-instances*
(store-lift latest-channel-instances))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index ba33790eda..e9bed0be1e 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -120,21 +120,21 @@ denote ranges as interpreted by 'matching-generations'."
(define* (build-and-use-profile store profile manifest
#:key
+ (hooks %default-profile-hooks)
allow-collisions?
bootstrap? use-substitutes?
dry-run?)
"Build a new generation of PROFILE, a file name, using the packages
specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true,
-do not treat collisions in MANIFEST as an error."
+do not treat collisions in MANIFEST as an error. HOOKS is a list of \"profile
+hooks\" run when building the profile."
(when (equal? profile %current-profile)
(ensure-default-profile))
(let* ((prof-drv (run-with-store store
(profile-derivation manifest
#:allow-collisions? allow-collisions?
- #:hooks (if bootstrap?
- '()
- %default-profile-hooks)
+ #:hooks (if bootstrap? '() hooks)
#:locales? (not bootstrap?))))
(prof (derivation->output-path prof-drv)))
(show-what-to-build store (list prof-drv)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 0339b149fa..513434c5f1 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -188,6 +188,7 @@ true, display what would be built without actually building it."
(mlet %store-monad ((manifest (channel-instances->manifest instances)))
(mbegin %store-monad
(update-profile profile manifest
+ #:hooks %channel-profile-hooks
#:dry-run? dry-run?)
(munless dry-run?
(return (display-profile-news profile))))))
diff --git a/tests/packages.scm b/tests/packages.scm
index 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