nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

channels: Compute a package cache and use it. 

* gnu/packages.scm (cache-is-authoritative?, load-package-cache)
(cache-lookup, generate-package-cache): New procedures.
(%package-cache-file): New variable.
(find-packages-by-name): Rename to...
(find-packages-by-name/direct): ... this.
(find-packages-by-name): Rewrite to use the package cache when
'cache-is-authoritative?' returns true.
* tests/packages.scm ("find-packages-by-name + version, with cache")
("find-packages-by-name with cache"): New tests.
* guix/channels.scm (package-cache-file): New procedure.
(%channel-profile-hooks): New variable.
(channel-instances->derivation): Use it in #:hooks.
* guix/scripts/package.scm (build-and-use-profile): Add #:hooks and
honor it.
* guix/scripts/pull.scm (build-and-install): Pass #:hooks to
UPDATE-PROFILE.
This commit is contained in:
Ludovic Courtès 2019-01-11 17:23:39 +01:00
parent 1d90e9d7c9
commit 5fbdc9a5aa
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
5 changed files with 181 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

127
gnu/packages.scm
View File

@ -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.

36
guix/channels.scm
View File

@ -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))

8
guix/scripts/package.scm
View File

@ -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)

1
guix/scripts/pull.scm
View File

@ -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))))))

18
tests/packages.scm
View File

@ -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