futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Optimize package-transitive-supported-systems.

Browse Source 
* guix/packages.scm (first-value): Remove.
  (define-memoized/v): New macro.
  (package-transitive-supported-systems): Rewrite.
This commit is contained in:
Mark H Weaver 2014-12-21 16:21:02 -05:00
parent d95523fb8b
commit a193b8248b
1 changed files with 30 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
guix/packages.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -543,40 +544,38 @@ for the host system (\"native inputs\"), and not target inputs."
recursively." recursively."
(transitive-inputs (package-propagated-inputs package))) (transitive-inputs (package-propagated-inputs package)))
(define-syntax-rule (first-value exp) (define-syntax define-memoized/v
"Truncate all but the first value returned by EXP." (lambda (form)
(call-with-values (lambda () exp) "Define a memoized single-valued unary procedure with docstring.
(lambda (result . _) The procedure argument is compared to cached keys using `eqv?'."
result))) (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 "Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies." supported by its dependencies."
(first-value (fold (lambda (input systems)
(let loop ((package package) (match input
(systems (package-supported-systems package)) ((label (? package? p) . _)
(visited vlist-null)) (lset-intersection
(match (vhash-assq package visited) string=? systems (package-transitive-supported-systems p)))
((_ . result) (_
(values (lset-intersection string=? systems result) systems)))
visited)) (package-supported-systems package)
(#f (package-direct-inputs package)))
(call-with-values
(lambda ()
(fold2 (lambda (input systems visited)
(match input
((label (? package? package) . _)
(loop package systems visited))
(_
(values systems visited))))
(lset-intersection string=?
systems
(package-supported-systems package))
visited
(package-direct-inputs package)))
(lambda (systems visited)
(values systems
(vhash-consq package systems visited)))))))))
(define (bag-transitive-inputs bag) (define (bag-transitive-inputs bag)
"Same as 'package-transitive-inputs', but applied to a bag." "Same as 'package-transitive-inputs', but applied to a bag."