diff options
| -rw-r--r-- | gnu-system.am | 3 | ||||
| -rw-r--r-- | gnu/packages/commencement.scm | 15 | ||||
| -rw-r--r-- | gnu/packages/ld-wrapper2.in | 201 |
3 files changed, 217 insertions, 2 deletions
diff --git a/gnu-system.am b/gnu-system.am index d92aaaf891..0e23175415 100644 --- a/gnu-system.am +++ b/gnu-system.am @@ -575,7 +575,8 @@ dist_patch_DATA = \ gnu/packages/patches/zathura-plugindir-environment-variable.patch MISC_DISTRO_FILES = \ - gnu/packages/ld-wrapper.in + gnu/packages/ld-wrapper.in \ + gnu/packages/ld-wrapper2.in bootstrapdir = $(guilemoduledir)/gnu/packages/bootstrap bootstrap_x86_64_linuxdir = $(bootstrapdir)/x86_64-linux diff --git a/gnu/packages/commencement.scm b/gnu/packages/commencement.scm index 4342dc56d1..22da2e0fb3 100644 --- a/gnu/packages/commencement.scm +++ b/gnu/packages/commencement.scm @@ -708,6 +708,19 @@ COREUTILS-FINAL vs. COREUTILS, etc." ;;; GCC toolchain. ;;; +(define (fixed-ld-wrapper) + ;; FIXME: In this cycle, a bug was introduced in ld-wrapper: it would + ;; incorrectly flag ~/.guix-profile/lib/libfoo.so as "impure", due to a bug + ;; in its symlink resolution code. To work around that while avoiding a + ;; full rebuild, use an ld-wrapper with the bug-fix for 'gcc-toolchain'. + (let ((orig (car (assoc-ref %final-inputs "ld-wrapper")))) + (package + (inherit orig) + (location (source-properties->location (current-source-location))) + (inputs `(("wrapper" ,(search-path %load-path + "gnu/packages/ld-wrapper2.in")) + ,@(package-inputs orig)))))) + (define (gcc-toolchain gcc) "Return a complete toolchain for GCC." (package @@ -746,7 +759,7 @@ and binaries, plus debugging symbols in the 'debug' output), and Binutils.") ;; install everything that we need, and (2) to make sure ld-wrapper comes ;; before Binutils' ld in the user's profile. (inputs `(("gcc" ,gcc) - ("ld-wrapper" ,(car (assoc-ref %final-inputs "ld-wrapper"))) + ("ld-wrapper" ,(fixed-ld-wrapper)) ("binutils" ,binutils-final) ("libc" ,glibc-final) ("libc-debug" ,glibc-final "debug"))))) diff --git a/gnu/packages/ld-wrapper2.in b/gnu/packages/ld-wrapper2.in new file mode 100644 index 0000000000..2f0e0ab24a --- /dev/null +++ b/gnu/packages/ld-wrapper2.in @@ -0,0 +1,201 @@ +#!@BASH@ +# -*- mode: scheme; coding: utf-8; -*- + +# XXX: We have to go through Bash because there's no command-line switch to +# augment %load-compiled-path, and because of the silly 127-byte limit for +# the shebang line in Linux. +# Use `load-compiled' because `load' (and `-l') doesn't otherwise load our +# .go file (see <http://bugs.gnu.org/12519>). + +main="(@ (gnu build-support ld-wrapper) ld-wrapper)" +exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr (command-line)))" "$@" +!# +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu build-support ld-wrapper) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:export (ld-wrapper)) + +;;; Commentary: +;;; +;;; This is a wrapper for the linker. Its purpose is to inspect the -L and +;;; -l switches passed to the linker, add corresponding -rpath arguments, and +;;; invoke the actual linker with this new set of arguments. +;;; +;;; The alternatives to this hack would be: +;;; +;;; 1. Using $LD_RUN_PATH. However, that would tend to include more than +;;; needed in the RPATH; for instance, given a package with `libfoo' as +;;; an input, all its binaries would have libfoo in their RPATH, +;;; regardless of whether they actually NEED it. +;;; +;;; 2. Use a GCC "lib" spec string such as `%{L*:-rpath %*}', which adds a +;;; `-rpath LIBDIR' argument for each occurrence of `-L LIBDIR'. +;;; However, this doesn't work when $LIBRARY_PATH is used, because the +;;; additional `-L' switches are not matched by the above rule, because +;;; the rule only matches explicit user-provided switches. See +;;; <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for details. +;;; +;;; As a bonus, this wrapper checks for "impurities"--i.e., references to +;;; libraries outside the store. +;;; +;;; Code: + +(define %real-ld + ;; Name of the linker that we wrap. + "@LD@") + +(define %store-directory + ;; File name of the store. + (or (getenv "NIX_STORE") "/gnu/store")) + +(define %temporary-directory + ;; Temporary directory. + (or (getenv "TMPDIR") "/tmp")) + +(define %build-directory + ;; Top build directory when run from a builder. + (getenv "NIX_BUILD_TOP")) + +(define %allow-impurities? + ;; Whether to allow references to libraries outside the store. + (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES")) + +(define %debug? + ;; Whether to emit debugging output. + (getenv "GUIX_LD_WRAPPER_DEBUG")) + +(define %disable-rpath? + ;; Whether to disable automatic '-rpath' addition. + (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH")) + +(define (readlink* file) + ;; Call 'readlink' until the result is not a symlink. + (define %max-symlink-depth 50) + + (let loop ((file file) + (depth 0)) + (define (absolute target) + (if (absolute-file-name? target) + target + (string-append (dirname file) "/" target))) + + (catch 'system-error + (lambda () + (if (>= depth %max-symlink-depth) + file + (loop (absolute (readlink file)) (+ depth 1)))) + (lambda args + (let ((errno (system-error-errno args))) + (if (or (= errno EINVAL) (= errno ENOENT)) + file + (apply throw args))))))) + +(define (pure-file-name? file) + ;; Return #t when FILE is the name of a file either within the store + ;; (possibly via a symlink) or within the build directory. + (let ((file (readlink* file))) + (or (not (string-prefix? "/" file)) + (string-prefix? %store-directory file) + (string-prefix? %temporary-directory file) + (and %build-directory + (string-prefix? %build-directory file))))) + +(define (store-file-name? file) + ;; Return #t when FILE is a store file, possibly indirectly. + (string-prefix? %store-directory (readlink* file))) + +(define (shared-library? file) + ;; Return #t when FILE denotes a shared library. + (or (string-suffix? ".so" file) + (let ((index (string-contains file ".so."))) + ;; Since we cannot use regexps during bootstrap, roll our own. + (and index + (string-every (char-set-union (char-set #\.) char-set:digit) + (string-drop file (+ index 3))))))) + +(define (library-files-linked args) + ;; Return the file names of shared libraries explicitly linked against via + ;; `-l' or with an absolute file name in ARGS. + (define path+files + (fold (lambda (argument result) + (match result + ((library-path . library-files) + (cond ((string-prefix? "-L" argument) ;augment the search path + (cons (append library-path + (list (string-drop argument 2))) + library-files)) + ((string-prefix? "-l" argument) ;add library + (let* ((lib (string-append "lib" + (string-drop argument 2) + ".so")) + (full (search-path library-path lib))) + (if full + (cons library-path + (cons full library-files)) + result))) + ((and (string-prefix? %store-directory argument) + (shared-library? argument)) ;add library + (cons library-path + (cons argument library-files))) + (else + result))))) + (cons '() '()) + args)) + + (match path+files + ((path . files) + (reverse files)))) + +(define (rpath-arguments library-files) + ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of + ;; absolute file names. + (fold-right (lambda (file args) + ;; Add '-rpath' if and only if FILE is in the store; we don't + ;; want to add '-rpath' for files under %BUILD-DIRECTORY or + ;; %TEMPORARY-DIRECTORY because that could leak to installed + ;; files. + (cond ((and (not %disable-rpath?) + (store-file-name? file)) + (cons* "-rpath" (dirname file) args)) + ((or %allow-impurities? + (pure-file-name? file)) + args) + (else + (begin + (format (current-error-port) + "ld-wrapper: error: attempt to use \ +impure library ~s~%" + file) + (exit 1))))) + '() + library-files)) + +(define (ld-wrapper . args) + ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches. + (let* ((libs (library-files-linked args)) + (args (append args (rpath-arguments libs)))) + (when %debug? + (format (current-error-port) + "ld-wrapper: invoking `~a' with ~s~%" + %real-ld args)) + (apply execl %real-ld (basename %real-ld) args))) + +;;; ld-wrapper.scm ends here |