Package: guix-patches;
Reported by: Christopher Baines <mail <at> cbaines.net>
Date: Fri, 5 Jan 2024 16:38:02 UTC
Severity: normal
Tags: patch
View this message in rfc822 format
From: Christopher Baines <mail <at> cbaines.net> To: 68266 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [bug#68266] [PATCH 1/7] gnu: Memozise make-ld-wrapper results. Date: Fri, 5 Jan 2024 16:40:43 +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/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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.