[bug#44899] [PATCH 3/3] build-system/gnu: Add 'make-dynamic-linker-cache' phase.

["Ludovic Courtès" <ludo@gnu.org>]

* guix/build/gnu-build-system.scm (make-dynamic-linker-cache): New
procedure.
(%standard-phases): Add it.
* guix/build-system/gnu.scm (gnu-build, gnu-cross-build): Add
 #:make-dynamic-linker-cache? and honor it.
---
 guix/build-system/gnu.scm       |  4 ++
 guix/build/gnu-build-system.scm | 73 +++++++++++++++++++++++++++++++++
 2 files changed, 77 insertions(+)

diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 2c23197e77..d6c4dc9bbc 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -342,6 +342,7 @@ standard packages used as implicit inputs of the GNU build system."
                     (strip-directories ''("lib" "lib64" "libexec"
                                           "bin" "sbin"))
                     (validate-runpath? #t)
+                    (make-dynamic-linker-cache? #t)
                     (license-file-regexp %license-file-regexp)
                     (phases '%standard-phases)
                     (locale "en_US.utf8")
@@ -410,6 +411,7 @@ packages that must not be referenced."
                   #:patch-shebangs? ,patch-shebangs?
                   #:strip-binaries? ,strip-binaries?
                   #:validate-runpath? ,validate-runpath?
+                  #:make-dynamic-linker-cache? ,make-dynamic-linker-cache?
                   #:license-file-regexp ,license-file-regexp
                   #:strip-flags ,strip-flags
                   #:strip-directories ,strip-directories)))
@@ -497,6 +499,7 @@ is one of `host' or `target'."
                           (strip-directories ''("lib" "lib64" "libexec"
                                                 "bin" "sbin"))
                           (validate-runpath? #t)
+                          (make-dynamic-linker-cache? #t)
                           (license-file-regexp %license-file-regexp)
                           (phases '%standard-phases)
                           (locale "en_US.utf8")
@@ -577,6 +580,7 @@ platform."
                     #:patch-shebangs? ,patch-shebangs?
                     #:strip-binaries? ,strip-binaries?
                     #:validate-runpath? ,validate-runpath?
+                    #:make-dynamic-linker-cache? ,make-dynamic-linker-cache?
                     #:license-file-regexp ,license-file-regexp
                     #:strip-flags ,strip-flags
                     #:strip-directories ,strip-directories))))
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 8fa11f4ea9..194cddc047 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -712,6 +712,78 @@ which cannot be found~%"
                                          (which binary) rest)))))))))
             outputs))
 
+(define* (make-dynamic-linker-cache #:key outputs
+                                    (make-dynamic-linker-cache? #t)
+                                    #:allow-other-keys)
+  "Create a dynamic linker cache under 'etc/ld.so.cache' in each of the
+OUTPUTS.  This reduces application startup time by avoiding the 'stat' storm
+that traversing all the RUNPATH entries entails."
+  (define (make-cache-for-output directory)
+    (define bin-directories
+      (filter-map (lambda (sub-directory)
+                    (let ((directory (string-append directory "/"
+                                                    sub-directory)))
+                      (and (directory-exists? directory)
+                           directory)))
+                  '("bin" "sbin")))
+
+    (define programs
+      ;; Programs that can benefit from the ld.so cache.  These programs must
+      ;; be in a directory such that:
+      ;;
+      ;;   (string-append (dirname PROGRAM) "../etc/ld.so.cache")
+      ;;
+      ;; potentially exists since that's what ld.so will look for.  Thus,
+      ;; something like 'libexec/foo/PROGRAM' is not a valid candidate.
+      (append-map (lambda (directory)
+                    (if (directory-exists? directory)
+                        (filter-map (lambda (file)
+                                      (let ((file (string-append
+                                                   directory "/" file)))
+                                        (and (executable-file? file)
+                                             (not (file-is-directory? file))
+                                             (elf-file? file)
+                                             file)))
+                                    (scandir directory))
+                        '()))
+                  bin-directories))
+
+    (define runpaths
+      ;; The union of RUNPATH entries.
+      (delete-duplicates
+       (append-map (lambda (program)
+                     (or (file-runpath program) '()))
+                   programs)))
+
+    (define cache-file
+      (string-append directory "/etc/ld.so.cache"))
+
+    (unless (null? runpaths)
+      (mkdir-p (dirname cache-file))
+      (guard (c ((invoke-error? c)
+                 ;; Do not treat 'ldconfig' failure as an error.
+                 (format (current-error-port)
+                         "warning: 'ldconfig' failed:~%")
+                 (report-invoke-error c (current-error-port))))
+        ;; Create a config file to tell 'ldconfig' where to look for the
+        ;; libraries that PROGRAMS need.
+        (call-with-output-file "/tmp/ld.so.conf"
+          (lambda (port)
+            (for-each (lambda (directory)
+                        (display directory port)
+                        (newline port))
+                      runpaths)))
+
+        (invoke "ldconfig" "-f" "/tmp/ld.so.conf" "-C" cache-file)
+        (format #t "created '~a' from ~a library search path entries~%"
+                cache-file (length runpaths)))))
+
+  (if make-dynamic-linker-cache?
+      (match outputs
+        (((_ . directories) ...)
+         (for-each make-cache-for-output directories)))
+      (format #t "ld.so cache not built~%")))
+
 (define %license-file-regexp
   ;; Regexp matching license files.
   "^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$")
@@ -791,6 +863,7 @@ which cannot be found~%"
             validate-documentation-location
             delete-info-dir-file
             patch-dot-desktop-files
+            make-dynamic-linker-cache
             install-license-files
             reset-gzip-timestamps
             compress-documentation)))
-- 
2.29.2