[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