Merge branch 'origin/core-updates-next' into core-updates

2 files changed, 96 insertions, 38 deletions

diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm
index bb019967e5..e8ea66dfb3 100644
--- a/guix/build/gremlin.scm
+++ b/guix/build/gremlin.scm
@@ -41,7 +41,8 @@
             elf-dynamic-info-runpath
             expand-origin
 
-            validate-needed-in-runpath))
+            validate-needed-in-runpath
+            strip-runpath))
 
 ;;; Commentary:
 ;;;
@@ -99,10 +100,16 @@ dynamic linking information."
 ;;     } d_un;
 ;; } Elf64_Dyn;
 
+(define-record-type <dynamic-entry>
+  (dynamic-entry type value offset)
+  dynamic-entry?
+  (type   dynamic-entry-type)                     ;DT_*
+  (value  dynamic-entry-value)                    ;string | number | ...
+  (offset dynamic-entry-offset))                  ;integer
+
 (define (raw-dynamic-entries elf segment)
-  "Return as a list of type/value pairs all the dynamic entries found in
-SEGMENT, the 'PT_DYNAMIC' segment of ELF.  In the result, each car is a DT_
-value, and the interpretation of the cdr depends on the type."
+  "Return as a list of <dynamic-entry> for the dynamic entries found in
+SEGMENT, the 'PT_DYNAMIC' segment of ELF."
   (define start
     (elf-segment-offset segment))
   (define bytes
@@ -123,7 +130,9 @@ value, and the interpretation of the cdr depends on the type."
           (if (= type DT_NULL)                    ;finished?
               (reverse result)
               (loop (+ offset (* 2 word-size))
-                    (alist-cons type value result)))))))
+                    (cons (dynamic-entry type value
+                                         (+ start offset word-size))
+                          result)))))))
 
 (define (vma->offset elf vma)
   "Convert VMA, a virtual memory address, to an offset within ELF.
@@ -148,35 +157,33 @@ offset."
 
 (define (dynamic-entries elf segment)
   "Return all the dynamic entries found in SEGMENT, the 'PT_DYNAMIC' segment
-of ELF, as a list of type/value pairs.  The type is a DT_ value, and the value
-may be a string or an integer depending on the entry type (for instance, the
-value of DT_NEEDED entries is a string.)"
+of ELF, as a list of <dynamic-entry>.  The value of each entry may be a string
+or an integer depending on the entry type (for instance, the value of
+DT_NEEDED entries is a string.)  Likewise the offset is the offset within the
+string table if the type is a string."
   (define entries
     (raw-dynamic-entries elf segment))
 
   (define string-table-offset
-    (any (match-lambda
-            ((type . value)
-             (and (= type DT_STRTAB) value))
-            (_ #f))
+    (any (lambda (entry)
+           (and (= (dynamic-entry-type entry) DT_STRTAB)
+                (dynamic-entry-value entry)))
          entries))
 
-  (define (interpret-dynamic-entry type value)
-    (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH))
-           (if string-table-offset
-               (pointer->string
-                (bytevector->pointer (elf-bytes elf)
-                                     (vma->offset
-                                      elf
-                                      (+ string-table-offset value))))
-               value))
-          (else
-           value)))
-
-  (map (match-lambda
-         ((type . value)
-          (cons type (interpret-dynamic-entry type value))))
-       entries))
+  (define (interpret-dynamic-entry entry)
+    (let ((type  (dynamic-entry-type entry))
+          (value (dynamic-entry-value entry)))
+      (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH))
+             (if string-table-offset
+                 (let* ((offset (vma->offset elf (+ string-table-offset value)))
+                        (value  (pointer->string
+                                 (bytevector->pointer (elf-bytes elf) offset))))
+                   (dynamic-entry type value offset))
+                 (dynamic-entry type value (dynamic-entry-offset entry))))
+            (else
+             (dynamic-entry type value (dynamic-entry-offset entry))))))
+
+  (map interpret-dynamic-entry entries))
 
 
 ;;;
@@ -200,21 +207,29 @@ value of DT_NEEDED entries is a string.)"
 (define (elf-dynamic-info elf)
   "Return dynamic-link information for ELF as an <elf-dynamic-info> object, or
 #f if ELF lacks dynamic-link information."
+  (define (matching-entry type)
+    (lambda (entry)
+      (= type (dynamic-entry-type entry))))
+
   (match (dynamic-link-segment elf)
     (#f #f)
     ((? elf-segment? dynamic)
      (let ((entries (dynamic-entries elf dynamic)))
-       (%elf-dynamic-info (assv-ref entries DT_SONAME)
-                          (filter-map (match-lambda
-                                        ((type . value)
-                                         (and (= type DT_NEEDED) value))
-                                        (_ #f))
+       (%elf-dynamic-info (find (matching-entry DT_SONAME) entries)
+                          (filter-map (lambda (entry)
+                                        (and (= (dynamic-entry-type entry)
+                                                DT_NEEDED)
+                                             (dynamic-entry-value entry)))
                                       entries)
-                          (or (and=> (assv-ref entries DT_RPATH)
-                                     search-path->list)
+                          (or (and=> (find (matching-entry DT_RPATH)
+                                           entries)
+                                     (compose search-path->list
+                                              dynamic-entry-value))
                               '())
-                          (or (and=> (assv-ref entries DT_RUNPATH)
-                                     search-path->list)
+                          (or (and=> (find (matching-entry DT_RUNPATH)
+                                           entries)
+                                     (compose search-path->list
+                                              dynamic-entry-value))
                               '()))))))
 
 (define %libc-libraries
@@ -306,4 +321,47 @@ be found in RUNPATH ~s~%"
           ;;   (format (current-error-port) "~a is OK~%" file))
           (null? not-found))))))
 
+(define (strip-runpath file)
+  "Remove from the DT_RUNPATH of FILE any entries that are not necessary
+according to DT_NEEDED."
+  (define (minimal-runpath needed runpath)
+    (filter (lambda (directory)
+              (and (string-prefix? "/" directory)
+                   (any (lambda (lib)
+                          (file-exists? (string-append directory "/" lib)))
+                        needed)))
+            runpath))
+
+  (define port
+    (open-file file "r+b"))
+
+  (catch #t
+    (lambda ()
+      (let* ((elf      (parse-elf (get-bytevector-all port)))
+             (entries  (dynamic-entries elf (dynamic-link-segment elf)))
+             (needed   (filter-map (lambda (entry)
+                                     (and (= (dynamic-entry-type entry)
+                                             DT_NEEDED)
+                                          (dynamic-entry-value entry)))
+                                   entries))
+             (runpath  (find (lambda (entry)
+                               (= DT_RUNPATH (dynamic-entry-type entry)))
+                             entries))
+             (old      (search-path->list
+                        (dynamic-entry-value runpath)))
+             (new      (minimal-runpath needed old)))
+        (unless (equal? old new)
+          (format (current-error-port)
+                  "~a: stripping RUNPATH to ~s (removed ~s)~%"
+                  file new
+                  (lset-difference string=? old new))
+          (seek port (dynamic-entry-offset runpath) SEEK_SET)
+          (put-bytevector port (string->utf8 (string-join new ":")))
+          (put-u8 port 0))
+        (close-port port)
+        new))
+    (lambda (key . args)
+      (false-if-exception (close-port port))
+      (apply throw key args))))
+
 ;;; gremlin.scm ends here
diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm
index e7690a4c37..7efd433d6c 100644
--- a/guix/build/meson-build-system.scm
+++ b/guix/build/meson-build-system.scm
@@ -135,7 +135,7 @@ for example libraries only needed for the tests."
                                             (find-files dir elf-pred))
                                           existing-elf-dirs))))
          (for-each (lambda (elf-file)
-                     (system* "patchelf" "--shrink-rpath" elf-file)
+                     (strip-runpath elf-file)
                      (handle-file elf-file elf-list))
                    elf-list)))))
   (for-each handle-output outputs)