[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