Optimize package-transitive-supported-systems.
* guix/packages.scm (first-value): Remove. (define-memoized/v): New macro. (package-transitive-supported-systems): Rewrite.
This commit is contained in:
parent
d95523fb8b
commit
a193b8248b
|
@ -1,5 +1,6 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
@ -543,40 +544,38 @@ for the host system (\"native inputs\"), and not target inputs."
|
|||
recursively."
|
||||
(transitive-inputs (package-propagated-inputs package)))
|
||||
|
||||
(define-syntax-rule (first-value exp)
|
||||
"Truncate all but the first value returned by EXP."
|
||||
(call-with-values (lambda () exp)
|
||||
(lambda (result . _)
|
||||
result)))
|
||||
(define-syntax define-memoized/v
|
||||
(lambda (form)
|
||||
"Define a memoized single-valued unary procedure with docstring.
|
||||
The procedure argument is compared to cached keys using `eqv?'."
|
||||
(syntax-case form ()
|
||||
((_ (proc arg) docstring body body* ...)
|
||||
(string? (syntax->datum #'docstring))
|
||||
#'(define proc
|
||||
(let ((cache (make-hash-table)))
|
||||
(define (proc arg)
|
||||
docstring
|
||||
(match (hashv-get-handle cache arg)
|
||||
((_ . value)
|
||||
value)
|
||||
(_
|
||||
(let ((result (let () body body* ...)))
|
||||
(hashv-set! cache arg result)
|
||||
result))))
|
||||
proc))))))
|
||||
|
||||
(define (package-transitive-supported-systems package)
|
||||
(define-memoized/v (package-transitive-supported-systems package)
|
||||
"Return the intersection of the systems supported by PACKAGE and those
|
||||
supported by its dependencies."
|
||||
(first-value
|
||||
(let loop ((package package)
|
||||
(systems (package-supported-systems package))
|
||||
(visited vlist-null))
|
||||
(match (vhash-assq package visited)
|
||||
((_ . result)
|
||||
(values (lset-intersection string=? systems result)
|
||||
visited))
|
||||
(#f
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(fold2 (lambda (input systems visited)
|
||||
(fold (lambda (input systems)
|
||||
(match input
|
||||
((label (? package? package) . _)
|
||||
(loop package systems visited))
|
||||
((label (? package? p) . _)
|
||||
(lset-intersection
|
||||
string=? systems (package-transitive-supported-systems p)))
|
||||
(_
|
||||
(values systems visited))))
|
||||
(lset-intersection string=?
|
||||
systems
|
||||
(package-supported-systems package))
|
||||
visited
|
||||
systems)))
|
||||
(package-supported-systems package)
|
||||
(package-direct-inputs package)))
|
||||
(lambda (systems visited)
|
||||
(values systems
|
||||
(vhash-consq package systems visited)))))))))
|
||||
|
||||
(define (bag-transitive-inputs bag)
|
||||
"Same as 'package-transitive-inputs', but applied to a bag."
|
||||
|
|
Loading…
Reference in New Issue