ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 15:36:20 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu: Rename ld-wrapper2 to ld-wrapper.

Browse source 
* 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:
Ludovic Courtès 2015-04-21 21:07:11 +02:00
parent 44fd6ef137
commit cbbb11c8a0
4 changed files with 24 additions and 247 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
gnu-system.am
View file

@ -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

15
gnu/packages/commencement.scm
View file

@ -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")))))

46
gnu/packages/ld-wrapper.in
View file

@ -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)
(if (>= depth %max-symlink-depth) target
file (string-append (dirname file) "/" target)))
(loop (readlink file) (+ depth 1))))
(lambda args
(if (= EINVAL (system-error-errno args))
file
(apply throw args))))))
(define (dereference-symlinks file) (if (>= depth %max-symlink-depth)
;; Same as 'readlink*' but return FILE if the symlink target is invalid or file
;; FILE does not exist. (call-with-values
(catch 'system-error (lambda ()
(lambda () (catch 'system-error
;; When used from a user environment, FILE may refer to (lambda ()
;; ~/.guix-profile/lib/libfoo.so, which is itself a symlink to the (values #t (readlink file)))
;; store. Check whether this is the case. (lambda args
(readlink* file)) (let ((errno (system-error-errno args)))
(lambda args (if (or (= errno EINVAL) (= errno ENOENT))
(if (= ENOENT (system-error-errno args)) (values #f file)
file (apply throw args))))))
(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.

207
gnu/packages/ld-wrapper2.in
View file

@ -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