[bug#68266] [PATCH 0/7] Memoize packages associated with cross building.

[bug#68266] [PATCH 0/7] Memoize packages associated with cross building.

[Christopher Baines]

[-- Attachment #1: Type: text/plain, Size: 709 bytes --]

This comes from dumping the contents of the store connection object
cache after computing derivations targeting i586-pc-gnu, and looking at
what packages appear multiple times as cache keys.

Christopher Baines (7):
  gnu: Memozise make-ld-wrapper results.
  gnu: Memozise cross-binutils results.
  gnu: Memozise cross-gcc results.
  gnu: Memozise cross-kernel-headers results.
  gnu: Memozise cross-mig results.
  gnu: Memozise cross-libc results.
  packages: rust: Memoize make-rust-sysroot results.

 gnu/packages/base.scm       | 126 +++---
 gnu/packages/cross-base.scm | 804 +++++++++++++++++++-----------------
 gnu/packages/rust.scm       |   6 +-
 3 files changed, 486 insertions(+), 450 deletions(-)

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 987 bytes --]

[bug#68266] [PATCH 1/7] gnu: Memozise make-ld-wrapper results.

[Christopher Baines]

To ensure that it just returns a single package record for some given
arguments, as this helps to avoid poor performance of the store connection
object cache.

* gnu/packages/base.scm (make-ld-wrapper): Move code to
make-ld-wrapper/implementation and call it.
(make-ld-wrapper/implementation) New procedure.

Change-Id: Id6fc805a4a7ffbc5ff0a5174eafcdf2c7c46854d
---
 gnu/packages/base.scm | 126 ++++++++++++++++++++++--------------------
 1 file changed, 66 insertions(+), 60 deletions(-)

diff --git a/gnu/packages/base.scm b/gnu/packages/base.scm
index 8b25af6a5e..929bf9f422 100644
--- a/gnu/packages/base.scm
+++ b/gnu/packages/base.scm
@@ -66,6 +66,7 @@ (define-module (gnu packages base)
   #:use-module (guix gexp)
   #:use-module (guix packages)
   #:use-module (guix download)
+  #:use-module (guix memoization)
   #:use-module (guix git-download)
   #:use-module (guix build-system gnu)
   #:use-module (guix build-system trivial)
@@ -715,68 +716,73 @@ (define* (make-ld-wrapper name #:key
 wrapper for the cross-linker for that target, called 'TARGET-ld'.  To use a
 different linker than the default \"ld\", such as \"ld.gold\" the linker name
 can be provided via the LINKER argument."
-  ;; Note: #:system->target-triplet is a procedure so that the evaluation of
-  ;; its result can be delayed until the 'arguments' field is evaluated, thus
-  ;; in a context where '%current-system' is accurate.
-  (package
-    (name name)
-    (version "0")
-    (source #f)
-    (build-system trivial-build-system)
-    (inputs `(("binutils" ,binutils)
-              ("guile"    ,guile)
-              ("bash"     ,bash)
-              ("wrapper"  ,(search-path %load-path
-                                        "gnu/packages/ld-wrapper.in"))))
-    (arguments
-     (let ((target (target (%current-system))))
-       `(#:guile ,guile-for-build
-         #:modules ((guix build utils))
-         #:builder (begin
-                     (use-modules (guix build utils)
-                                  (system base compile))
-
-                     (let* ((out (assoc-ref %outputs "out"))
-                            (bin (string-append out "/bin"))
-                            (ld  ,(if target
-                                      `(string-append bin "/" ,target "-"
-                                                      ,linker)
-                                      `(string-append bin "/" ,linker)))
-                            (go  (string-append ld ".go")))
-
-                       (setvbuf (current-output-port)
-                                (cond-expand (guile-2.0 _IOLBF)
-                                             (else 'line)))
-                       (format #t "building ~s/bin/ld wrapper in ~s~%"
-                               (assoc-ref %build-inputs "binutils")
-                               out)
-
-                       (mkdir-p bin)
-                       (copy-file (assoc-ref %build-inputs "wrapper") ld)
-                       (substitute* ld
-                         (("@SELF@")
-                          ld)
-                         (("@GUILE@")
-                          (string-append (assoc-ref %build-inputs "guile")
-                                         "/bin/guile"))
-                         (("@BASH@")
-                          (string-append (assoc-ref %build-inputs "bash")
-                                         "/bin/bash"))
-                         (("@LD@")
-                          (string-append (assoc-ref %build-inputs "binutils")
-                                         ,(if target
-                                              (string-append "/bin/"
-                                                             target "-" linker)
-                                              (string-append "/bin/" linker)))))
-                       (chmod ld #o555)
-                       (compile-file ld #:output-file go))))))
-    (synopsis "The linker wrapper")
-    (description
-     "The linker wrapper (or @code{ld-wrapper}) wraps the linker to add any
+  (make-ld-wrapper/implementation name target binutils linker
+                                  guile bash guile-for-build))
+
+(define make-ld-wrapper/implementation
+  (mlambda (name target binutils linker guile bash guile-for-build)
+    ;; Note: #:system->target-triplet is a procedure so that the evaluation of
+    ;; its result can be delayed until the 'arguments' field is evaluated,
+    ;; thus in a context where '%current-system' is accurate.
+    (package
+      (name name)
+      (version "0")
+      (source #f)
+      (build-system trivial-build-system)
+      (inputs `(("binutils" ,binutils)
+                ("guile"    ,guile)
+                ("bash"     ,bash)
+                ("wrapper"  ,(search-path %load-path
+                                          "gnu/packages/ld-wrapper.in"))))
+      (arguments
+       (let ((target (target (%current-system))))
+         `(#:guile ,guile-for-build
+           #:modules ((guix build utils))
+           #:builder (begin
+                       (use-modules (guix build utils)
+                                    (system base compile))
+
+                       (let* ((out (assoc-ref %outputs "out"))
+                              (bin (string-append out "/bin"))
+                              (ld  ,(if target
+                                        `(string-append bin "/" ,target "-"
+                                                        ,linker)
+                                        `(string-append bin "/" ,linker)))
+                              (go  (string-append ld ".go")))
+
+                         (setvbuf (current-output-port)
+                                  (cond-expand (guile-2.0 _IOLBF)
+                                               (else 'line)))
+                         (format #t "building ~s/bin/ld wrapper in ~s~%"
+                                 (assoc-ref %build-inputs "binutils")
+                                 out)
+
+                         (mkdir-p bin)
+                         (copy-file (assoc-ref %build-inputs "wrapper") ld)
+                         (substitute* ld
+                           (("@SELF@")
+                            ld)
+                           (("@GUILE@")
+                            (string-append (assoc-ref %build-inputs "guile")
+                                           "/bin/guile"))
+                           (("@BASH@")
+                            (string-append (assoc-ref %build-inputs "bash")
+                                           "/bin/bash"))
+                           (("@LD@")
+                            (string-append (assoc-ref %build-inputs "binutils")
+                                           ,(if target
+                                                (string-append "/bin/"
+                                                               target "-" linker)
+                                                (string-append "/bin/" linker)))))
+                         (chmod ld #o555)
+                         (compile-file ld #:output-file go))))))
+      (synopsis "The linker wrapper")
+      (description
+       "The linker wrapper (or @code{ld-wrapper}) wraps the linker to add any
 missing @code{-rpath} flags, and to detect any misuse of libraries outside of
 the store.")
-    (home-page "https://www.gnu.org/software/guix//")
-    (license gpl3+)))
+      (home-page "https://www.gnu.org/software/guix//")
+      (license gpl3+))))
 
 (define-public %glibc/hurd-configure-flags
   ;; 'configure' in glibc 2.35 omits to pass '-ffreestanding' when detecting

base-commit: 5279bd453f354cbbaafff44e46c6fa03a39bc10a
-- 
2.41.0

[bug#68266] [PATCH 2/7] gnu: Memozise cross-binutils results.

[Christopher Baines]

To ensure that it just returns a single package record for some given
arguments, as this helps to avoid poor performance of the store connection
object cache.

* gnu/packages/cross-base.scm (cross-binutils*): Move code to
cross-binutils/implementation and call it.
(cross-binutils/implementation) New procedure.
(cross-binutils/deprecated): Call cross-binutils/implementation.

Change-Id: Ic7a493177026c7a699108ab6d75482ff3c189340
---
 gnu/packages/cross-base.scm | 92 +++++++++++++++++++------------------
 1 file changed, 48 insertions(+), 44 deletions(-)

diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm
index 6ee7b315d8..a04e4f9c9e 100644
--- a/gnu/packages/cross-base.scm
+++ b/gnu/packages/cross-base.scm
@@ -89,56 +89,60 @@ (define (contains-keyword? args)
   (find keyword? args))
 
 (define* (cross-binutils . args)
+  "Return a cross-Binutils for TARGET using BINUTILS."
   (if (or (= (length args) 1) (contains-keyword? args))
       (apply cross-binutils* args)
       (apply cross-binutils/deprecated args)))
 
+(define* (cross-binutils* target #:key (binutils binutils))
+  (cross-binutils/implementation target binutils))
+
 (define* (cross-binutils/deprecated target #:optional (binutils binutils))
   (warning (G_ "'cross-binutils' must be used with keyword arguments~%"))
-  (cross-binutils* target #:binutils binutils))
-
-(define* (cross-binutils* target #:key (binutils binutils))
-  "Return a cross-Binutils for TARGET using BINUTILS."
-  (let ((binutils (package
-                    (inherit binutils)
-                    (arguments
-                     (substitute-keyword-arguments (package-arguments
-                                                    binutils)
-                       ((#:configure-flags flags)
-                        ;; Build with `--with-sysroot' so that ld honors
-                        ;; DT_RUNPATH entries when searching for a needed
-                        ;; library.  This works because as a side effect
-                        ;; `genscripts.sh' sets `USE_LIBPATH=yes', which tells
-                        ;; elf32.em to use DT_RUNPATH in its search list.
-                        ;; See <http://sourceware.org/ml/binutils/2013-05/msg00312.html>.
-                        ;;
-                        ;; In theory choosing / as the sysroot could lead ld
-                        ;; to pick up native libs instead of target ones.  In
-                        ;; practice the RUNPATH of target libs only refers to
-                        ;; target libs, not native libs, so this is safe.
-                        `(cons "--with-sysroot=/" ,flags)))))))
-
-    ;; For Xtensa, apply Qualcomm's patch.
-    (cross (cond ((string-prefix? "xtensa-" target)
-                  (package-with-patches binutils
-                                        (search-patches
-                                         "ath9k-htc-firmware-binutils.patch")))
-                 ((target-mingw? target)
-                  (package-with-extra-patches
-                   (package-with-extra-configure-variable
-                    ;; mingw binutils does not work correctly when configured
-                    ;; with `--enable-compressed-debug-sections`. An error
-                    ;; like the following will occur whenever you try to link:
-                    ;;
-                    ;;   x86_64-w64-mingw32-ld: final link failed: bad value
-                    ;;
-                    ;; TODO: This seems like a deeper problem that warrants
-                    ;; deeper investigation.
-                    binutils "--enable-compressed-debug-sections" "no")
-                   (search-patches "binutils-mingw-w64-timestamp.patch"
-                                   "binutils-mingw-w64-deterministic.patch")))
-                 (else binutils))
-           target)))
+  (cross-binutils/implementation target binutils))
+
+(define cross-binutils/implementation
+  (mlambda (target binutils)
+    (let ((binutils (package
+                      (inherit binutils)
+                      (arguments
+                       (substitute-keyword-arguments (package-arguments
+                                                      binutils)
+                         ((#:configure-flags flags)
+                          ;; Build with `--with-sysroot' so that ld honors
+                          ;; DT_RUNPATH entries when searching for a needed
+                          ;; library.  This works because as a side effect
+                          ;; `genscripts.sh' sets `USE_LIBPATH=yes', which tells
+                          ;; elf32.em to use DT_RUNPATH in its search list.
+                          ;; See <http://sourceware.org/ml/binutils/2013-05/msg00312.html>.
+                          ;;
+                          ;; In theory choosing / as the sysroot could lead ld
+                          ;; to pick up native libs instead of target ones.  In
+                          ;; practice the RUNPATH of target libs only refers to
+                          ;; target libs, not native libs, so this is safe.
+                          `(cons "--with-sysroot=/" ,flags)))))))
+
+      ;; For Xtensa, apply Qualcomm's patch.
+      (cross (cond ((string-prefix? "xtensa-" target)
+                    (package-with-patches binutils
+                                          (search-patches
+                                           "ath9k-htc-firmware-binutils.patch")))
+                   ((target-mingw? target)
+                    (package-with-extra-patches
+                     (package-with-extra-configure-variable
+                      ;; mingw binutils does not work correctly when configured
+                      ;; with `--enable-compressed-debug-sections`. An error
+                      ;; like the following will occur whenever you try to link:
+                      ;;
+                      ;;   x86_64-w64-mingw32-ld: final link failed: bad value
+                      ;;
+                      ;; TODO: This seems like a deeper problem that warrants
+                      ;; deeper investigation.
+                      binutils "--enable-compressed-debug-sections" "no")
+                     (search-patches "binutils-mingw-w64-timestamp.patch"
+                                     "binutils-mingw-w64-deterministic.patch")))
+                   (else binutils))
+             target))))
 
 (define (cross-gcc-arguments target xgcc libc)
   "Return build system arguments for a cross-gcc for TARGET, using XGCC as the
-- 
2.41.0

[bug#68266] [PATCH 3/7] gnu: Memozise cross-gcc results.

[Christopher Baines]

To ensure that it just returns a single package record for some given
arguments, as this helps to avoid poor performance of the store connection
object cache.

* gnu/packages/cross-base.scm (cross-gcc): Move code to
cross-gcc/implementation and call it.
(cross-gcc/implementation) New procedure.

Change-Id: Ibeafaa4d652fc1d6fd27870b82a309c177b66a05
---
 gnu/packages/cross-base.scm | 183 +++++++++++++++++++-----------------
 1 file changed, 95 insertions(+), 88 deletions(-)

diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm
index a04e4f9c9e..a4e361b476 100644
--- a/gnu/packages/cross-base.scm
+++ b/gnu/packages/cross-base.scm
@@ -301,6 +301,97 @@ (define (cross-gcc-search-paths target)
                              ,(string-append target "/include")))))))
              %gcc-cross-include-paths)))
 
+(define cross-gcc/implementation
+  (mlambda (target xgcc xbinutils libc)
+    (package
+      (inherit xgcc)
+      (name (string-append "gcc-cross-"
+                           (if libc "" "sans-libc-")
+                           target))
+      (source
+       (origin
+         (inherit
+          (package-source xgcc))
+         (patches
+          (append
+           (origin-patches (package-source xgcc))
+           (append (cond
+                    ((version>=? (package-version xgcc) "12.0")
+                     (search-patches "gcc-12-cross-environment-variables.patch"
+                                     "gcc-cross-gxx-include-dir.patch"))
+                    ((version>=? (package-version xgcc) "10.0")
+                     (search-patches "gcc-10-cross-environment-variables.patch"
+                                     "gcc-cross-gxx-include-dir.patch"))
+                    ((version>=? (package-version xgcc) "8.0")
+                     (search-patches "gcc-8-cross-environment-variables.patch"))
+                    ((version>=? (package-version xgcc) "6.0")
+                     (search-patches "gcc-7-cross-toolexeclibdir.patch"
+                                     "gcc-6-cross-environment-variables.patch"))
+                    (else
+                     (search-patches "gcc-cross-environment-variables.patch")))
+                   (cross-gcc-patches xgcc target))))
+         (modules '((guix build utils)))
+         (snippet
+          (cross-gcc-snippet target))))
+
+      (outputs '("out" "lib"))
+
+      (arguments
+       `(#:implicit-inputs? #f
+         #:imported-modules ((gnu build cross-toolchain)
+                             ,@%gnu-build-system-modules)
+         #:modules ((guix build gnu-build-system)
+                    (guix build utils)
+                    (gnu build cross-toolchain)
+                    (srfi srfi-1)
+                    (srfi srfi-26)
+                    (ice-9 regex))
+
+         ,@(cross-gcc-arguments target xgcc libc)))
+
+      (native-inputs
+       `(("ld-wrapper-cross" ,(make-ld-wrapper
+                               (string-append "ld-wrapper-" target)
+                               #:target (const target)
+                               #:binutils xbinutils))
+         ("binutils-cross" ,xbinutils)
+
+         ,@(let ((inputs (append (package-inputs xgcc)
+                                 (fold alist-delete (%final-inputs)
+                                       '("libc" "libc:static"))
+
+                                 ;; Call it differently so that the builder can
+                                 ;; check whether the "libc" input is #f.
+                                 `(("libc-native"
+                                    ,@(assoc-ref (%final-inputs) "libc"))
+                                   ("libc-native:static"
+                                    ,@(assoc-ref (%final-inputs)
+                                                 "libc:static"))))))
+             (cond
+              ((target-mingw? target)
+               (if libc
+                   `(,@inputs
+                     ("libc" ,libc))
+                   `(,@inputs
+                     ("mingw-source" ,(package-source mingw-w64)))))
+              ((and libc (target-avr? target))
+               `(,@inputs
+                 ("libc" ,libc)))
+              (libc
+               `(,@inputs
+                 ("libc" ,libc)
+                 ("libc:static" ,libc "static")
+                 ("xkernel-headers"       ;the target headers
+                  ,@(assoc-ref (package-propagated-inputs libc)
+                               "kernel-headers"))))
+              (else inputs)))))
+
+      (inputs '())
+
+      ;; Only search target inputs, not host inputs.
+      (search-paths (cross-gcc-search-paths target))
+      (native-search-paths '()))))
+
 (define* (cross-gcc target
                     #:key
                     (xgcc %xgcc)
@@ -310,94 +401,10 @@ (define* (cross-gcc target
 XGCC as the base compiler.  Use XBINUTILS as the associated cross-Binutils.
 If LIBC is false, then build a GCC that does not target a libc; otherwise,
 target that libc."
-  (package
-    (inherit xgcc)
-    (name (string-append "gcc-cross-"
-                         (if libc "" "sans-libc-")
-                         target))
-    (source
-     (origin
-       (inherit
-        (package-source xgcc))
-       (patches
-        (append
-         (origin-patches (package-source xgcc))
-         (append (cond
-                  ((version>=? (package-version xgcc) "12.0")
-                   (search-patches "gcc-12-cross-environment-variables.patch"
-                                   "gcc-cross-gxx-include-dir.patch"))
-                  ((version>=? (package-version xgcc) "10.0")
-                   (search-patches "gcc-10-cross-environment-variables.patch"
-                                   "gcc-cross-gxx-include-dir.patch"))
-                  ((version>=? (package-version xgcc) "8.0")
-                   (search-patches "gcc-8-cross-environment-variables.patch"))
-                  ((version>=? (package-version xgcc) "6.0")
-                   (search-patches "gcc-7-cross-toolexeclibdir.patch"
-                                   "gcc-6-cross-environment-variables.patch"))
-                  (else
-                   (search-patches "gcc-cross-environment-variables.patch")))
-                 (cross-gcc-patches xgcc target))))
-       (modules '((guix build utils)))
-       (snippet
-        (cross-gcc-snippet target))))
-
-    (outputs '("out" "lib"))
-
-    (arguments
-     `(#:implicit-inputs? #f
-       #:imported-modules ((gnu build cross-toolchain)
-                           ,@%gnu-build-system-modules)
-       #:modules ((guix build gnu-build-system)
-                  (guix build utils)
-                  (gnu build cross-toolchain)
-                  (srfi srfi-1)
-                  (srfi srfi-26)
-                  (ice-9 regex))
-
-       ,@(cross-gcc-arguments target xgcc libc)))
-
-    (native-inputs
-     `(("ld-wrapper-cross" ,(make-ld-wrapper
-                             (string-append "ld-wrapper-" target)
-                             #:target (const target)
-                             #:binutils xbinutils))
-       ("binutils-cross" ,xbinutils)
-
-       ,@(let ((inputs (append (package-inputs xgcc)
-                               (fold alist-delete (%final-inputs)
-                                     '("libc" "libc:static"))
-
-                               ;; Call it differently so that the builder can
-                               ;; check whether the "libc" input is #f.
-                               `(("libc-native"
-                                  ,@(assoc-ref (%final-inputs) "libc"))
-                                 ("libc-native:static"
-                                  ,@(assoc-ref (%final-inputs)
-                                               "libc:static"))))))
-           (cond
-            ((target-mingw? target)
-             (if libc
-                 `(,@inputs
-                   ("libc" ,libc))
-                 `(,@inputs
-                   ("mingw-source" ,(package-source mingw-w64)))))
-            ((and libc (target-avr? target))
-             `(,@inputs
-               ("libc" ,libc)))
-            (libc
-             `(,@inputs
-               ("libc" ,libc)
-               ("libc:static" ,libc "static")
-               ("xkernel-headers"       ;the target headers
-                ,@(assoc-ref (package-propagated-inputs libc)
-                             "kernel-headers"))))
-            (else inputs)))))
-
-    (inputs '())
-
-    ;; Only search target inputs, not host inputs.
-    (search-paths (cross-gcc-search-paths target))
-    (native-search-paths '())))
+  (cross-gcc/implementation target
+                            xgcc
+                            xbinutils
+                            libc))
 
 (define* (cross-kernel-headers . args)
   (if (or (= (length args) 1) (contains-keyword? args))
-- 
2.41.0

[bug#68266] [PATCH 4/7] gnu: Memozise cross-kernel-headers results.

[Christopher Baines]

To ensure that it just returns a single package record for some given
arguments, as this helps to avoid poor performance of the store connection
object cache.

* gnu/packages/cross-base.scm (cross-kernel-headers*): Move code to
cross-kernel-headers/implementation and call it.
(cross-kernel-headers/implementation) New procedure.

Change-Id: I345604c089e7a8a9884c07f39c95f960760e86db
---
 gnu/packages/cross-base.scm | 306 ++++++++++++++++++------------------
 1 file changed, 157 insertions(+), 149 deletions(-)

diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm
index a4e361b476..f966e2f5ac 100644
--- a/gnu/packages/cross-base.scm
+++ b/gnu/packages/cross-base.scm
@@ -407,10 +407,19 @@ (define* (cross-gcc target
                             libc))
 
 (define* (cross-kernel-headers . args)
+  "Return headers depending on TARGET."
   (if (or (= (length args) 1) (contains-keyword? args))
       (apply cross-kernel-headers* args)
       (apply cross-kernel-headers/deprecated args)))
 
+(define* (cross-kernel-headers* target
+                                #:key
+                                (linux-headers linux-libre-headers)
+                                (xgcc (cross-gcc target))
+                                (xbinutils (cross-binutils target)))
+  (cross-kernel-headers/implementation target
+                                       linux-headers xgcc xbinutils))
+
 (define* (cross-kernel-headers/deprecated target
                                           #:optional
                                           (linux-headers linux-libre-headers)
@@ -486,159 +495,158 @@ (define* (cross-mig target
      (modify-inputs (package-native-inputs mig)
        (prepend xgcc xbinutils)))))
 
-(define* (cross-kernel-headers* target
-                                #:key
-                                (linux-headers linux-libre-headers)
-                                (xgcc (cross-gcc target))
-                                (xbinutils (cross-binutils target)))
-  "Return headers depending on TARGET."
-
-  (define xlinux-headers
     (package
-      (inherit linux-headers)
-      (name (string-append (package-name linux-headers)
-                           "-cross-" target))
       (arguments
-       (substitute-keyword-arguments
-           `(#:implicit-cross-inputs? #f
-             ,@(package-arguments linux-headers))
-         ((#:phases phases)
-          `(modify-phases ,phases
-             (replace 'build
-               (lambda _
-                 (setenv "ARCH" ,(platform-linux-architecture
-                                  (lookup-platform-by-target target)))
-                 (format #t "`ARCH' set to `~a' (cross compiling)~%"
-                         (getenv "ARCH"))
-
-                 (invoke "make" ,(system->defconfig target))
-                 (invoke "make" "mrproper"
-                         ,@(if (version>=? (package-version linux-headers) "5.3")
-                               '("headers")
-                               '("headers_check")))))))))
-      (native-inputs `(("cross-gcc" ,xgcc)
-                       ("cross-binutils" ,xbinutils)
-                       ,@(package-native-inputs linux-headers)))))
-
-  (define xmig
-    (cross-mig target #:xgcc xgcc #:xbinutils xbinutils))
-
-  (define xgnumach-headers
-    (cross-gnumach-headers target #:xgcc xgcc #:xbinutils xbinutils))
-
-  (define xhurd-headers
-    (package
-      (inherit hurd-headers)
-      (name (string-append (package-name hurd-headers)
-                           "-cross-" target))
-
-      (arguments
-       (substitute-keyword-arguments (package-arguments hurd-headers)
-         ((#:configure-flags flags)
-          `(cons* ,(string-append "--build=" (%current-system))
-                  ,(string-append "--host=" target)
-                  ,flags))))
-
-      (native-inputs `(("cross-gcc" ,xgcc)
-                       ("cross-binutils" ,xbinutils)
-                       ("cross-mig" ,xmig)
-                       ,@(alist-delete "mig" (package-native-inputs hurd-headers))))))
-
-  (define xglibc/hurd-headers
-    (package
-      (inherit glibc/hurd-headers)
-      (name (string-append (package-name glibc/hurd-headers)
-                           "-cross-" target))
-
-      (arguments
-       (substitute-keyword-arguments
-           `(#:modules ((guix build gnu-build-system)
-                        (guix build utils)
-                        (srfi srfi-26))
-             ,@(package-arguments glibc/hurd-headers))
-         ((#:phases phases)
-          `(modify-phases ,phases
-             (add-after 'unpack 'set-cross-headers-path
-               (lambda* (#:key inputs #:allow-other-keys)
-                 (let* ((mach (assoc-ref inputs "gnumach-headers"))
-                        (hurd (assoc-ref inputs "hurd-headers"))
-                        (cpath (string-append mach "/include:"
-                                              hurd "/include")))
-                   (for-each (cut setenv <> cpath)
-                             ',%gcc-cross-include-paths)
-                   #t)))))
-         ((#:configure-flags flags)
-          `(cons* ,(string-append "--build=" (%current-system))
-                  ,(string-append "--host=" target)
-                  ,flags))))
-
-      (propagated-inputs `(("gnumach-headers" ,xgnumach-headers)
-                           ("hurd-headers" ,xhurd-headers)))
-
-      (native-inputs `(("cross-gcc" ,xgcc)
-                       ("cross-binutils" ,xbinutils)
-                       ("cross-mig" ,xmig)
-                       ,@(alist-delete "mig"(package-native-inputs glibc/hurd-headers))))))
-
-  (define xhurd-minimal
-    (package
-      (inherit hurd-minimal)
-      (name (string-append (package-name hurd-minimal)
-                           "-cross-" target))
-      (arguments
-       (substitute-keyword-arguments
-           `(#:modules ((guix build gnu-build-system)
-                        (guix build utils)
-                        (srfi srfi-26))
-             ,@(package-arguments hurd-minimal))
-         ((#:configure-flags flags)
-          `(cons* ,(string-append "--build=" (%current-system))
-                  ,(string-append "--host=" target)
-                  ,flags))
-         ((#:phases phases)
           #~(modify-phases #$phases
-              (add-after 'unpack 'delete-shared-target
-                ;; Cannot create shared libraries due to missing crt1.o
-                (lambda _
-                  (substitute* "Makeconf"
-                    (("(targets := \\$\\(libname\\)\\.a) \\$\\(libname\\)\\.so" all static)
-                     static)
-                    (("\\$\\(DESTDIR\\)\\$\\(libdir\\)/\\$\\(libname\\)\\.so\\.\\$\\(hurd-version\\)")
-                     "")
-                    (("^libs: .*\\.so\\..*" all)
-                     (string-append "# " all)))))
-             (add-before 'configure 'set-cross-headers-path
-               (lambda* (#:key inputs #:allow-other-keys)
-                 (let* ((glibc-headers (assoc-ref inputs "cross-glibc-hurd-headers"))
-                        (mach-headers (assoc-ref inputs "cross-gnumach-headers"))
-                        (cpath (string-append glibc-headers "/include"
-                                              ":" mach-headers "/include")))
-                   (for-each (cut setenv <> cpath)
-                             '#$%gcc-cross-include-paths)
-                   #t)))))))
-
-      (inputs `(("cross-glibc-hurd-headers" ,xglibc/hurd-headers)
-                ("cross-gnumach-headers" ,xgnumach-headers)))
 
-      (native-inputs `(("cross-gcc" ,xgcc)
-                       ("cross-binutils" ,xbinutils)
-                       ("cross-mig" ,xmig)
-                       ,@(alist-delete "mig"
-                                       (package-native-inputs hurd-minimal))))))
-
-  (define xhurd-core-headers
-    (package
-      (inherit hurd-core-headers)
-      (name (string-append (package-name hurd-core-headers)
-                           "-cross-" target))
-
-      (inputs `(("gnumach-headers" ,xgnumach-headers)
-                ("hurd-headers" ,xhurd-headers)
-                ("hurd-minimal" ,xhurd-minimal)))))
-
-  (match target
-    ((or "i586-pc-gnu" "i586-gnu") xhurd-core-headers)
-    (_ xlinux-headers)))
+(define cross-kernel-headers/implementation
+  (mlambda (target linux-headers xgcc xbinutils)
+    (define xlinux-headers
+      (package
+        (inherit linux-headers)
+        (name (string-append (package-name linux-headers)
+                             "-cross-" target))
+        (arguments
+         (substitute-keyword-arguments
+             `(#:implicit-cross-inputs? #f
+               ,@(package-arguments linux-headers))
+           ((#:phases phases)
+            `(modify-phases ,phases
+               (replace 'build
+                 (lambda _
+                   (setenv "ARCH" ,(platform-linux-architecture
+                                    (lookup-platform-by-target target)))
+                   (format #t "`ARCH' set to `~a' (cross compiling)~%"
+                           (getenv "ARCH"))
+
+                   (invoke "make" ,(system->defconfig target))
+                   (invoke "make" "mrproper"
+                           ,@(if (version>=? (package-version linux-headers) "5.3")
+                                 '("headers")
+                                 '("headers_check")))))))))
+        (native-inputs `(("cross-gcc" ,xgcc)
+                         ("cross-binutils" ,xbinutils)
+                         ,@(package-native-inputs linux-headers)))))
+
+    (define xmig
+      (cross-mig target #:xgcc xgcc #:xbinutils xbinutils))
+
+    (define xgnumach-headers
+      (cross-gnumach-headers target #:xgcc xgcc #:xbinutils xbinutils))
+
+    (define xhurd-headers
+      (package
+        (inherit hurd-headers)
+        (name (string-append (package-name hurd-headers)
+                             "-cross-" target))
+
+        (arguments
+         (substitute-keyword-arguments (package-arguments hurd-headers)
+           ((#:configure-flags flags)
+            `(cons* ,(string-append "--build=" (%current-system))
+                    ,(string-append "--host=" target)
+                    ,flags))))
+
+        (native-inputs `(("cross-gcc" ,xgcc)
+                         ("cross-binutils" ,xbinutils)
+                         ("cross-mig" ,xmig)
+                         ,@(alist-delete "mig" (package-native-inputs hurd-headers))))))
+
+    (define xglibc/hurd-headers
+      (package
+        (inherit glibc/hurd-headers)
+        (name (string-append (package-name glibc/hurd-headers)
+                             "-cross-" target))
+
+        (arguments
+         (substitute-keyword-arguments
+             `(#:modules ((guix build gnu-build-system)
+                          (guix build utils)
+                          (srfi srfi-26))
+               ,@(package-arguments glibc/hurd-headers))
+           ((#:phases phases)
+            `(modify-phases ,phases
+               (add-after 'unpack 'set-cross-headers-path
+                 (lambda* (#:key inputs #:allow-other-keys)
+                   (let* ((mach (assoc-ref inputs "gnumach-headers"))
+                          (hurd (assoc-ref inputs "hurd-headers"))
+                          (cpath (string-append mach "/include:"
+                                                hurd "/include")))
+                     (for-each (cut setenv <> cpath)
+                               ',%gcc-cross-include-paths)
+                     #t)))))
+           ((#:configure-flags flags)
+            `(cons* ,(string-append "--build=" (%current-system))
+                    ,(string-append "--host=" target)
+                    ,flags))))
+
+        (propagated-inputs `(("gnumach-headers" ,xgnumach-headers)
+                             ("hurd-headers" ,xhurd-headers)))
+
+        (native-inputs `(("cross-gcc" ,xgcc)
+                         ("cross-binutils" ,xbinutils)
+                         ("cross-mig" ,xmig)
+                         ,@(alist-delete "mig"(package-native-inputs glibc/hurd-headers))))))
+
+    (define xhurd-minimal
+      (package
+        (inherit hurd-minimal)
+        (name (string-append (package-name hurd-minimal)
+                             "-cross-" target))
+        (arguments
+         (substitute-keyword-arguments
+             `(#:modules ((guix build gnu-build-system)
+                          (guix build utils)
+                          (srfi srfi-26))
+               ,@(package-arguments hurd-minimal))
+           ((#:configure-flags flags)
+            `(cons* ,(string-append "--build=" (%current-system))
+                    ,(string-append "--host=" target)
+                    ,flags))
+           ((#:phases phases)
+            #~(modify-phases #$phases
+                (add-after 'unpack 'delete-shared-target
+                  ;; Cannot create shared libraries due to missing crt1.o
+                  (lambda _
+                    (substitute* "Makeconf"
+                      (("(targets := \\$\\(libname\\)\\.a) \\$\\(libname\\)\\.so" all static)
+                       static)
+                      (("\\$\\(DESTDIR\\)\\$\\(libdir\\)/\\$\\(libname\\)\\.so\\.\\$\\(hurd-version\\)")
+                       "")
+                      (("^libs: .*\\.so\\..*" all)
+                       (string-append "# " all)))))
+                (add-before 'configure 'set-cross-headers-path
+                  (lambda* (#:key inputs #:allow-other-keys)
+                    (let* ((glibc-headers (assoc-ref inputs "cross-glibc-hurd-headers"))
+                           (mach-headers (assoc-ref inputs "cross-gnumach-headers"))
+                           (cpath (string-append glibc-headers "/include"
+                                                 ":" mach-headers "/include")))
+                      (for-each (cut setenv <> cpath)
+                                '#$%gcc-cross-include-paths)
+                      #t)))))))
+
+        (inputs `(("cross-glibc-hurd-headers" ,xglibc/hurd-headers)
+                  ("cross-gnumach-headers" ,xgnumach-headers)))
+
+        (native-inputs `(("cross-gcc" ,xgcc)
+                         ("cross-binutils" ,xbinutils)
+                         ("cross-mig" ,xmig)
+                         ,@(alist-delete "mig"
+                                         (package-native-inputs hurd-minimal))))))
+
+    (define xhurd-core-headers
+      (package
+        (inherit hurd-core-headers)
+        (name (string-append (package-name hurd-core-headers)
+                             "-cross-" target))
+
+        (inputs `(("gnumach-headers" ,xgnumach-headers)
+                  ("hurd-headers" ,xhurd-headers)
+                  ("hurd-minimal" ,xhurd-minimal)))))
+
+    (match target
+      ((or "i586-pc-gnu" "i586-gnu") xhurd-core-headers)
+      (_ xlinux-headers))))
 
 (define* (cross-libc . args)
   (if (or (= (length args) 1) (contains-keyword? args))
-- 
2.41.0

[bug#68266] [PATCH 5/7] gnu: Memozise cross-mig results.

[Christopher Baines]

To ensure that it just returns a single package record for some given
arguments, as this helps to avoid poor performance of the store connection
object cache.

* gnu/packages/cross-base.scm (cross-mig): Move code to
cross-mig/implementation and call it.
(cross-mig/implementation) New procedure.

Change-Id: Iaf2a69c48664d2f0766b9d2f6e981653e0e3c44c
---
 gnu/packages/cross-base.scm | 56 +++++++++++++++++++------------------
 1 file changed, 29 insertions(+), 27 deletions(-)

diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm
index f966e2f5ac..6c6c6e7636 100644
--- a/gnu/packages/cross-base.scm
+++ b/gnu/packages/cross-base.scm
@@ -467,37 +467,39 @@ (define* (cross-mig target
                     (xbinutils (cross-binutils target)))
   "Return a cross-mig for TARGET, where TARGET is a GNU triplet.  Use XGCC as
 the base compiler.  Use XBINUTILS as the associated cross-Binutils."
-  (define xgnumach-headers
-    (cross-gnumach-headers target
-                           #:xgcc xgcc
-                           #:xbinutils xbinutils))
-  (package
-    (inherit mig)
-    (name (string-append "mig-cross"))
-    (arguments
-     (substitute-keyword-arguments (package-arguments mig)
-       ((#:configure-flags flags #~'())
-        #~(list #$(string-append "--target=" target)))
-       ((#:tests? _ #f)
-        #f)
-       ((#:phases phases #~%standard-phases)
-        #~(modify-phases #$phases
-            (add-before 'configure 'set-cross-headers-path
-              (lambda* (#:key inputs #:allow-other-keys)
-                (let* ((mach #+xgnumach-headers)
-                       (cpath (string-append mach "/include")))
-                  (for-each (lambda (variable)
-                              (setenv variable cpath))
-                            '#$%gcc-cross-include-paths))))))))
-    (propagated-inputs
-     (list xgnumach-headers))
-    (native-inputs
-     (modify-inputs (package-native-inputs mig)
-       (prepend xgcc xbinutils)))))
+  (cross-mig/implementation target xgcc xbinutils))
 
+(define cross-mig/implementation
+  (mlambda (target xgcc xbinutils)
+    "Return a cross-mig for TARGET, where TARGET is a GNU triplet.  Use XGCC as
+the base compiler.  Use XBINUTILS as the associated cross-Binutils."
+    (define xgnumach-headers
+      (cross-gnumach-headers target
+                             #:xgcc xgcc
+                             #:xbinutils xbinutils))
     (package
+      (inherit mig)
+      (name (string-append "mig-cross"))
       (arguments
+       (substitute-keyword-arguments (package-arguments mig)
+         ((#:configure-flags flags #~'())
+          #~(list #$(string-append "--target=" target)))
+         ((#:tests? _ #f)
+          #f)
+         ((#:phases phases #~%standard-phases)
           #~(modify-phases #$phases
+              (add-before 'configure 'set-cross-headers-path
+                (lambda* (#:key inputs #:allow-other-keys)
+                  (let* ((mach #+xgnumach-headers)
+                         (cpath (string-append mach "/include")))
+                    (for-each (lambda (variable)
+                                (setenv variable cpath))
+                              '#$%gcc-cross-include-paths))))))))
+      (propagated-inputs
+       (list xgnumach-headers))
+      (native-inputs
+       (modify-inputs (package-native-inputs mig)
+         (prepend xgcc xbinutils))))))
 
 (define cross-kernel-headers/implementation
   (mlambda (target linux-headers xgcc xbinutils)
-- 
2.41.0

[bug#68266] [PATCH 6/7] gnu: Memozise cross-libc results.

[Christopher Baines]

To ensure that it just returns a single package record for some given
arguments, as this helps to avoid poor performance of the store connection
object cache.

* gnu/packages/cross-base.scm (cross-libc*): Move code to
cross-libc/implementation and call it.
(cross-libc/implementation) New procedure.

Change-Id: I72f430136860e5d1fd9edeb3274678186b896bd4
---
 gnu/packages/cross-base.scm | 165 +++++++++++++++++++-----------------
 1 file changed, 85 insertions(+), 80 deletions(-)

diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm
index 6c6c6e7636..8a40211456 100644
--- a/gnu/packages/cross-base.scm
+++ b/gnu/packages/cross-base.scm
@@ -651,10 +651,22 @@ (define cross-kernel-headers/implementation
       (_ xlinux-headers))))
 
 (define* (cross-libc . args)
+  "Return LIBC cross-built for TARGET, a GNU triplet. Use XGCC and XBINUTILS
+and the cross tool chain.  If TARGET doesn't have a standard C library #f is
+returned."
   (if (or (= (length args) 1) (contains-keyword? args))
       (apply cross-libc* args)
       (apply cross-libc/deprecated args)))
 
+(define* (cross-libc* target
+                      #:key
+                      (libc (libc-for-target target))
+                      (xgcc (cross-gcc target))
+                      (xbinutils (cross-binutils target))
+                      (xheaders (cross-kernel-headers target)))
+  (cross-libc/implementation target libc
+                             xgcc xbinutils xheaders))
+
 (define* (cross-libc/deprecated target
                                 #:optional
                                 (libc (libc-for-target target))
@@ -668,88 +680,81 @@ (define* (cross-libc/deprecated target
                #:xbinutils xbinutils
                #:xheaders xheaders))
 
-(define* (cross-libc* target
-                      #:key
-                      (libc (libc-for-target target))
-                      (xgcc (cross-gcc target))
-                      (xbinutils (cross-binutils target))
-                      (xheaders (cross-kernel-headers target)))
-  "Return LIBC cross-built for TARGET, a GNU triplet. Use XGCC and XBINUTILS
-and the cross tool chain.  If TARGET doesn't have a standard C library #f is
-returned."
-  (match target
-   ((? target-mingw?)
-    (let ((machine (substring target 0 (string-index target #\-))))
-      (make-mingw-w64 machine
-                      #:xgcc xgcc
-                      #:xbinutils xbinutils)))
-   ((or (? target-linux?) (? target-hurd?))
-    (package
-      (inherit libc)
-      (name (string-append "glibc-cross-" target))
-      (arguments
-       (substitute-keyword-arguments
-         `(;; Disable stripping (see above.)
-           #:strip-binaries? #f
-
-           ;; This package is used as a target input, but it should not have
-           ;; the usual cross-compilation inputs since that would include
-           ;; itself.
-           #:implicit-cross-inputs? #f
-
-           ;; We need SRFI 26.
-           #:modules ((guix build gnu-build-system)
-                      (guix build utils)
-                      (srfi srfi-26))
-
-           ,@(package-arguments libc))
-         ((#:configure-flags flags)
-          `(cons ,(string-append "--host=" target)
-                 ,(if (target-hurd? target)
-                      `(append (list "--disable-werror"
-                                     ,@%glibc/hurd-configure-flags)
-                               ,flags)
-                      flags)))
-         ((#:phases phases)
-          `(modify-phases ,phases
-             (add-before 'configure 'set-cross-kernel-headers-path
-               (lambda* (#:key inputs #:allow-other-keys)
-                 (let* ((kernel (assoc-ref inputs "kernel-headers"))
-                        (cpath (string-append kernel "/include")))
-                   (for-each (cut setenv <> cpath)
-                             ',%gcc-cross-include-paths)
-                   (setenv "CROSS_LIBRARY_PATH"
+(define cross-libc/implementation
+  (mlambda (target libc xgcc xbinutils xheaders)
+    (match target
+      ((? target-mingw?)
+       (let ((machine (substring target 0 (string-index target #\-))))
+         (make-mingw-w64 machine
+                         #:xgcc xgcc
+                         #:xbinutils xbinutils)))
+      ((or (? target-linux?) (? target-hurd?))
+       (package
+         (inherit libc)
+         (name (string-append "glibc-cross-" target))
+         (arguments
+          (substitute-keyword-arguments
+              `(;; Disable stripping (see above.)
+                #:strip-binaries? #f
+
+                                  ;; This package is used as a target input, but it should not have
+                                  ;; the usual cross-compilation inputs since that would include
+                                  ;; itself.
+                                  #:implicit-cross-inputs? #f
+
+                                  ;; We need SRFI 26.
+                                  #:modules ((guix build gnu-build-system)
+                                             (guix build utils)
+                                             (srfi srfi-26))
+
+                                  ,@(package-arguments libc))
+            ((#:configure-flags flags)
+             `(cons ,(string-append "--host=" target)
+                    ,(if (target-hurd? target)
+                         `(append (list "--disable-werror"
+                                        ,@%glibc/hurd-configure-flags)
+                                  ,flags)
+                         flags)))
+            ((#:phases phases)
+             `(modify-phases ,phases
+                (add-before 'configure 'set-cross-kernel-headers-path
+                  (lambda* (#:key inputs #:allow-other-keys)
+                    (let* ((kernel (assoc-ref inputs "kernel-headers"))
+                           (cpath (string-append kernel "/include")))
+                      (for-each (cut setenv <> cpath)
+                                ',%gcc-cross-include-paths)
+                      (setenv "CROSS_LIBRARY_PATH"
                               (string-append kernel "/lib")) ; for Hurd's libihash
                       #t)))
-             ,@(if (target-hurd? target)
-                   '((add-after 'install 'augment-libc.so
-                       (lambda* (#:key outputs #:allow-other-keys)
-                         (let* ((out (assoc-ref outputs "out")))
-                           (substitute* (string-append out "/lib/libc.so")
-                             (("/[^ ]+/lib/libc.so.0.3")
-                              (string-append out "/lib/libc.so.0.3"
-                                             " libmachuser.so libhurduser.so"))))
-                         #t)))
-                   '())))))
-
-      ;; Shadow the native "kernel-headers" because glibc's recipe expects the
-      ;; "kernel-headers" input to point to the right thing.
-      (propagated-inputs `(("kernel-headers" ,xheaders)))
-
-      (native-inputs `(("cross-gcc" ,xgcc)
-                       ("cross-binutils" ,xbinutils)
-                       ,@(if (target-hurd? target)
-                             `(("cross-mig"
-                                ,(cross-mig target
-                                            #:xgcc xgcc
-                                            #:xbinutils xbinutils)))
-                             '())
-                       ,@(package-inputs libc) ;FIXME: static-bash
-                       ,@(package-native-inputs libc)))))
-   ((? target-avr?)
-    (make-avr-libc #:xbinutils xbinutils
-                   #:xgcc xgcc))
-   (else #f)))
+                ,@(if (target-hurd? target)
+                      '((add-after 'install 'augment-libc.so
+                          (lambda* (#:key outputs #:allow-other-keys)
+                            (let* ((out (assoc-ref outputs "out")))
+                              (substitute* (string-append out "/lib/libc.so")
+                                (("/[^ ]+/lib/libc.so.0.3")
+                                 (string-append out "/lib/libc.so.0.3"
+                                                " libmachuser.so libhurduser.so"))))
+                            #t)))
+                      '())))))
+
+         ;; Shadow the native "kernel-headers" because glibc's recipe expects the
+         ;; "kernel-headers" input to point to the right thing.
+         (propagated-inputs `(("kernel-headers" ,xheaders)))
+
+         (native-inputs `(("cross-gcc" ,xgcc)
+                          ("cross-binutils" ,xbinutils)
+                          ,@(if (target-hurd? target)
+                                `(("cross-mig"
+                                   ,(cross-mig target
+                                               #:xgcc xgcc
+                                               #:xbinutils xbinutils)))
+                                '())
+                          ,@(package-inputs libc) ;FIXME: static-bash
+                          ,@(package-native-inputs libc)))))
+      ((? target-avr?)
+       (make-avr-libc #:xbinutils xbinutils
+                      #:xgcc xgcc))
+      (else #f))))
 
 (define* (cross-gcc-toolchain/implementation target
                                              #:key
-- 
2.41.0

[bug#68266] [PATCH 7/7] packages: rust: Memoize make-rust-sysroot results.

[Christopher Baines]

To ensure that it just returns a single package record for some given
arguments, as this helps to avoid poor performance of the store connection
object cache.

* gnu/packages/rust.scm (make-rust-sysroot): Move code to
make-rust-sysroot/implementation.
(make-rust-sysroot/implementation): New variable.

Change-Id: Ibb30c7398328c87c032bb8828635a34ada935167
---
 gnu/packages/rust.scm | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/rust.scm b/gnu/packages/rust.scm
index ea95d27476..64cde7ea14 100644
--- a/gnu/packages/rust.scm
+++ b/gnu/packages/rust.scm
@@ -60,6 +60,7 @@ (define-module (gnu packages rust)
   #:use-module (guix build-system gnu)
   #:use-module (guix build-system trivial)
   #:use-module (guix download)
+  #:use-module (guix memoization)
   #:use-module (guix git-download)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix packages)
@@ -1057,7 +1058,10 @@ (define-public rust
                             (package-native-inputs base-rust))))))
 
 (define*-public (make-rust-sysroot target)
-  (let ((base-rust rust))
+  (make-rust-sysroot/implementation target rust))
+
+(define make-rust-sysroot/implementation
+  (mlambda (target base-rust)
     (package
       (inherit base-rust)
       (name (string-append "rust-sysroot-for-" target))
-- 
2.41.0

[bug#68266] [PATCH 7/7] packages: rust: Memoize make-rust-sysroot results.

[Ludovic Courtès]

[-- Attachment #1: Type: text/plain, Size: 1095 bytes --]

Hi,

Christopher Baines <mail@cbaines.net> skribis:

> To ensure that it just returns a single package record for some given
> arguments, as this helps to avoid poor performance of the store connection
> object cache.
>
> * gnu/packages/rust.scm (make-rust-sysroot): Move code to
> make-rust-sysroot/implementation.
> (make-rust-sysroot/implementation): New variable.
>
> Change-Id: Ibb30c7398328c87c032bb8828635a34ada935167

[...]

>  (define*-public (make-rust-sysroot target)
> -  (let ((base-rust rust))
> +  (make-rust-sysroot/implementation target rust))
> +
> +(define make-rust-sysroot/implementation
> +  (mlambda (target base-rust)
>      (package
>        (inherit base-rust)
>        (name (string-append "rust-sysroot-for-" target))

We should avoid using ‘mlambda’ (without ‘q’) with packages as it leads
to deep object comparisons.  That’s why for packages we typically
always have one-argument (mlambdaq (package) …).

But since ‘base-rust’ wasn’t a parameter before, let’s keep it simple
(‘diff --ignore-space-change’):


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 1123 bytes --]

diff --git a/gnu/packages/rust.scm b/gnu/packages/rust.scm
index 2b86cf3c8b..983a3f0f41 100644
--- a/gnu/packages/rust.scm
+++ b/gnu/packages/rust.scm
@@ -62,6 +62,7 @@ (define-module (gnu packages rust)
   #:use-module (guix download)
   #:use-module (guix git-download)
   #:use-module ((guix licenses) #:prefix license:)
+  #:use-module (guix memoization)
   #:use-module (guix packages)
   #:use-module ((guix build utils) #:select (alist-replace))
   #:use-module (guix utils)
@@ -1060,7 +1061,8 @@ (define-public rust
                             `("procps" ,procps)
                             (package-native-inputs base-rust))))))
 
-(define*-public (make-rust-sysroot target)
+(define-public make-rust-sysroot
+  (mlambda (target)
     (let ((base-rust rust))
       (package
         (inherit base-rust)
@@ -1228,7 +1230,7 @@ (define*-public (make-rust-sysroot target)
                         (cross-binutils target)))))
         (properties
          `((hidden? . #t)
-         ,(package-properties base-rust))))))
+           ,(package-properties base-rust)))))))
 
 (define-public rust-analyzer
   (package

[-- Attachment #3: Type: text/plain, Size: 1408 bytes --]


It should help when cross-compiling several ‘cargo-build-system’ packages:

--8<---------------cut here---------------start------------->8---
$ time GUIX_PROFILING=object-cache guix build --no-grafts greetd wlgreet du-dust circtools --target=aarch64-linux-gnu -d # before
/gnu/store/mivzv83wryv9gp5bjncg5m1831dx2xwr-circtools-1.0.0.drv
/gnu/store/4xf7kh9mi0vpvs8m1ak4x8w1rpsdpv6z-du-dust-0.8.6.drv
/gnu/store/ayk54gvlbc1qam6irzf9kaig56dhzni0-wlgreet-0.4.1.drv
/gnu/store/r601i40cii9ic5w1k4hy5c2yngfayh64-greetd-0.9.0.drv
Object Cache:
  fresh caches:    22
  lookups:      40435
  hits:         36821 (91.1%)
  cache size:    3613 entries

real	0m2.964s
user	0m2.925s
sys	0m0.174s
$ time GUIX_PROFILING=object-cache ./pre-inst-env guix build --no-grafts greetd wlgreet du-dust circtools --target=aarch64-linux-gnu -d # after
/gnu/store/1wsldmvigjb8w2gk418npbnfznlb0ck1-circtools-1.0.0.drv
/gnu/store/b5c73fawjdvkgy431qxz9l6l9y9a9lhz-du-dust-0.8.6.drv
/gnu/store/zwc7qzsbzf62dgbbzy74lki4hsr406bw-wlgreet-0.4.1.drv
/gnu/store/vjdd23hc82701afb132z1ajcqa7hfd74-greetd-0.9.0.drv
Object Cache:
  fresh caches:    22
  lookups:      37942
  hits:         34523 (91.0%)
  cache size:    3418 entries

real	0m2.980s
user	0m3.300s
sys	0m0.160s
--8<---------------cut here---------------end--------------->8---

(Here we removed ~2.5k nodes from the cache.)

WDYT?

Ludo’.

[bug#68266] [PATCH 7/7] packages: rust: Memoize make-rust-sysroot results.

[Christopher Baines]

[-- Attachment #1: Type: text/plain, Size: 1947 bytes --]


Ludovic Courtès <ludo@gnu.org> writes:

> Christopher Baines <mail@cbaines.net> skribis:
>
>> To ensure that it just returns a single package record for some given
>> arguments, as this helps to avoid poor performance of the store connection
>> object cache.
>>
>> * gnu/packages/rust.scm (make-rust-sysroot): Move code to
>> make-rust-sysroot/implementation.
>> (make-rust-sysroot/implementation): New variable.
>>
>> Change-Id: Ibb30c7398328c87c032bb8828635a34ada935167
>
> [...]
>
>>  (define*-public (make-rust-sysroot target)
>> -  (let ((base-rust rust))
>> +  (make-rust-sysroot/implementation target rust))
>> +
>> +(define make-rust-sysroot/implementation
>> +  (mlambda (target base-rust)
>>      (package
>>        (inherit base-rust)
>>        (name (string-append "rust-sysroot-for-" target))
>
> We should avoid using ‘mlambda’ (without ‘q’) with packages as it leads
> to deep object comparisons.  That’s why for packages we typically
> always have one-argument (mlambdaq (package) …).
>
> But since ‘base-rust’ wasn’t a parameter before, let’s keep it simple
> (‘diff --ignore-space-change’):

...

> WDYT?

Yeah, that does look good. I pushed my earlier version of this patch
this morning though.

I did have a look at trying to adapt the changes to fit in (guix
build-system cargo) instead, as I noticed that seemed to be a pattern
elsewhere, but I think there's something weird going on with the use of
make-rust-sysroot there since default-rust-sysroot takes an argument,
but doesn't use it. Maybe once that's figured out, we can move the
memoization there and switch to just using the target as the key.

Unfortunately I'm still waiting to see what effect this has on the data
service processing revisions. I'm pretty sure it's going to help, but
I'm concerned it's not going to help enough to make processing revisions
for patches feasible again.

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 987 bytes --]

[bug#68266] [PATCH 7/7] packages: rust: Memoize make-rust-sysroot results.

[Efraim Flashner]

[-- Attachment #1: Type: text/plain, Size: 2950 bytes --]

On Fri, Jan 12, 2024 at 05:57:26PM +0000, Christopher Baines wrote:
> 
> Ludovic Courtès <ludo@gnu.org> writes:
> 
> > Christopher Baines <mail@cbaines.net> skribis:
> >
> >> To ensure that it just returns a single package record for some given
> >> arguments, as this helps to avoid poor performance of the store connection
> >> object cache.
> >>
> >> * gnu/packages/rust.scm (make-rust-sysroot): Move code to
> >> make-rust-sysroot/implementation.
> >> (make-rust-sysroot/implementation): New variable.
> >>
> >> Change-Id: Ibb30c7398328c87c032bb8828635a34ada935167
> >
> > [...]
> >
> >>  (define*-public (make-rust-sysroot target)
> >> -  (let ((base-rust rust))
> >> +  (make-rust-sysroot/implementation target rust))
> >> +
> >> +(define make-rust-sysroot/implementation
> >> +  (mlambda (target base-rust)
> >>      (package
> >>        (inherit base-rust)
> >>        (name (string-append "rust-sysroot-for-" target))
> >
> > We should avoid using ‘mlambda’ (without ‘q’) with packages as it leads
> > to deep object comparisons.  That’s why for packages we typically
> > always have one-argument (mlambdaq (package) …).
> >
> > But since ‘base-rust’ wasn’t a parameter before, let’s keep it simple
> > (‘diff --ignore-space-change’):
> 
> ...
> 
> > WDYT?
> 
> Yeah, that does look good. I pushed my earlier version of this patch
> this morning though.
> 
> I did have a look at trying to adapt the changes to fit in (guix
> build-system cargo) instead, as I noticed that seemed to be a pattern
> elsewhere, but I think there's something weird going on with the use of
> make-rust-sysroot there since default-rust-sysroot takes an argument,
> but doesn't use it. Maybe once that's figured out, we can move the
> memoization there and switch to just using the target as the key.
> 
> Unfortunately I'm still waiting to see what effect this has on the data
> service processing revisions. I'm pretty sure it's going to help, but
> I'm concerned it's not going to help enough to make processing revisions
> for patches feasible again.

I looked at the build system a bit and I think it was a combination of
cargo-culting the other cross build implementations that took a target
argument for the cross-compilers and I figured that rust-sysroot would
also need one. The other bit was I think I had in mind the possibility
of choosing seemingly arbitrary targets which were supported by rust but
not known to Guix and having it possible to cross-compile to those.
Given that rust, like go, IIRC doesn't actually need a cross-compiled
compiler to build cross-compiled packages, could it be that parts of
that logic can be rewritten/simplified?


-- 
Efraim Flashner   <efraim@flashner.co.il>   רנשלפ םירפא
GPG key = A28B F40C 3E55 1372 662D  14F7 41AA E7DC CA3D 8351
Confidentiality cannot be guaranteed on emails sent or received unencrypted

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 833 bytes --]

[bug#68266] [PATCH 7/7] packages: rust: Memoize make-rust-sysroot results.

[Ludovic Courtès]

Hello,

Christopher Baines <mail@cbaines.net> skribis:

> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Christopher Baines <mail@cbaines.net> skribis:

[...]

>>>  (define*-public (make-rust-sysroot target)
>>> -  (let ((base-rust rust))
>>> +  (make-rust-sysroot/implementation target rust))
>>> +
>>> +(define make-rust-sysroot/implementation
>>> +  (mlambda (target base-rust)
>>>      (package
>>>        (inherit base-rust)
>>>        (name (string-append "rust-sysroot-for-" target))
>>
>> We should avoid using ‘mlambda’ (without ‘q’) with packages as it leads
>> to deep object comparisons.  That’s why for packages we typically
>> always have one-argument (mlambdaq (package) …).
>>
>> But since ‘base-rust’ wasn’t a parameter before, let’s keep it simple
>> (‘diff --ignore-space-change’):
>
> ...
>
>> WDYT?
>
> Yeah, that does look good. I pushed my earlier version of this patch
> this morning though.
>
> I did have a look at trying to adapt the changes to fit in (guix
> build-system cargo) instead, as I noticed that seemed to be a pattern
> elsewhere, but I think there's something weird going on with the use of
> make-rust-sysroot there since default-rust-sysroot takes an argument,

What matters is that ‘make-rust-sysroot’ takes a single argument,
‘target’, so we can safely write:

  (define make-rust-sysroot
    (mlambda (target)
      …))

I think it’s important to not bring a deep <package> comparison because
this kind of cost is then hard to pinpoint.

Perhaps you can adjust ‘make-rust-sysroot’ along these lines?

Thanks,
Ludo’.

[bug#68266] [PATCH 1/7] gnu: Memozise make-ld-wrapper results.

[Ludovic Courtès]

Hi,

Christopher Baines <mail@cbaines.net> skribis:

> To ensure that it just returns a single package record for some given
> arguments, as this helps to avoid poor performance of the store connection
> object cache.
>
> * gnu/packages/base.scm (make-ld-wrapper): Move code to
> make-ld-wrapper/implementation and call it.
> (make-ld-wrapper/implementation) New procedure.
>
> Change-Id: Id6fc805a4a7ffbc5ff0a5174eafcdf2c7c46854d

Do you have figures before and after the change?

The reason I’m asking is that (gnu packages commencement) arranges to
not call ‘make-ld-wrapper’ repeatedly already.  For instance, there’s:

  (define-public ld-wrapper
    ;; The final 'ld' wrapper, which uses the final Guile and Binutils.
    (make-ld-wrapper "ld-wrapper"
                     #:binutils binutils-final
                     #:guile guile-final
                     #:bash bash-final))

and from there on we manipulate a single <package> record.

Thanks,
Ludo’.

[bug#68266] [PATCH 1/7] gnu: Memozise make-ld-wrapper results.

[Christopher Baines]

[-- Attachment #1: Type: text/plain, Size: 1677 bytes --]


Ludovic Courtès <ludo@gnu.org> writes:

> Hi,
>
> Christopher Baines <mail@cbaines.net> skribis:
>
>> To ensure that it just returns a single package record for some given
>> arguments, as this helps to avoid poor performance of the store connection
>> object cache.
>>
>> * gnu/packages/base.scm (make-ld-wrapper): Move code to
>> make-ld-wrapper/implementation and call it.
>> (make-ld-wrapper/implementation) New procedure.
>>
>> Change-Id: Id6fc805a4a7ffbc5ff0a5174eafcdf2c7c46854d
>
> Do you have figures before and after the change?
>
> The reason I’m asking is that (gnu packages commencement) arranges to
> not call ‘make-ld-wrapper’ repeatedly already.  For instance, there’s:
>
>   (define-public ld-wrapper
>     ;; The final 'ld' wrapper, which uses the final Guile and Binutils.
>     (make-ld-wrapper "ld-wrapper"
>                      #:binutils binutils-final
>                      #:guile guile-final
>                      #:bash bash-final))
>
> and from there on we manipulate a single <package> record.

I believe the reason packages from make-ld-wrapper were showing up
multiple times in the cache for me is linked to it's use in the
cross-base module, as part of the cross-gcc procedure.

A later commit does change cross-gcc to return a single package record
for some given arguments, so that probably resolves the biggest misuse
of make-ld-wrapper.

I think there's other cases (in the llvm and mold modules) where it
looks like it's called multiple times with the same arguments, so maybe
that's an argument for having memoization around make-ld-wrapper even
though it's not needed for all uses.

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 987 bytes --]

[bug#68266] [PATCH 1/7] gnu: Memozise make-ld-wrapper results.

[Ludovic Courtès]

[-- Attachment #1: Type: text/plain, Size: 712 bytes --]

Hi,

Christopher Baines <mail@cbaines.net> skribis:

> I believe the reason packages from make-ld-wrapper were showing up
> multiple times in the cache for me is linked to it's use in the
> cross-base module, as part of the cross-gcc procedure.
>
> A later commit does change cross-gcc to return a single package record
> for some given arguments, so that probably resolves the biggest misuse
> of make-ld-wrapper.

Oh, I see.

Before resorting to memoization (which doesn’t come for free), we can
for instance make sure we do not create new package records from inputs
fields (since they are thunked, a fresh record would be created each
time the field is accessed).  Here’s an example:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 1398 bytes --]

diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm
index 6ee7b315d8..ca3b41a4c7 100644
--- a/gnu/packages/cross-base.scm
+++ b/gnu/packages/cross-base.scm
@@ -306,6 +306,11 @@ (define* (cross-gcc target
 XGCC as the base compiler.  Use XBINUTILS as the associated cross-Binutils.
 If LIBC is false, then build a GCC that does not target a libc; otherwise,
 target that libc."
+  (define ld-wrapper
+    (make-ld-wrapper (string-append "ld-wrapper-" target)
+                     #:target (const target)
+                     #:binutils xbinutils))
+
   (package
     (inherit xgcc)
     (name (string-append "gcc-cross-"
@@ -313,8 +318,7 @@ (define* (cross-gcc target
                          target))
     (source
      (origin
-       (inherit
-        (package-source xgcc))
+       (inherit (package-source xgcc))
        (patches
         (append
          (origin-patches (package-source xgcc))
@@ -353,10 +357,7 @@ (define* (cross-gcc target
        ,@(cross-gcc-arguments target xgcc libc)))
 
     (native-inputs
-     `(("ld-wrapper-cross" ,(make-ld-wrapper
-                             (string-append "ld-wrapper-" target)
-                             #:target (const target)
-                             #:binutils xbinutils))
+     `(("ld-wrapper-cross" ,ld-wrapper)
        ("binutils-cross" ,xbinutils)
 
        ,@(let ((inputs (append (package-inputs xgcc)

[-- Attachment #3: Type: text/plain, Size: 1227 bytes --]


This particular one doesn’t have a huge impact on simple cases but it
might pay off for bigger graphs:

--8<---------------cut here---------------start------------->8---
$ GUIX_PROFILING=object-cache ./pre-inst-env guix build hello --target=aarch64-linux-gnu --no-grafts -d
/gnu/store/i8x1gg73x3fvxn4lrrgbcb97sz4qq1yx-hello-2.12.1.drv
Object Cache:
  fresh caches:    20
  lookups:       5514
  hits:          5008 (90.8%)
  cache size:     505 entries
$ # before:
$ GUIX_PROFILING=object-cache ./pre-inst-env guix build hello --target=aarch64-linux-gnu --no-grafts -d
/gnu/store/kdnh9bwg874aq8bvvw9y2vkl7z94icqa-hello-2.12.1.drv
Object Cache:
  fresh caches:    20
  lookups:       5406
  hits:          4907 (90.8%)
  cache size:     498 entries
--8<---------------cut here---------------end--------------->8---

> I think there's other cases (in the llvm and mold modules) where it
> looks like it's called multiple times with the same arguments, so maybe
> that's an argument for having memoization around make-ld-wrapper even
> though it's not needed for all uses.

On guix-devel, Efraim mentioned cargo-build-system packages.  Is that
related?

Thanks for looking into this!

Ludo’.

[bug#68266] [PATCH 1/7] gnu: Memozise make-ld-wrapper results.

[Christopher Baines]

[-- Attachment #1: Type: text/plain, Size: 3880 bytes --]


Ludovic Courtès <ludo@gnu.org> writes:

> Christopher Baines <mail@cbaines.net> skribis:
>
>> I believe the reason packages from make-ld-wrapper were showing up
>> multiple times in the cache for me is linked to it's use in the
>> cross-base module, as part of the cross-gcc procedure.
>>
>> A later commit does change cross-gcc to return a single package record
>> for some given arguments, so that probably resolves the biggest misuse
>> of make-ld-wrapper.
>
> Oh, I see.
>
> Before resorting to memoization (which doesn’t come for free), we can
> for instance make sure we do not create new package records from inputs
> fields (since they are thunked, a fresh record would be created each
> time the field is accessed).  Here’s an example:
>
> diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm
> index 6ee7b315d8..ca3b41a4c7 100644
> --- a/gnu/packages/cross-base.scm
> +++ b/gnu/packages/cross-base.scm
> @@ -306,6 +306,11 @@ (define* (cross-gcc target
>  XGCC as the base compiler.  Use XBINUTILS as the associated cross-Binutils.
>  If LIBC is false, then build a GCC that does not target a libc; otherwise,
>  target that libc."
> +  (define ld-wrapper
> +    (make-ld-wrapper (string-append "ld-wrapper-" target)
> +                     #:target (const target)
> +                     #:binutils xbinutils))
> +
>    (package
>      (inherit xgcc)
>      (name (string-append "gcc-cross-"
> @@ -313,8 +318,7 @@ (define* (cross-gcc target
>                           target))
>      (source
>       (origin
> -       (inherit
> -        (package-source xgcc))
> +       (inherit (package-source xgcc))
>         (patches
>          (append
>           (origin-patches (package-source xgcc))
> @@ -353,10 +357,7 @@ (define* (cross-gcc target
>         ,@(cross-gcc-arguments target xgcc libc)))
>  
>      (native-inputs
> -     `(("ld-wrapper-cross" ,(make-ld-wrapper
> -                             (string-append "ld-wrapper-" target)
> -                             #:target (const target)
> -                             #:binutils xbinutils))
> +     `(("ld-wrapper-cross" ,ld-wrapper)
>         ("binutils-cross" ,xbinutils)
>  
>         ,@(let ((inputs (append (package-inputs xgcc)
>
>
> This particular one doesn’t have a huge impact on simple cases but it
> might pay off for bigger graphs:
>
> $ GUIX_PROFILING=object-cache ./pre-inst-env guix build hello --target=aarch64-linux-gnu --no-grafts -d
> /gnu/store/i8x1gg73x3fvxn4lrrgbcb97sz4qq1yx-hello-2.12.1.drv
> Object Cache:
>   fresh caches:    20
>   lookups:       5514
>   hits:          5008 (90.8%)
>   cache size:     505 entries
> $ # before:
> $ GUIX_PROFILING=object-cache ./pre-inst-env guix build hello --target=aarch64-linux-gnu --no-grafts -d
> /gnu/store/kdnh9bwg874aq8bvvw9y2vkl7z94icqa-hello-2.12.1.drv
> Object Cache:
>   fresh caches:    20
>   lookups:       5406
>   hits:          4907 (90.8%)
>   cache size:     498 entries
>
>> I think there's other cases (in the llvm and mold modules) where it
>> looks like it's called multiple times with the same arguments, so maybe
>> that's an argument for having memoization around make-ld-wrapper even
>> though it's not needed for all uses.
>
> On guix-devel, Efraim mentioned cargo-build-system packages.  Is that
> related?

Looking at the various changes, while rust-sysroot doesn't appear that
many times in the cache, I think it's responsible for most of the
slowness. Maybe that's due in part to what you say above, using the
cross- procedures in the native-inputs field.

Maybe the transformation you suggest above could be applied, but I'd be
worried about how that would work if you set one
%current-system/%current-target-system when you call the procedure, then
another when you compute the derivation.

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 987 bytes --]

[bug#68266] [PATCH v2] guix: store: Add report-object-cache-duplication.

[Christopher Baines]

This is intended to help with spotting duplication in the object cache, so
where many keys, for example package records map to the same derivation. This
represents an opportunity for improved performance if you can reduce this
duplication in the cache, and better take advantage of the already present
cache entries.

I'm thinking this can be used by the data service, but maybe it could also be
worked in to guix commands.

* guix/store.scm (report-object-cache-duplication): New procedure.

Change-Id: Ia6c816f871d10cae6807543224250110099d764f
---
 guix/store.scm | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 59 insertions(+)

diff --git a/guix/store.scm b/guix/store.scm
index 97c4f32a5b..86ca293cac 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -70,6 +70,7 @@ (define-module (guix store)
             current-store-protocol-version        ;for internal use
             cache-lookup-recorder                 ;for internal use
             mcached
+            report-object-cache-duplication
 
             &store-error store-error?
             &store-connection-error store-connection-error?
@@ -2037,6 +2038,64 @@ (define-syntax mcached
     ((_ mvalue object keys ...)
      (mcached eq? mvalue object keys ...))))
 
+(define* (report-object-cache-duplication store #:key (threshold 10)
+                                          (port (current-error-port)))
+  (define cache-values-to-keys
+    (make-hash-table))
+
+  (define (insert key val)
+    (hash-set!
+     cache-values-to-keys
+     key
+     (or (and=> (hash-ref cache-values-to-keys
+                          key)
+                (lambda (existing-values)
+                  (cons val existing-values)))
+         (list val))))
+
+  (let* ((cache-size
+          (vhash-fold
+           (lambda (key value result)
+             (match value
+               ((item . keys*)
+                (insert item key)))
+
+             (+ 1 result))
+           0
+           (store-connection-cache store %object-cache-id)))
+         (cached-values-by-key-count
+          (sort
+           (hash-map->list
+            (lambda (key value)
+              (cons key (length value)))
+            cache-values-to-keys)
+           (lambda (a b)
+             (< (cdr a) (cdr b))))))
+
+    (filter-map
+     (match-lambda
+       ((value . count)
+        (if (>= count threshold)
+            (begin
+              (when port
+                (simple-format port "value ~A cached ~A times\n" value count)
+                (simple-format port "example keys:\n"))
+
+              (let ((keys (hash-ref cache-values-to-keys value)))
+                (when port
+                  (for-each
+                   (lambda (key)
+                     (simple-format #t "  - ~A\n" key))
+                   (if (> count 10)
+                       (take keys 10)
+                       keys))
+                  (newline port))
+
+                `((value . ,value)
+                  (keys . ,keys))))
+            #f)))
+     cached-values-by-key-count)))
+
 (define (preserve-documentation original proc)
   "Return PROC with documentation taken from ORIGINAL."
   (set-object-property! proc 'documentation

base-commit: e541f9593f8bfc84b6140c2408b393243289fae6
-- 
2.41.0

[bug#68266] [PATCH v2] guix: store: Add report-object-cache-duplication.

[Ludovic Courtès]

Christopher Baines <mail@cbaines.net> skribis:

> This is intended to help with spotting duplication in the object cache, so
> where many keys, for example package records map to the same derivation. This
> represents an opportunity for improved performance if you can reduce this
> duplication in the cache, and better take advantage of the already present
> cache entries.

Another way to detect this is by looking at ‘add-data-to-store-cache’
stats:

--8<---------------cut here---------------start------------->8---
$ GUIX_PROFILING="add-data-to-store-cache object-cache" guix build --no-grafts greetd wlgreet du-dust circtools --target=aarch64-linux-gnu -d 
/gnu/store/mivzv83wryv9gp5bjncg5m1831dx2xwr-circtools-1.0.0.drv
/gnu/store/4xf7kh9mi0vpvs8m1ak4x8w1rpsdpv6z-du-dust-0.8.6.drv
/gnu/store/ayk54gvlbc1qam6irzf9kaig56dhzni0-wlgreet-0.4.1.drv
/gnu/store/r601i40cii9ic5w1k4hy5c2yngfayh64-greetd-0.9.0.drv
Object Cache:
  fresh caches:    22
  lookups:      40435
  hits:         36821 (91.1%)
  cache size:    3613 entries

'add-data-to-store' cache:
  lookups:       4090
  hits:           958 (23.4%)
  .drv files:    3062 (74.9%)
  Scheme files:   916 (22.4%)
$ GUIX_PROFILING="add-data-to-store-cache object-cache" ./pre-inst-env guix build --no-grafts greetd wlgreet du-dust circtools --target=aarch64-linux-gnu -d 
/gnu/store/1wsldmvigjb8w2gk418npbnfznlb0ck1-circtools-1.0.0.drv
/gnu/store/b5c73fawjdvkgy431qxz9l6l9y9a9lhz-du-dust-0.8.6.drv
/gnu/store/zwc7qzsbzf62dgbbzy74lki4hsr406bw-wlgreet-0.4.1.drv
/gnu/store/vjdd23hc82701afb132z1ajcqa7hfd74-greetd-0.9.0.drv
Object Cache:
  fresh caches:    22
  lookups:      37942
  hits:         34523 (91.0%)
  cache size:    3418 entries

'add-data-to-store' cache:
  lookups:       3895
  hits:           763 (19.6%)
  .drv files:    2957 (75.9%)
  Scheme files:   826 (21.2%)
--8<---------------cut here---------------end--------------->8---

Ideally, the hit rate there would be 0% and we could remove it.

If there’s a positive hit rate, it means we keep adding the same .drv
and/or *-builder files to the store, meaning that the object cache was
ineffective.

> +(define* (report-object-cache-duplication store #:key (threshold 10)
> +                                          (port (current-error-port)))

Do you have an example output of this?

How helpful does it look to you in practice?

I guess it we’d need to add a ‘register-profiling-hook!’ call somewhere?

If we were to add this, I’d suggest adding a docstring and following the
same style as the rest of the code (no long identifiers for local
variables and no car/cdr, for example).

Thanks,
Ludo’.

[bug#68266] [PATCH v2] guix: store: Add report-object-cache-duplication.

[Christopher Baines]

[-- Attachment #1: Type: text/plain, Size: 5676 bytes --]


Ludovic Courtès <ludo@gnu.org> writes:

> Christopher Baines <mail@cbaines.net> skribis:
>
>> This is intended to help with spotting duplication in the object cache, so
>> where many keys, for example package records map to the same derivation. This
>> represents an opportunity for improved performance if you can reduce this
>> duplication in the cache, and better take advantage of the already present
>> cache entries.
>
> Another way to detect this is by looking at ‘add-data-to-store-cache’
> stats:
>
> $ GUIX_PROFILING="add-data-to-store-cache object-cache" guix build --no-grafts greetd wlgreet du-dust circtools --target=aarch64-linux-gnu -d 
> /gnu/store/mivzv83wryv9gp5bjncg5m1831dx2xwr-circtools-1.0.0.drv
> /gnu/store/4xf7kh9mi0vpvs8m1ak4x8w1rpsdpv6z-du-dust-0.8.6.drv
> /gnu/store/ayk54gvlbc1qam6irzf9kaig56dhzni0-wlgreet-0.4.1.drv
> /gnu/store/r601i40cii9ic5w1k4hy5c2yngfayh64-greetd-0.9.0.drv
> Object Cache:
>   fresh caches:    22
>   lookups:      40435
>   hits:         36821 (91.1%)
>   cache size:    3613 entries
>
> 'add-data-to-store' cache:
>   lookups:       4090
>   hits:           958 (23.4%)
>   .drv files:    3062 (74.9%)
>   Scheme files:   916 (22.4%)
> $ GUIX_PROFILING="add-data-to-store-cache object-cache" ./pre-inst-env guix build --no-grafts greetd wlgreet du-dust circtools --target=aarch64-linux-gnu -d 
> /gnu/store/1wsldmvigjb8w2gk418npbnfznlb0ck1-circtools-1.0.0.drv
> /gnu/store/b5c73fawjdvkgy431qxz9l6l9y9a9lhz-du-dust-0.8.6.drv
> /gnu/store/zwc7qzsbzf62dgbbzy74lki4hsr406bw-wlgreet-0.4.1.drv
> /gnu/store/vjdd23hc82701afb132z1ajcqa7hfd74-greetd-0.9.0.drv
> Object Cache:
>   fresh caches:    22
>   lookups:      37942
>   hits:         34523 (91.0%)
>   cache size:    3418 entries
>
> 'add-data-to-store' cache:
>   lookups:       3895
>   hits:           763 (19.6%)
>   .drv files:    2957 (75.9%)
>   Scheme files:   826 (21.2%)
>
> Ideally, the hit rate there would be 0% and we could remove it.
>
> If there’s a positive hit rate, it means we keep adding the same .drv
> and/or *-builder files to the store, meaning that the object cache was
> ineffective.
>
>> +(define* (report-object-cache-duplication store #:key (threshold 10)
>> +                                          (port (current-error-port)))
>
> Do you have an example output of this?
>
> How helpful does it look to you in practice?

Yep, so here's some output I get from computing all the cross
derivations to i586-pc-gnu:

  value #<derivation
    /gnu/store/lqxlksh00cshc816xqfq47r3jjdfj2p9-subversion-1.14.2.drv =>
    /gnu/store/92avphfdcrcaxx8m5a6ihmw558bj3np8-subversion-1.14.2 7fcfbe5f9280>
  cached 4174 times
  example keys:
    - #<package subversion@1.14.2 gnu/packages/version-control.scm:2316 7fcfc1c924d0>
    - #<package subversion@1.14.2 gnu/packages/version-control.scm:2316 7fcfc1c924d0>
    - #<file-append #<package subversion@1.14.2 gnu/packages/version-control.scm:2316 7fcfc1c924d0> "/bin/svn">
    - #<file-append #<package subversion@1.14.2 gnu/packages/version-control.scm:2316 7fcfc1c924d0> "/bin/svn">

So it's not immediately obvious what the issue is, but if you search for
"/bin/svn", then you find the file-append calls in svn-fetch, so there's
a couple of new file-append records added to the cache for each
svn-fetch.


  value /gnu/store/qi1km3qlv5hdsql6h3ibwvz6v4z8lqbz-ld-wrapper.in cached 755 times
  example keys:
    - #<<local-file> file: "/home/chris/Projects/Guix/guix/gnu/packages/ld-wrapper.in" absolute: #<promise "/home/chris/Projects/Guix/guix/gnu/packages/ld-wrapper.in"> name: "ld-wrapper.in" recursive?: #t select?: #<procedure true (file stat)>>
    - #<<local-file> file: "/home/chris/Projects/Guix/guix/gnu/packages/ld-wrapper.in" absolute: #<promise "/home/chris/Projects/Guix/guix/gnu/packages/ld-wrapper.in"> name: "ld-wrapper.in" recursive?: #t select?: #<procedure true (file stat)>>
    - #<<local-file> file: "/home/chris/Projects/Guix/guix/gnu/packages/ld-wrapper.in" absolute: #<promise "/home/chris/Projects/Guix/guix/gnu/packages/ld-wrapper.in"> name: "ld-wrapper.in" recursive?: #t select?: #<procedure true (file stat)>>
    - #<<local-file> file: "/home/chris/Projects/Guix/guix/gnu/packages/ld-wrapper.in" absolute: #<promise "/home/chris/Projects/Guix/guix/gnu/packages/ld-wrapper.in"> name: "ld-wrapper.in" recursive?: #t select?: #<procedure true (file stat)>>


Similar to file-append, it's not immediately obvious where all these
local-file's are coming from, but searching for ld-wrapper.in suggests
make-ld-wrapper.

My thinking here is that maybe it's worth not caching everything in the
object cache. Particularly for file-append, I'm not sure what the cache
is actually doing. As for local-file, given there's lower level caching,
maybe it's worth leaning on that and not caching local-file either. I
tried this out, and it seemed to not make performance worse at least,
and it did remove the duplication from the cache.

Other things that show up include:

  value #<derivation /gnu/store/z28jfsm43wg50cvdfq0548pbf5jfhk8r-binutils-cross-i586-pc-gnu-2.38.drv => /gnu/store/lkmwq399jllig2a5r323v6y9nflpn6gn-binutils-cross-i586-pc-gnu-2.38 7fcfbd358000> cached 1228 times
  example keys:
    - #<package binutils-cross-i586-pc-gnu@2.38 gnu/packages/cross-base.scm:79 7fcfbf3bb8f0>
    - #<package binutils-cross-i586-pc-gnu@2.38 gnu/packages/cross-base.scm:79 7fcfbf3b6630>
    - #<package binutils-cross-i586-pc-gnu@2.38 gnu/packages/cross-base.scm:79 7fcfbf3b6420>
    - #<package binutils-cross-i586-pc-gnu@2.38 gnu/packages/cross-base.scm:79 7fcfbf3b62c0>

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 987 bytes --]