diff options
| -rw-r--r-- | doc/guix.texi | 5 | ||||
| -rw-r--r-- | guix/packages.scm | 89 | ||||
| -rw-r--r-- | tests/packages.scm | 11 |
3 files changed, 58 insertions, 47 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index e475463782..88909c42a9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -765,9 +765,8 @@ The build actions it prescribes may then be realized by using the @code{build-derivations} procedure (@pxref{The Store}). @deffn {Scheme Procedure} package-derivation @var{store} @var{package} [@var{system}] -Return the derivation of @var{package} for @var{system}. The result is -the file name of the derivation---i.e., a @code{.drv} file under -@code{/nix/store}. +Return the derivation path and corresponding @code{<derivation>} object +of @var{package} for @var{system} (@pxref{Derivations}). @var{package} must be a valid @code{<package>} object, and @var{system} must be a string denoting the target system type---e.g., diff --git a/guix/packages.scm b/guix/packages.scm index e65877df58..da8f45af5e 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -217,25 +217,34 @@ recursively." ;; Package to derivation-path mapping. (make-weak-key-hash-table 100)) -(define (cache package system drv) - "Memoize DRV as the derivation of PACKAGE on SYSTEM." - - ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the - ;; same value for all structs (as of Guile 2.0.6), and because pointer - ;; equality is sufficient in practice. - (hashq-set! %derivation-cache package `((,system . ,drv))) - drv) - -(define (cached-derivation package system) - "Return the cached derivation path of PACKAGE for SYSTEM, or #f." - (match (hashq-ref %derivation-cache package) - ((alist ...) - (assoc-ref alist system)) - (#f #f))) +(define (cache package system thunk) + "Memoize the return values of THUNK as the derivation of PACKAGE on +SYSTEM." + (let ((vals (call-with-values thunk list))) + ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the + ;; same value for all structs (as of Guile 2.0.6), and because pointer + ;; equality is sufficient in practice. + (hashq-set! %derivation-cache package `((,system ,@vals))) + (apply values vals))) + +(define-syntax-rule (cached package system body ...) + "Memoize the result of BODY for the arguments PACKAGE and SYSTEM. +Return the cached result when available." + (let ((thunk (lambda () body ...))) + (match (hashq-ref %derivation-cache package) + ((alist (... ...)) + (match (assoc-ref alist system) + ((vals (... ...)) + (apply values vals)) + (#f + (cache package system thunk)))) + (#f + (cache package system thunk))))) (define* (package-derivation store package #:optional (system (%current-system))) - "Return the derivation of PACKAGE for SYSTEM." + "Return the derivation path and corresponding <derivation> object of +PACKAGE for SYSTEM." (define (intern file) ;; Add FILE to the store. Set the `recursive?' bit to #t, so that ;; file permissions are preserved. @@ -281,32 +290,28 @@ recursively." (package package) (input x))))))) - (or (cached-derivation package system) - - ;; Compute the derivation and cache the result. Caching is - ;; important because some derivations, such as the implicit inputs - ;; of the GNU build system, will be queried many, many times in a - ;; row. - (cache - package system - (match package - (($ <package> name version source (= build-system-builder builder) - args inputs propagated-inputs native-inputs self-native-input? - outputs) - ;; TODO: For `search-paths', add a builder prologue that calls - ;; `set-path-environment-variable'. - (let ((inputs (map expand-input - (package-transitive-inputs package)))) - - (apply builder - store (package-full-name package) - (and source - (package-source-derivation store source system)) - inputs - #:outputs outputs #:system system - (if (procedure? args) - (args system) - args)))))))) + ;; Compute the derivation and cache the result. Caching is important + ;; because some derivations, such as the implicit inputs of the GNU build + ;; system, will be queried many, many times in a row. + (cached package system + (match package + (($ <package> name version source (= build-system-builder builder) + args inputs propagated-inputs native-inputs self-native-input? + outputs) + ;; TODO: For `search-paths', add a builder prologue that calls + ;; `set-path-environment-variable'. + (let ((inputs (map expand-input + (package-transitive-inputs package)))) + + (apply builder + store (package-full-name package) + (and source + (package-source-derivation store source system)) + inputs + #:outputs outputs #:system system + (if (procedure? args) + (args system) + args))))))) (define* (package-cross-derivation store package) ;; TODO diff --git a/tests/packages.scm b/tests/packages.scm index ea0df511d2..990deb79ef 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +27,7 @@ #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages bootstrap) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) #:use-module (rnrs io ports) @@ -70,7 +71,13 @@ ("d" ,d) ("d/x" "something.drv")) (pk 'x (package-transitive-inputs e)))))) -(test-skip (if (not %store) 2 0)) +(test-skip (if (not %store) 3 0)) + +(test-assert "return values" + (let-values (((drv-path drv) + (package-derivation %store (dummy-package "p")))) + (and (derivation-path? drv-path) + (derivation? drv)))) (test-assert "trivial" (let* ((p (package (inherit (dummy-package "trivial")) |