kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases 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
;;; 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)
(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)))))))))
(fold (lambda (input systems)
(match input
((label (? package? p) . _)
(lset-intersection
string=? systems (package-transitive-supported-systems p)))
(_
systems)))
(package-supported-systems package)
(package-direct-inputs package)))
(define (bag-transitive-inputs bag)
"Same as 'package-transitive-inputs', but applied to a bag."