mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
gnu: Rename ld-wrapper2 to ld-wrapper.
* gnu/packages/ld-wrapper2.in: Rename to... * gnu/packages/ld-wrapper.in: ... this. * gnu-system.am (MISC_DISTRO_FILES): Remove ld-wrapper2.in. * gnu/packages/commencement.scm (fixed-ld-wrapper): Remove. (gcc-toolchain): Restore pre-77db91ad inputs.
This commit is contained in:
parent
44fd6ef137
commit
cbbb11c8a0
4 changed files with 24 additions and 247 deletions
|
@ -578,8 +578,7 @@ dist_patch_DATA = \
|
||||||
gnu/packages/patches/zathura-plugindir-environment-variable.patch
|
gnu/packages/patches/zathura-plugindir-environment-variable.patch
|
||||||
|
|
||||||
MISC_DISTRO_FILES = \
|
MISC_DISTRO_FILES = \
|
||||||
gnu/packages/ld-wrapper.in \
|
gnu/packages/ld-wrapper.in
|
||||||
gnu/packages/ld-wrapper2.in
|
|
||||||
|
|
||||||
bootstrapdir = $(guilemoduledir)/gnu/packages/bootstrap
|
bootstrapdir = $(guilemoduledir)/gnu/packages/bootstrap
|
||||||
bootstrap_x86_64_linuxdir = $(bootstrapdir)/x86_64-linux
|
bootstrap_x86_64_linuxdir = $(bootstrapdir)/x86_64-linux
|
||||||
|
|
|
@ -708,19 +708,6 @@ (define-public canonical-package
|
||||||
;;; GCC toolchain.
|
;;; 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)
|
(define (gcc-toolchain gcc)
|
||||||
"Return a complete toolchain for GCC."
|
"Return a complete toolchain for GCC."
|
||||||
(package
|
(package
|
||||||
|
@ -759,7 +746,7 @@ (define (gcc-toolchain gcc)
|
||||||
;; install everything that we need, and (2) to make sure ld-wrapper comes
|
;; install everything that we need, and (2) to make sure ld-wrapper comes
|
||||||
;; before Binutils' ld in the user's profile.
|
;; before Binutils' ld in the user's profile.
|
||||||
(inputs `(("gcc" ,gcc)
|
(inputs `(("gcc" ,gcc)
|
||||||
("ld-wrapper" ,(fixed-ld-wrapper))
|
("ld-wrapper" ,(car (assoc-ref %final-inputs "ld-wrapper")))
|
||||||
("binutils" ,binutils-final)
|
("binutils" ,binutils-final)
|
||||||
("libc" ,glibc-final)
|
("libc" ,glibc-final)
|
||||||
("libc-debug" ,glibc-final "debug")))))
|
("libc-debug" ,glibc-final "debug")))))
|
||||||
|
|
|
@ -92,34 +92,32 @@ exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr (command-line))
|
||||||
|
|
||||||
(let loop ((file file)
|
(let loop ((file file)
|
||||||
(depth 0))
|
(depth 0))
|
||||||
(catch 'system-error
|
(define (absolute target)
|
||||||
(lambda ()
|
(if (absolute-file-name? target)
|
||||||
|
target
|
||||||
|
(string-append (dirname file) "/" target)))
|
||||||
|
|
||||||
(if (>= depth %max-symlink-depth)
|
(if (>= depth %max-symlink-depth)
|
||||||
file
|
file
|
||||||
(loop (readlink file) (+ depth 1))))
|
(call-with-values
|
||||||
(lambda args
|
(lambda ()
|
||||||
(if (= EINVAL (system-error-errno args))
|
|
||||||
file
|
|
||||||
(apply throw args))))))
|
|
||||||
|
|
||||||
(define (dereference-symlinks file)
|
|
||||||
;; Same as 'readlink*' but return FILE if the symlink target is invalid or
|
|
||||||
;; FILE does not exist.
|
|
||||||
(catch 'system-error
|
(catch 'system-error
|
||||||
(lambda ()
|
(lambda ()
|
||||||
;; When used from a user environment, FILE may refer to
|
(values #t (readlink file)))
|
||||||
;; ~/.guix-profile/lib/libfoo.so, which is itself a symlink to the
|
|
||||||
;; store. Check whether this is the case.
|
|
||||||
(readlink* file))
|
|
||||||
(lambda args
|
(lambda args
|
||||||
(if (= ENOENT (system-error-errno args))
|
(let ((errno (system-error-errno args)))
|
||||||
file
|
(if (or (= errno EINVAL) (= errno ENOENT))
|
||||||
(apply throw args)))))
|
(values #f file)
|
||||||
|
(apply throw args))))))
|
||||||
|
(lambda (success? target)
|
||||||
|
(if success?
|
||||||
|
(loop (absolute target) (+ depth 1))
|
||||||
|
file))))))
|
||||||
|
|
||||||
(define (pure-file-name? file)
|
(define (pure-file-name? file)
|
||||||
;; Return #t when FILE is the name of a file either within the store
|
;; Return #t when FILE is the name of a file either within the store
|
||||||
;; (possibly via a symlink) or within the build directory.
|
;; (possibly via a symlink) or within the build directory.
|
||||||
(let ((file (dereference-symlinks file)))
|
(let ((file (readlink* file)))
|
||||||
(or (not (string-prefix? "/" file))
|
(or (not (string-prefix? "/" file))
|
||||||
(string-prefix? %store-directory file)
|
(string-prefix? %store-directory file)
|
||||||
(string-prefix? %temporary-directory file)
|
(string-prefix? %temporary-directory file)
|
||||||
|
@ -128,7 +126,7 @@ exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr (command-line))
|
||||||
|
|
||||||
(define (store-file-name? file)
|
(define (store-file-name? file)
|
||||||
;; Return #t when FILE is a store file, possibly indirectly.
|
;; Return #t when FILE is a store file, possibly indirectly.
|
||||||
(string-prefix? %store-directory (dereference-symlinks file)))
|
(string-prefix? %store-directory (readlink* file)))
|
||||||
|
|
||||||
(define (shared-library? file)
|
(define (shared-library? file)
|
||||||
;; Return #t when FILE denotes a shared library.
|
;; Return #t when FILE denotes a shared library.
|
||||||
|
|
|
@ -1,207 +0,0 @@
|
||||||
#!@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)))
|
|
||||||
|
|
||||||
(if (>= depth %max-symlink-depth)
|
|
||||||
file
|
|
||||||
(call-with-values
|
|
||||||
(lambda ()
|
|
||||||
(catch 'system-error
|
|
||||||
(lambda ()
|
|
||||||
(values #t (readlink file)))
|
|
||||||
(lambda args
|
|
||||||
(let ((errno (system-error-errno args)))
|
|
||||||
(if (or (= errno EINVAL) (= errno ENOENT))
|
|
||||||
(values #f file)
|
|
||||||
(apply throw args))))))
|
|
||||||
(lambda (success? target)
|
|
||||||
(if success?
|
|
||||||
(loop (absolute target) (+ depth 1))
|
|
||||||
file))))))
|
|
||||||
|
|
||||||
(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
|
|
Loading…
Reference in a new issue