summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-01-20 22:17:58 +0100
committerLudovic Courtès <ludo@gnu.org>2013-01-20 22:54:36 +0100
commite509d1527d231b6460a20762e13b57cba2e43485 (patch)
tree750b7bb4c321d42d17ca2b50679d682373d5251b
parent079fca3be86e38bcbefa67e6f07b7ff440726ceb (diff)
packages: Have `package-derivation' return a <derivation> as a second value.
* guix/packages.scm (cache): Change the `drv' argument to `thunk'. Memoize all the return values of THUNK. (cached-derivation): Remove. (cached): New macro. (package-derivation): Use `cached' instead of `(or (cached-derivation) …)'. * doc/guix.texi (Defining Packages): Update accordingly.
-rw-r--r--doc/guix.texi5
-rw-r--r--guix/packages.scm89
-rw-r--r--tests/packages.scm11
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"))