[bug#46100] [PATCH 0/4] Memoize inferior package access.

[Ludovic Courtès]

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