Subject: [PATCH v2 2/2] guix: fix: slow `map-derivation' procedure

From: Sergio Pastor Pérez <[email-masked]>
Date: Wed, 5 Feb 2025 13:29:34 +0100

Implement caching to speed up computation.

Change-Id: I186e2a62f6655e3b0738dd6e0f628faccd8b855e
---
 guix/derivations.scm | 108 +++++++++++++++++++++++--------------------
 1 file changed, 58 insertions(+), 50 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 9c019a35bb..aa7f55ee92 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -1044,7 +1044,8 @@ (define* (map-derivation store drv mapping
                            ((file . replacement)
                             (vhash-cons file replacement result))))
                        vlist-null
-                       mapping)))
+                       mapping))
+        (computed-drvs (make-hash-table 100)))
     (define rewritten-input
       ;; Rewrite the given input according to MAPPING, and return an input
       ;; in the format used in 'derivation' calls.
@@ -1060,55 +1061,62 @@ (define* (map-derivation store drv mapping
               (derivation-input (loop drv) sub-drvs)))))))
 
     (let loop ((drv drv))
-      (let* ((inputs       (map (cut rewritten-input <> loop)
-                                (derivation-inputs drv)))
-             (initial      (append-map derivation-input-output-paths
-                                       (derivation-inputs drv)))
-             (replacements (append-map input->output-paths inputs))
-
-             ;; Sources typically refer to the output directories of the
-             ;; original inputs, INITIAL.  Rewrite them by substituting
-             ;; REPLACEMENTS.
-             (sources      (map (lambda (source)
-                                  (match (vhash-assoc source mapping)
-                                    ((_ . replacement)
-                                     replacement)
-                                    (#f
-                                     (if (file-is-directory? source)
-                                         source
-                                         (substitute-file source
-                                                          initial replacements)))))
-                                (derivation-sources drv)))
-
-             ;; Now augment the lists of initials and replacements.
-             (initial      (append (derivation-sources drv) initial))
-             (replacements (append sources replacements))
-             (name         (store-path-package-name
-                            (string-drop-right (derivation-file-name drv)
-                                               4))))
-        (derivation store name
-                    (substitute (derivation-builder drv)
-                                initial replacements)
-                    (map (cut substitute <> initial replacements)
-                         (derivation-builder-arguments drv))
-                    #:system system
-                    #:env-vars (map (match-lambda
-                                     ((var . value)
-                                      `(,var
-                                        . ,(substitute value initial
-                                                       replacements))))
-                                    (derivation-builder-environment-vars drv))
-                    #:inputs (filter derivation-input? inputs)
-                    #:sources (append sources (filter string? inputs))
-                    #:outputs (derivation-output-names drv)
-                    #:hash (match (derivation-outputs drv)
-                             ((($ <derivation-output> _ algo hash))
-                              hash)
-                             (_ #f))
-                    #:hash-algo (match (derivation-outputs drv)
-                                  ((($ <derivation-output> _ algo hash))
-                                   algo)
-                                  (_ #f)))))))
+      (let ((cached-drv (hash-ref computed-drvs drv)))
+        (if cached-drv
+            cached-drv
+            (let* ((inputs       (map (cut rewritten-input <> loop)
+                                      (derivation-inputs drv)))
+                   (initial      (append-map derivation-input-output-paths
+                                             (derivation-inputs drv)))
+                   (replacements (append-map input->output-paths inputs))
+
+                   ;; Sources typically refer to the output directories of the
+                   ;; original inputs, INITIAL.  Rewrite them by substituting
+                   ;; REPLACEMENTS.
+                   (sources      (map (lambda (source)
+                                        (match (vhash-assoc source mapping)
+                                          ((_ . replacement)
+                                           replacement)
+                                          (#f
+                                           (if (file-is-directory? source)
+                                               source
+                                               (substitute-file source
+                                                                initial replacements)))))
+                                      (derivation-sources drv)))
+
+                   ;; Now augment the lists of initials and replacements.
+                   (initial      (append (derivation-sources drv) initial))
+                   (replacements (append sources replacements))
+                   (name         (store-path-package-name
+                                  (string-drop-right (derivation-file-name drv)
+                                                     4))))
+
+              (hash-set!
+               computed-drvs
+               drv
+               (derivation store name
+                           (substitute (derivation-builder drv)
+                                       initial replacements)
+                           (map (cut substitute <> initial replacements)
+                                (derivation-builder-arguments drv))
+                           #:system system
+                           #:env-vars (map (match-lambda
+                                             ((var . value)
+                                              `(,var
+                                                . ,(substitute value initial
+                                                               replacements))))
+                                           (derivation-builder-environment-vars drv))
+                           #:inputs (filter derivation-input? inputs)
+                           #:sources (append sources (filter string? inputs))
+                           #:outputs (derivation-output-names drv)
+                           #:hash (match (derivation-outputs drv)
+                                    ((($ <derivation-output> _ algo hash))
+                                     hash)
+                                    (_ #f))
+                           #:hash-algo (match (derivation-outputs drv)
+                                         ((($ <derivation-output> _ algo hash))
+                                          algo)
+                                         (_ #f))))))))))
 
 
 ;;;
-- 
2.48.1