Package: guix;
Reported by: Sergio Pastor Pérez <sergio.pastorperez <at> outlook.es>
Date: Thu, 4 Jul 2024 15:06:02 UTC
Severity: normal
Message #32 received at 71941 <at> debbugs.gnu.org (full text, mbox):
From: Sergio Pastor Pérez <sergio.pastorperez <at> gmail.com> To: 71941 <at> debbugs.gnu.org Cc: Sergio Pastor Pérez <sergio.pastorperez <at> gmail.com> Subject: [PATCH v4 2/3] guix: fix: Slow 'map-derivation' procedure Date: Sat, 1 Mar 2025 19:06:09 +0100
Implement caching to speed up computation through memoization.
Change-Id: I186e2a62f6655e3b0738dd6e0f628faccd8b855e
---
guix/derivations.scm | 103 ++++++++++++++++++++++---------------------
1 file changed, 53 insertions(+), 50 deletions(-)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index d84d1a391c..9b44febdb8 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -1060,56 +1060,59 @@ (define* (map-derivation store drv mapping
(#f
(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)))))))
+ (define loop
+ (mlambdaq (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))))))
+
+ (loop drv)))
;;;
--
2.48.1
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.