[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#46100] [PATCH 0/4] Memoize inferior package access.
From: |
Ludovic Courtès |
Subject: |
[bug#46100] [PATCH 0/4] Memoize inferior package access. |
Date: |
Tue, 26 Jan 2021 11:41:24 +0100 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux) |
Hi!
Thanks for digging into this!
Ricardo Wurmus <rekado@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’.
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
- [bug#46101] [PATCH 1/4] guix: Fix typo., Ricardo Wurmus, 2021/01/25
- [bug#46102] [PATCH 2/4] inferior: Memoize inferior-package->manifest-entry., Ricardo Wurmus, 2021/01/25
- [bug#46100] [PATCH 0/4] Memoize inferior package access.,
Ludovic Courtès <=
- [bug#46100] [PATCH 0/4] Memoize inferior package access., Ludovic Courtès, 2021/01/26
- [bug#46100] [PATCH 0/4] Memoize inferior package access., Ricardo Wurmus, 2021/01/26
- [bug#46100] [PATCH 0/4] Memoize inferior package access., Ludovic Courtès, 2021/01/27
- [bug#46100] [PATCH 0/4] Memoize inferior package access., Ricardo Wurmus, 2021/01/28
- bug#46100: [PATCH 0/4] Memoize inferior package access., Ludovic Courtès, 2021/01/28
[bug#46101] [PATCH 3/4] inferior: Memoize inferior package search path access., Ricardo Wurmus, 2021/01/25
[bug#46101] [PATCH 4/4] inferior: Memoize package input field access., Ricardo Wurmus, 2021/01/25