diff options
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/gremlin.scm | 132 | ||||
-rw-r--r-- | guix/build/meson-build-system.scm | 8 | ||||
-rw-r--r-- | guix/build/r-build-system.scm | 2 |
3 files changed, 100 insertions, 42 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 e4aae8212f..9724764424 100644 --- a/guix/build/meson-build-system.scm +++ b/guix/build/meson-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,9 +76,8 @@ "1")) (if tests? (invoke "ninja" test-target) - (begin - (format #t "test suite not run~%") - #t))) + (format #t "test suite not run~%")) + #t) (define* (install #:rest args) (invoke "ninja" "install")) @@ -134,7 +134,7 @@ for example libraries only needed for the tests." (find-files dir elf-pred)) existing-elf-dirs)))) (for-each (lambda (elf-file) - (invoke "patchelf" "--shrink-rpath" elf-file) + (strip-runpath elf-file) (handle-file elf-file elf-list)) elf-list))))) (for-each handle-output outputs) diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm index 4d8ac5b479..2c0b322da9 100644 --- a/guix/build/r-build-system.scm +++ b/guix/build/r-build-system.scm @@ -44,7 +44,7 @@ (unless (zero? code) (raise (condition ((@@ (guix build utils) &invoke-error) (program "R") - (arguments (string-append params " " command)) + (arguments (cons command params)) (exit-status (status:exit-val code)) (term-signal (status:term-sig code)) (stop-signal (status:stop-sig code))))))))) |