Package: guix;
Reported by: Sergio Pastor Pérez <sergio.pastorperez <at> outlook.es>
Date: Thu, 4 Jul 2024 15:06:02 UTC
Severity: normal
View this message in rfc822 format
From: Sergio Pastor Pérez <sergio.pastorperez <at> gmail.com> To: 71941 <at> debbugs.gnu.org Cc: ludo <at> gnu.org, Sergio Pastor Pérez <sergio.pastorperez <at> gmail.com>, Sergio Pastor Pérez <sergio.pastorperez <at> outlook.es>, Christopher Baines <guix <at> cbaines.net>, Josselin Poiret <dev <at> jpoiret.xyz>, Ludovic Courtès <ludo <at> gnu.org>, Mathieu Othacehe <othacehe <at> gnu.org>, Simon Tournier <zimon.toutoune <at> gmail.com>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: bug#71941: [PATCH v2 2/2] guix: fix: slow `map-derivation' procedure 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.