Subject: [PATCH 4/7] gnu: Memozise cross-kernel-headers results.

From: Christopher Baines <[email-masked]>
Date: Fri, 5 Jan 2024 16:40:46 +0000

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