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

distro: Add an ld' wrapper, to pass missing -rpath' flags.

Browse source 
* distro/ld-wrapper.scm: New file.
* Makefile.am (MODULES): Add it.

* distro/base.scm (ld-wrapper-boot3): New variable.
  (%boot3-inputs): Add LD-WRAPPER-BOOT3.
  (bash-final, guile-final, ld-wrapper): New final.
  (%final-inputs): Use BASH-FINAL; add LD-WRAPPER.
  (gcc-4.7): Remove the `-rpath' trick from the `lib' spec string.
This commit is contained in:
Ludovic Courtès 2012-09-26 18:27:04 +02:00
parent dc8907d8e3
commit 82dc2b9af9
3 changed files with 215 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile.am
View file

@ -35,7 +35,8 @@ MODULES = \
guix/packages.scm \
guix.scm \
distro.scm \
distro/base.scm
distro/base.scm \
distro/ld-wrapper.scm
GOBJECTS = $(MODULES:%.scm=%.go)

79
distro/base.scm
View file

@ -765,17 +765,6 @@ (define-public gcc-4.7
;; 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 @@ (define-public gcc-4.7
"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 @@ (define-public gcc-final
("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 @@ (define-public %final-inputs
("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))))

147
distro/ld-wrapper.scm Normal file
View file

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