From a193b8248b235d1c29905c5be9431ba20c7bf412 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 21 Dec 2014 16:21:02 -0500
Subject: Optimize package-transitive-supported-systems.

* guix/packages.scm (first-value): Remove.
  (define-memoized/v): New macro.
  (package-transitive-supported-systems): Rewrite.
---
 guix/packages.scm | 61 +++++++++++++++++++++++++++----------------------------
 1 file changed, 30 insertions(+), 31 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 07f6d0ccbc..2a9a55e12f 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -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."
-- 
cgit 1.4.1