diff options
Diffstat (limited to 'distro')
| -rw-r--r-- | distro/base.scm | 79 | ||||
| -rw-r--r-- | distro/ld-wrapper.scm | 147 |
2 files changed, 213 insertions, 13 deletions
diff --git a/distro/base.scm b/distro/base.scm index d6cb8b3170..37443c1f55 100644 --- a/distro/base.scm +++ b/distro/base.scm @@ -765,17 +765,6 @@ BFD (Binary File Descriptor) library, `gprof', `nm', `strip', etc.") ;; Tell where to find libstdc++, libc, and `?crt*.o', except ;; `crt{begin,end}.o', which come with GCC. - ;; - ;; The `%{L*:-rpath %*}' rule adds a `-rpath LIBDIR' argument - ;; for each occurrence of `-L LIBDIR'. We could avoid - ;; `-rpath' altogether and instead use the `LD_RUN_PATH' - ;; environment variable, but 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. See - ;; <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for - ;; details. ;; XXX: For crt*.o, use `STANDARD_STARTFILE_PREFIX' instead? See ;; <http://www.linuxfromscratch.org/lfs/view/stable/chapter05/gcc-pass1.html>. @@ -784,7 +773,7 @@ BFD (Binary File Descriptor) library, `gprof', `nm', `strip', etc.") "gcc/config/i386/gnu-user64.h") (("#define LIB_SPEC (.*)$" _ suffix) (format #f "#define LIB_SPEC \"-L~a/lib -rpath=~a/lib \ --rpath=~a/lib64 -rpath=~a/lib %{L*:-rpath %*}\" ~a~%" +-rpath=~a/lib64 -rpath=~a/lib \" ~a~%" libc libc out out suffix)) (("([^ ]*)crt([^\\.])\\.o" _ prefix suffix) (string-append libc "/lib/" prefix "crt" suffix ".o")))) @@ -1678,11 +1667,74 @@ exec ~a/bin/~a-gcc -B~a/lib -Wl,-dynamic-linker -Wl,~a/lib/~a \"$@\"~%" ("binutils" ,binutils-final) ,@%boot2-inputs)))) +(define ld-wrapper-boot3 + ;; A linker wrapper that uses the bootstrap Guile. + (package + (name "ld-wrapper-boot3") + (version "0") + (source #f) + (build-system trivial-build-system) + (inputs `(("binutils" ,binutils-final) + ("guile" ,(nixpkgs-derivation* "guile")) + ("wrapper" ,(search-path %load-path "distro/ld-wrapper.scm")))) + (arguments + `(#:modules ((guix build utils)) + #:builder (begin + (use-modules (guix build utils) + (system base compile)) + + (let* ((out (assoc-ref %outputs "out")) + (bin (string-append out "/bin")) + (ld (string-append bin "/ld")) + (go (string-append bin "/ld.go"))) + + (setvbuf (current-output-port) _IOLBF) + (format #t "building ~s/bin/ld wrapper in ~s~%" + (assoc-ref %build-inputs "binutils") + out) + + (mkdir out) (mkdir bin) + (copy-file (assoc-ref %build-inputs "wrapper") ld) + (substitute* ld + (("@GUILE@") + (string-append (assoc-ref %build-inputs "guile") + "/bin/guile")) + (("@LD@") + (string-append (assoc-ref %build-inputs "binutils") + "/bin/ld"))) + (chmod ld #o555) + (compile-file ld #:output-file go))))) + (description "The linker wrapper") + (long-description + "The linker wrapper (or `ld-wrapper') wraps the linker to add any +missing `-rpath' flags, and to detect any misuse of libraries outside of the +store.") + (home-page #f) + (license "GPLv3+"))) + (define %boot3-inputs ;; 4th stage inputs. `(("gcc" ,gcc-final) + ("ld-wrapper" ,ld-wrapper-boot3) ,@(alist-delete "gcc" %boot2-inputs))) +(define-public bash-final + (package-with-explicit-inputs bash %boot3-inputs + (current-source-location))) + +(define-public guile-final + (package-with-explicit-inputs guile-2.0 + `(("bash" ,bash-final) + ,@(alist-delete "bash" %boot3-inputs)) + (current-source-location))) + +(define-public ld-wrapper + ;; The final `ld' wrapper, which uses the final Guile. + (package (inherit ld-wrapper-boot3) + (name "ld-wrapper") + (inputs `(("guile" ,guile-final) + ,@(alist-delete "guile" (package-inputs ld-wrapper-boot3)))))) + (define-public %final-inputs ;; Final derivations used as implicit inputs by `gnu-build-system'. ;; FIXME: Build bash before the others, otherwise patch-shebangs uses it in @@ -1701,10 +1753,11 @@ exec ~a/bin/~a-gcc -B~a/lib -Wl,-dynamic-linker -Wl,~a/lib/~a \"$@\"~%" ("coreutils" ,coreutils) ("sed" ,sed) ("grep" ,grep) - ("bash" ,bash) ("findutils" ,findutils) ("gawk" ,gawk) ("make" ,gnu-make))) + ("bash" ,bash-final) + ("ld-wrapper" ,ld-wrapper) ("binutils" ,binutils-final) ("gcc" ,gcc-final) ("libc" ,glibc-final)))) diff --git a/distro/ld-wrapper.scm b/distro/ld-wrapper.scm new file mode 100644 index 0000000000..9d3e8008b3 --- /dev/null +++ b/distro/ld-wrapper.scm @@ -0,0 +1,147 @@ +#!/bin/sh +# -*- 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="(@ (distro ld-wrapper) ld-wrapper)" +exec @GUILE@ -c "(load-compiled \"$0.go\") (apply $main (cdr (command-line)))" "$@" +!# +;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- +;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of Guix. +;;; +;;; 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. +;;; +;;; 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 Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (distro ld-wrapper) + #:use-module (srfi srfi-1) + #: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") "/nix/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 (pure-file-name? file) + ;; Return #t when FILE is the name of a file either within the store or + ;; within the build directory. + (or (not (string-prefix? "/" file)) + (string-prefix? %store-directory file) + (string-prefix? %temporary-directory file) + (and %build-directory + (string-prefix? %build-directory file)))) + +(define (switch-arguments switch args) + ;; Return the arguments passed for the occurrences of SWITCH--e.g., + ;; "-L"--in ARGS. + (let ((prefix-len (string-length switch))) + (fold-right (lambda (arg path) + (if (string-prefix? switch arg) + (cons (substring arg prefix-len) path) + path)) + '() + args))) + +(define (library-path args) + ;; Return the library search path extracted from `-L' switches in ARGS. + ;; Note: allow references to out-of-store directories. When this leads to + ;; actual impurities, this is caught later. + (switch-arguments "-L" args)) + +(define (library-files-linked args) + ;; Return the file names of shared libraries explicitly linked against via + ;; `-l' in ARGS. + (map (lambda (lib) + (string-append "lib" lib ".so")) + (switch-arguments "-l" args))) + +(define (rpath-arguments lib-path library-files) + ;; Return the `-rpath' argument list for each of LIBRARY-FILES found in + ;; LIB-PATH. + (fold-right (lambda (file args) + (let ((absolute (search-path lib-path file))) + (if absolute + (if (or %allow-impurities? + (pure-file-name? absolute)) + (cons* "-rpath" (dirname absolute) + args) + (begin + (format (current-error-port) + "ld-wrapper: error: attempt to use impure library ~s~%" + absolute) + (exit 1))) + args))) + '() + library-files)) + +(define (ld-wrapper . args) + ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches. + (let* ((lib-path (library-path args)) + (libs (library-files-linked args)) + (args (append args (rpath-arguments lib-path libs)))) + (if %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 |