Package: guix-patches;
Reported by: Ricardo Wurmus <rekado <at> elephly.net>
Date: Mon, 25 Jan 2021 13:35:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
Message #24 received at 46100 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: Ricardo Wurmus <rekado <at> elephly.net> Cc: 46100 <at> debbugs.gnu.org Subject: Re: bug#46100: [PATCH 0/4] Memoize inferior package access. Date: Tue, 26 Jan 2021 11:41:24 +0100
[Message part 1 (text/plain, inline)]
Hi! Thanks for digging into this! Ricardo Wurmus <rekado <at> elephly.net> skribis: > +(define inferior-package->manifest-entry > + (let ((results vlist-null)) > + (lambda* (package #:optional (output "out") > + #:key (parent (delay #f)) > + (properties '())) > + "Return a manifest entry for the OUTPUT of package PACKAGE." > + (or (and=> (vhash-assoc package results) cdr) There’s a catch here: OUTPUT should be taken into account. Also it’s better to use eq?-ness but… I realized ‘inferior-package-inputs’ & co. do not preserve eq?-ness. So I came up with the attached patch, which addresses these two issues. For me the ‘packages->manifest’ phase goes from 13s to 2.5s (19s to 4.6s for the whole script), which is still a lot, but that was without the other patches. Thoughts? Ludo’.
[Message part 2 (text/x-patch, inline)]
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 2fe91beaab..91bbb5aa70 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -109,13 +109,14 @@
;; Inferior Guix process.
(define-record-type <inferior>
- (inferior pid socket close version packages table)
+ (inferior pid socket close version packages id-table table)
inferior?
(pid inferior-pid)
(socket inferior-socket)
(close inferior-close-socket) ;procedure
(version inferior-version) ;REPL protocol version
(packages inferior-package-promise) ;promise of inferior packages
+ (id-table inferior-package-id-table) ;promise of vhash
(table inferior-package-table)) ;promise of vhash
(define* (inferior-pipe directory command error-port)
@@ -160,6 +161,7 @@ inferior."
(('repl-version 0 rest ...)
(letrec ((result (inferior 'pipe pipe close (cons 0 rest)
(delay (%inferior-packages result))
+ (delay (%inferior-package-id-table result))
(delay (%inferior-package-table result)))))
;; For protocol (0 1) and later, send the protocol version we support.
@@ -295,6 +297,18 @@ Raise '&inferior-exception' when an exception is read from PORT."
(inferior-package inferior name version id)))
result)))
+(define (%inferior-package-id-table inferior)
+ (fold (lambda (package table)
+ (vhash-consv (inferior-package-id package) package
+ table))
+ vlist-null
+ (inferior-packages inferior)))
+
+(define (lookup-inferior-package-by-id inferior id)
+ (match (vhash-assv id (force (inferior-package-id-table inferior)))
+ (#f #f)
+ ((_ . package) package)))
+
(define (inferior-packages inferior)
"Return the list of packages known to INFERIOR."
(force (inferior-package-promise inferior)))
@@ -412,8 +426,10 @@ inferior package."
(map (match-lambda
((label ('package id name version) . rest)
- ;; XXX: eq?-ness of inferior packages is not preserved here.
- `(,label ,(inferior-package inferior name version id)
+ ;; XXX: eq?-ness of inferior packages is preserved, unless the
+ ;; package is not public.
+ `(,label ,(or (lookup-inferior-package-by-id inferior id)
+ (inferior-package inferior name version id))
,@rest))
(x x))
inputs))
@@ -642,29 +658,50 @@ failing when GUIX is too old and lacks the 'guix repl' command."
(define* (inferior-package->manifest-entry package
#:optional (output "out")
- #:key (parent (delay #f))
- (properties '()))
+ #:key (properties '()))
"Return a manifest entry for the OUTPUT of package PACKAGE."
;; For each dependency, keep a promise pointing to its "parent" entry.
- (letrec* ((deps (map (match-lambda
- ((label package)
- (inferior-package->manifest-entry package
- #:parent (delay entry)))
- ((label package output)
- (inferior-package->manifest-entry package output
- #:parent (delay entry))))
- (inferior-package-propagated-inputs package)))
- (entry (manifest-entry
- (name (inferior-package-name package))
- (version (inferior-package-version package))
- (output output)
- (item package)
- (dependencies (delete-duplicates deps))
- (search-paths
- (inferior-package-transitive-native-search-paths package))
- (parent parent)
- (properties properties))))
- entry))
+ (define cache
+ (make-hash-table))
+
+ (define-syntax-rule (memoized package output exp)
+ (let ((compute (lambda () exp)))
+ (match (hashq-ref cache package)
+ (#f
+ (let ((result (compute)))
+ (hashq-set! cache package `((,output . ,result)))
+ result))
+ (alist
+ (match (assoc-ref alist output)
+ (#f
+ (let ((result (compute)))
+ (hashq-set! cache package
+ `((, output . ,result) ,@alist))
+ result))
+ (result
+ result))))))
+
+ (let loop ((package package)
+ (output output)
+ (parent (delay #f)))
+ (memoized package output
+ (letrec* ((deps (map (match-lambda
+ ((label package)
+ (loop package "out" (delay entry)))
+ ((label package output)
+ (loop package output (delay entry))))
+ (inferior-package-propagated-inputs package)))
+ (entry (manifest-entry
+ (name (inferior-package-name package))
+ (version (inferior-package-version package))
+ (output output)
+ (item package)
+ (dependencies (delete-duplicates deps))
+ (search-paths
+ (inferior-package-transitive-native-search-paths package))
+ (parent parent)
+ (properties properties))))
+ entry))))
;;;
@@ -750,3 +787,7 @@ This is a convenience procedure that people may use in manifests passed to
#:cache-directory cache-directory
#:ttl ttl)))
(open-inferior cached))
+
+;;; Local Variables:
+;;; eval: (put 'memoized 'scheme-indent-function 1)
+;;; End:
diff --git a/tests/inferior.scm b/tests/inferior.scm
index 7c3d730d0c..ddfae8236d 100644
--- a/tests/inferior.scm
+++ b/tests/inferior.scm
@@ -195,6 +195,25 @@
(close-inferior inferior)
result))
+(test-assert "inferior-package-inputs & pointer identity"
+ (let* ((inferior (open-inferior %top-builddir
+ #:command "scripts/guix"))
+ (lookup (lambda (name)
+ (first (lookup-inferior-packages inferior name))))
+ (guile-gcrypt (lookup "guile-gcrypt"))
+ (libgcrypt (lookup "libgcrypt"))
+ (pkg-config (lookup "pkg-config")))
+ (define (input name)
+ (match (assoc name (inferior-package-inputs guile-gcrypt))
+ ((label package . _) package)))
+
+ (and (eq? libgcrypt
+ (car (assoc-ref (inferior-package-inputs guile-gcrypt)
+ "libgcrypt")))
+ (eq? pkg-config
+ (car (assoc-ref (inferior-package-native-inputs guile-gcrypt)
+ "pkg-config"))))))
+
(test-equal "inferior-package-search-paths"
(package-native-search-paths guile-3.0)
(let* ((inferior (open-inferior %top-builddir
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.