From a2ebaddda7a5bd2b18193c5039f2650c07cce754 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 1 Sep 2012 19:21:06 +0200
Subject: packages: Cache the result of `package-derivation'.

* guix/packages.scm (%derivation-cache): New variable.
  (cache, cached-derivation): New procedures.
  (package-derivation): Use them.
---
 guix/packages.scm | 99 ++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 62 insertions(+), 37 deletions(-)

(limited to 'guix/packages.scm')

diff --git a/guix/packages.scm b/guix/packages.scm
index 0ecd4ca6d4..2ab45f9fb4 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -217,46 +217,71 @@ with their propagated inputs, recursively."
       ((input rest ...)
        (loop rest (cons input result))))))
 
+
+;;;
+;;; Package derivations.
+;;;
+
+(define %derivation-cache
+  ;; Package to derivation-path mapping.
+  (make-weak-key-hash-table))
+
+(define (cache package system drv)
+  "Memoize DRV as the derivation of PACKAGE on SYSTEM."
+  (hash-set! %derivation-cache (cons package system) drv)
+  drv)
+
+(define (cached-derivation package system)
+  "Return the cached derivation path of PACKAGE for SYSTEM, or #f."
+  (hash-ref %derivation-cache (cons package system)))
+
 (define* (package-derivation store package
                              #:optional (system (%current-system)))
   "Return the derivation of PACKAGE for 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 (match-lambda
-                         (((? string? name) (and package ($ <package>)))
-                          (list name (package-derivation store package)))
-                         (((? string? name) (and package ($ <package>))
-                           (? string? sub-drv))
-                          (list name (package-derivation store package)
-                                sub-drv))
-                         (((? string? name)
-                           (and (? string?) (? derivation-path?) drv))
-                          (list name drv))
-                         (((? string? name)
-                           (and (? string?) (? file-exists? file)))
-                          ;; Add FILE to the store.  When FILE is in the
-                          ;; sub-directory of a store path, it needs to be
-                          ;; added anyway, so it can be used as a source.
-                          (list name
-                                (add-to-store store (basename file)
-                                              #t #f "sha256" file)))
-                         (x
-                          (raise (condition (&package-input-error
-                                             (package package)
-                                             (input   x))))))
-                        (package-transitive-inputs package))))
-       (apply builder
-              store (string-append name "-" version)
-              (package-source-derivation store source)
-              inputs
-              #:outputs outputs #:system system
-              (if (procedure? args)
-                  (args system)
-                  args))))))
+  (or (cached-derivation 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 (match-lambda
+                             (((? string? name) (? package? package))
+                              (list name (package-derivation store package)))
+                             (((? string? name) (? package? package)
+                               (? string? sub-drv))
+                              (list name (package-derivation store package)
+                                    sub-drv))
+                             (((? string? name)
+                               (and (? string?) (? derivation-path?) drv))
+                              (list name drv))
+                             (((? string? name)
+                               (and (? string?) (? file-exists? file)))
+                              ;; Add FILE to the store.  When FILE is in the
+                              ;; sub-directory of a store path, it needs to be
+                              ;; added anyway, so it can be used as a source.
+                              (list name
+                                    (add-to-store store (basename file)
+                                                  #t #f "sha256" file)))
+                             (x
+                              (raise (condition (&package-input-error
+                                                 (package package)
+                                                 (input   x))))))
+                            (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
+                  (apply builder
+                         store (string-append name "-" version)
+                         (package-source-derivation store source)
+                         inputs
+                         #:outputs outputs #:system system
+                         (if (procedure? args)
+                             (args system)
+                             args))))))))
 
 (define* (package-cross-derivation store package)
   ;; TODO
-- 
cgit v1.2.3