mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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.
This commit is contained in:
parent
079fca3be8
commit
e509d1527d
3 changed files with 56 additions and 45 deletions
|
@ -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.,
|
||||
|
|
|
@ -217,25 +217,34 @@ (define %derivation-cache
|
|||
;; 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."
|
||||
(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)))
|
||||
|
||||
;; 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-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 @@ (define expand-input
|
|||
(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.
|
||||
(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))))
|
||||
|
||||
;; 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))))))))
|
||||
(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
|
||||
|
|
|
@ -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 @@ (define-module (test-packages)
|
|||
#: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 @@ (define-syntax-rule (dummy-package name* extra-fields ...)
|
|||
("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"))
|
||||
|
|
Loading…
Reference in a new issue