diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/gremlin.scm | 132 | ||||
| -rw-r--r-- | guix/build/meson-build-system.scm | 8 | ||||
| -rw-r--r-- | guix/build/python-build-system.scm | 2 | ||||
| -rw-r--r-- | guix/build/r-build-system.scm | 2 | ||||
| -rw-r--r-- | guix/gexp.scm | 136 | ||||
| -rw-r--r-- | guix/packages.scm | 10 | ||||
| -rw-r--r-- | guix/self.scm | 13 |
7 files changed, 140 insertions, 163 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/python-build-system.scm b/guix/build/python-build-system.scm index 376ea81f1a..5bb0ba49d5 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -246,8 +246,6 @@ installed with setuptools." (define* (enable-bytecode-determinism #:rest _) "Improve determinism of pyc files." - ;; Set DETERMINISTIC_BUILD to override the embedded mtime in pyc files. - (setenv "DETERMINISTIC_BUILD" "1") ;; Use deterministic hashes for strings, bytes, and datetime objects. (setenv "PYTHONHASHSEED" "0") #t) 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))))))))) diff --git a/guix/gexp.scm b/guix/gexp.scm index ffc976d61b..3a600c3830 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -601,12 +601,6 @@ names and file names suitable for the #:allowed-references argument to allowed-references disallowed-references leaked-env-vars local-build? (substitutable? #t) - - ;; TODO: This parameter is transitional; it's here - ;; to avoid a full rebuild. Remove it on the next - ;; rebuild cycle. - import-creates-derivation? - deprecation-warnings (script-name (string-append name "-builder"))) "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a @@ -701,18 +695,12 @@ The other arguments are as for 'derivation'." extensions)) (modules (if (pair? %modules) (imported-modules %modules - #:derivation? - import-creates-derivation? #:system system #:module-path module-path - #:guile guile-for-build - #:deprecation-warnings - deprecation-warnings) + #:guile guile-for-build) (return #f))) (compiled (if (pair? %modules) (compiled-modules %modules - #:derivation? - import-creates-derivation? #:system system #:module-path module-path #:extensions extensions @@ -1080,15 +1068,7 @@ to a tree suitable for 'interned-file-tree'." #:key (name "file-import") (symlink? #f) (system (%current-system)) - (guile (%guile-for-build)) - - ;; XXX: The only reason we have - ;; #:deprecation-warnings is because (guix - ;; build utils), which we use here, relies - ;; on _IO*, which is deprecated in 2.2. On - ;; the next full-rebuild cycle, we should - ;; disable such warnings unconditionally. - (deprecation-warnings #f)) + (guile (%guile-for-build))) "Return a derivation that imports FILES into STORE. FILES must be a list of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the resulting store path. FILE can be either a file name, or a file-like object, @@ -1128,54 +1108,38 @@ to the source files instead of copying them." #:guile-for-build guile #:local-build? #t - ;; TODO: On the next rebuild cycle, set to "no" - ;; unconditionally. + ;; Avoid deprecation warnings about the use of the _IO* + ;; constants in (guix build utils). #:env-vars - (case deprecation-warnings - ((#f) - '(("GUILE_WARN_DEPRECATED" . "no"))) - ((detailed) - '(("GUILE_WARN_DEPRECATED" . "detailed"))) - (else - '()))))) + '(("GUILE_WARN_DEPRECATED" . "no"))))) (define* (imported-files files #:key (name "file-import") - - ;; TODO: Remove this parameter on the next rebuild - ;; cycle. - (derivation? #f) - ;; The following parameters make sense when creating ;; an actual derivation. (system (%current-system)) - (guile (%guile-for-build)) - (deprecation-warnings #f)) + (guile (%guile-for-build))) "Import FILES into the store and return the resulting derivation or store file name (a derivation is created if and only if some elements of FILES are file-like objects and not local file names.) FILES must be a list of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the resulting store path. FILE can be either a file name, or a file-like object, as returned by 'local-file' for example." - (if (or derivation? - (any (match-lambda - ((_ . (? struct? source)) #t) - (_ #f)) - files)) + (if (any (match-lambda + ((_ . (? struct? source)) #t) + (_ #f)) + files) (imported-files/derivation files #:name name #:symlink? derivation? - #:system system #:guile guile - #:deprecation-warnings deprecation-warnings) + #:system system #:guile guile) (interned-file-tree `(,name directory ,@(file-mapping->tree files))))) (define* (imported-modules modules #:key (name "module-import") - (derivation? #f) ;TODO: remove on next rebuild (system (%current-system)) (guile (%guile-for-build)) - (module-path %load-path) - (deprecation-warnings #f)) + (module-path %load-path)) "Return a derivation that contains the source files of MODULES, a list of module names such as `(ice-9 q)'. All of MODULES must be either names of modules to be found in the MODULE-PATH search path, or a module name followed @@ -1196,14 +1160,11 @@ last one is created from the given <scheme-file> object." (cons f (search-path* module-path f))))) modules))) (imported-files files #:name name - #:derivation? derivation? #:system system - #:guile guile - #:deprecation-warnings deprecation-warnings))) + #:guile guile))) (define* (compiled-modules modules #:key (name "module-import-compiled") - (derivation? #f) ;TODO: remove on next rebuild (system (%current-system)) (guile (%guile-for-build)) (module-path %load-path) @@ -1214,22 +1175,11 @@ corresponding to MODULES. All the MODULES are built in a context where they can refer to each other." (define total (length modules)) - (define build-utils-hack? - ;; To avoid a full rebuild, we limit the fix below to the case where - ;; MODULE-PATH is different from %LOAD-PATH. This happens when building - ;; modules for 'compute-guix-derivation' upon 'guix pull'. TODO: Make - ;; this unconditional on the next rebuild cycle. - (and (member '(guix build utils) modules) - (not (equal? module-path %load-path)))) - (mlet %store-monad ((modules (imported-modules modules - #:derivation? derivation? #:system system #:guile guile #:module-path - module-path - #:deprecation-warnings - deprecation-warnings))) + module-path))) (define build (gexp (begin @@ -1268,46 +1218,34 @@ they can refer to each other." (setvbuf (current-output-port) (cond-expand (guile-2.2 'line) (else _IOLBF))) - (ungexp-splicing - (if build-utils-hack? - (gexp ((define mkdir-p - ;; Capture 'mkdir-p'. - (@ (guix build utils) mkdir-p)))) - '())) + (define mkdir-p + ;; Capture 'mkdir-p'. + (@ (guix build utils) mkdir-p)) ;; Add EXTENSIONS to the search path. - ;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle. - (ungexp-splicing - (if (null? extensions) - '() - (gexp ((set! %load-path - (append (map (lambda (extension) - (string-append extension - "/share/guile/site/" - (effective-version))) - '((ungexp-native-splicing extensions))) - %load-path)) - (set! %load-compiled-path - (append (map (lambda (extension) - (string-append extension "/lib/guile/" - (effective-version) - "/site-ccache")) - '((ungexp-native-splicing extensions))) - %load-compiled-path)))))) + (set! %load-path + (append (map (lambda (extension) + (string-append extension + "/share/guile/site/" + (effective-version))) + '((ungexp-native-splicing extensions))) + %load-path)) + (set! %load-compiled-path + (append (map (lambda (extension) + (string-append extension "/lib/guile/" + (effective-version) + "/site-ccache")) + '((ungexp-native-splicing extensions))) + %load-compiled-path)) (set! %load-path (cons (ungexp modules) %load-path)) - (ungexp-splicing - (if build-utils-hack? - ;; Above we loaded our own (guix build utils) but now we may - ;; need to load a compile a different one. Thus, force a - ;; reload. - (gexp ((let ((utils (ungexp - (file-append modules - "/guix/build/utils.scm")))) - (when (file-exists? utils) - (load utils))))) - '())) + ;; Above we loaded our own (guix build utils) but now we may need to + ;; load a compile a different one. Thus, force a reload. + (let ((utils (string-append (ungexp modules) + "/guix/build/utils.scm"))) + (when (file-exists? utils) + (load utils))) (mkdir (ungexp output)) (chdir (ungexp modules)) diff --git a/guix/packages.scm b/guix/packages.scm index a220b9c476..eab0b3404c 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -628,12 +628,7 @@ specifies modules in scope when evaluating SNIPPET." #:fail-on-error? #t))))) (apply invoke (string-append #+tar "/bin/tar") - "cvf" #$output - ;; The bootstrap xz does not support - ;; threaded compression (introduced in - ;; 5.2.0), but it ignores the extra flag. - (string-append "--use-compress-program=" - #+xz "/bin/xz --threads=0") + "cvfa" #$output ;; avoid non-determinism in the archive "--mtime=@0" "--owner=root:0" @@ -646,9 +641,6 @@ specifies modules in scope when evaluating SNIPPET." (let ((name (tarxz-name original-file-name))) (gexp->derivation name build - ;; TODO: Remove this on the next rebuild cycle. - #:import-creates-derivation? #t - #:graft? #f #:system system #:deprecation-warnings #t ;to avoid a rebuild diff --git a/guix/self.scm b/guix/self.scm index 5ad644b1df..c800c452e6 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -890,16 +890,9 @@ running Guile." 'canonical-package)) (match version - ("2.2.2" - ;; Gross hack to avoid ABI incompatibilities (see - ;; <https://bugs.gnu.org/29570>.) - (module-ref (resolve-interface '(gnu packages guile)) - 'guile-2.2.2)) ("2.2" - ;; Use the latest version, which has fixes for - ;; <https://bugs.gnu.org/30602> and VM stack-marking issues. (canonical-package (module-ref (resolve-interface '(gnu packages guile)) - 'guile-2.2.4))) + 'guile-2.2))) ("2.0" (module-ref (resolve-interface '(gnu packages guile)) 'guile-2.0)))) @@ -927,9 +920,7 @@ is not supported." #:name (string-append "guix-" (shorten version)) #:pull-version pull-version - #:guile-version (match guile-version - ("2.2.2" "2.2") - (version version)) + #:guile-version guile-version #:guile-for-build guile))) (if guix (lower-object guix) |