2 # -*- mode: scheme; coding: utf-8; -*-
4 # XXX: We have to go through Bash because there's no command-line switch to
5 # augment %load-compiled-path, and because of the silly 127-byte limit for
6 # the shebang line in Linux.
7 # Use `load-compiled' because `load' (and `-l') doesn't otherwise load our
8 # .go file (see <http://bugs.gnu.org/12519>).
9 # Unset 'GUILE_LOAD_COMPILED_PATH' to make sure we do not stumble upon
10 # incompatible .go files. See
11 # <https://lists.gnu.org/archive/html/guile-devel/2016-03/msg00000.html>.
13 unset GUILE_LOAD_COMPILED_PATH
14 main="(@ (gnu build-support ld-wrapper) ld-wrapper)"
15 exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr (command-line)))" "$@"
17 ;;; GNU Guix --- Functional package management for GNU
18 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
20 ;;; This file is part of GNU Guix.
22 ;;; GNU Guix is free software; you can redistribute it and/or modify it
23 ;;; under the terms of the GNU General Public License as published by
24 ;;; the Free Software Foundation; either version 3 of the License, or (at
25 ;;; your option) any later version.
27 ;;; GNU Guix is distributed in the hope that it will be useful, but
28 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
29 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
30 ;;; GNU General Public License for more details.
32 ;;; You should have received a copy of the GNU General Public License
33 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
35 (define-module (gnu build-support ld-wrapper)
36 #:use-module (srfi srfi-1)
37 #:use-module (ice-9 match)
38 #:autoload (ice-9 rdelim) (read-string)
39 #:export (ld-wrapper))
43 ;;; This is a wrapper for the linker. Its purpose is to inspect the -L and
44 ;;; -l switches passed to the linker, add corresponding -rpath arguments, and
45 ;;; invoke the actual linker with this new set of arguments.
47 ;;; The alternatives to this hack would be:
49 ;;; 1. Using $LD_RUN_PATH. However, that would tend to include more than
50 ;;; needed in the RPATH; for instance, given a package with `libfoo' as
51 ;;; an input, all its binaries would have libfoo in their RPATH,
52 ;;; regardless of whether they actually NEED it.
54 ;;; 2. Use a GCC "lib" spec string such as `%{L*:-rpath %*}', which adds a
55 ;;; `-rpath LIBDIR' argument for each occurrence of `-L LIBDIR'.
56 ;;; However, this doesn't work when $LIBRARY_PATH is used, because the
57 ;;; additional `-L' switches are not matched by the above rule, because
58 ;;; the rule only matches explicit user-provided switches. See
59 ;;; <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for details.
61 ;;; As a bonus, this wrapper checks for "impurities"--i.e., references to
62 ;;; libraries outside the store.
67 ;; Name of the linker that we wrap.
70 (define %store-directory
71 ;; File name of the store.
72 (or (getenv "NIX_STORE") "/gnu/store"))
74 (define %temporary-directory
75 ;; Temporary directory.
76 (or (getenv "TMPDIR") "/tmp"))
78 (define %build-directory
79 ;; Top build directory when run from a builder.
80 (getenv "NIX_BUILD_TOP"))
82 (define %allow-impurities?
83 ;; Whether to allow references to libraries outside the store.
84 (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES"))
87 ;; Whether to emit debugging output.
88 (getenv "GUIX_LD_WRAPPER_DEBUG"))
90 (define %disable-rpath?
91 ;; Whether to disable automatic '-rpath' addition.
92 (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH"))
94 (define (readlink* file)
95 ;; Call 'readlink' until the result is not a symlink.
96 (define %max-symlink-depth 50)
98 (let loop ((file file)
100 (define (absolute target)
101 (if (absolute-file-name? target)
103 (string-append (dirname file) "/" target)))
105 (if (>= depth %max-symlink-depth)
111 (values #t (readlink file)))
113 (let ((errno (system-error-errno args)))
114 (if (or (= errno EINVAL) (= errno ENOENT))
116 (apply throw args))))))
117 (lambda (success? target)
119 (loop (absolute target) (+ depth 1))
122 (define (pure-file-name? file)
123 ;; Return #t when FILE is the name of a file either within the store
124 ;; (possibly via a symlink) or within the build directory.
125 (let ((file (readlink* file)))
126 (or (not (string-prefix? "/" file))
127 (string-prefix? %store-directory file)
128 (string-prefix? %temporary-directory file)
129 (and %build-directory
130 (string-prefix? %build-directory file)))))
132 (define (store-file-name? file)
133 ;; Return #t when FILE is a store file, possibly indirectly.
134 (string-prefix? %store-directory (readlink* file)))
136 (define (shared-library? file)
137 ;; Return #t when FILE denotes a shared library.
138 (or (string-suffix? ".so" file)
139 (let ((index (string-contains file ".so.")))
140 ;; Since we cannot use regexps during bootstrap, roll our own.
142 (string-every (char-set-union (char-set #\.) char-set:digit)
143 (string-drop file (+ index 3)))))))
145 (define (library-search-path args)
146 ;; Return the library search path as a list of directory names. The GNU ld
147 ;; manual notes that "[a]ll `-L' options apply to all `-l' options,
148 ;; regardless of the order in which the options appear", so we must compute
149 ;; the search path independently of the -l options.
150 (let loop ((args args)
155 (("-L" directory . rest)
156 (loop rest (cons directory path)))
158 (if (string-prefix? "-L" argument) ;augment the search path
160 (cons (string-drop argument 2) path))
161 (loop rest path))))))
163 (define (library-files-linked args library-path)
164 ;; Return the absolute file names of shared libraries explicitly linked
165 ;; against via `-l' or with an absolute file name in ARGS, looking them up
168 (fold (lambda (argument result)
170 ((library-files ((and flag
171 (or "-dynamic-linker" "-plugin"))
173 ;; When passed '-dynamic-linker ld.so', ignore 'ld.so'; when
174 ;; passed '-plugin liblto_plugin.so', ignore
175 ;; 'liblto_plugin.so'. See <http://bugs.gnu.org/20102>.
177 (cons* argument flag rest)))
178 ((library-files previous-args)
179 (cond ((string-prefix? "-l" argument) ;add library
180 (let* ((lib (string-append "lib"
181 (string-drop argument 2)
183 (full (search-path library-path lib)))
185 (cons full library-files)
187 (cons argument previous-args))))
188 ((and (string-prefix? %store-directory argument)
189 (shared-library? argument)) ;add library
190 (list (cons argument library-files)
191 (cons argument previous-args)))
194 (cons argument previous-args)))))))
202 (define (rpath-arguments library-files)
203 ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of
204 ;; absolute file names.
205 (fold-right (lambda (file args)
206 ;; Add '-rpath' if and only if FILE is in the store; we don't
207 ;; want to add '-rpath' for files under %BUILD-DIRECTORY or
208 ;; %TEMPORARY-DIRECTORY because that could leak to installed
210 (cond ((and (not %disable-rpath?)
211 (store-file-name? file))
212 (cons* "-rpath" (dirname file) args))
213 ((or %allow-impurities?
214 (pure-file-name? file))
218 (format (current-error-port)
219 "ld-wrapper: error: attempt to use \
226 (define (expand-arguments args)
227 ;; Expand ARGS such that "response file" arguments, such as "@args.txt", are
228 ;; expanded (info "(gcc) Overall Options").
229 (define (response-file-arguments file)
231 (format (current-error-port)
232 "ld-wrapper: attempting to read arguments from '~a'~%" file))
234 ;; FIXME: Options can contain whitespace if they are protected by single
235 ;; or double quotes; this is not implemented here.
236 (string-tokenize (call-with-input-file file read-string)))
239 (fold-right (lambda (arg result)
240 (if (string-prefix? "@" arg)
241 (let ((file (string-drop arg 1)))
242 (append (catch 'system-error
244 (response-file-arguments file))
246 ;; FILE doesn't exist or cannot be read so
254 ;; If there are "@" arguments in RESULT *and* we can expand them (they don't
255 ;; refer to nonexistent files), then recurse.
256 (if (equal? result args)
258 (expand-arguments result)))
260 (define (ld-wrapper . args)
261 ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches.
262 (let* ((args (expand-arguments args))
263 (path (library-search-path args))
264 (libs (library-files-linked args path))
265 (args (append args (rpath-arguments libs))))
267 (format (current-error-port)
268 "ld-wrapper: library search path: ~s~%" path)
269 (format (current-error-port)
270 "ld-wrapper: libraries linked: ~s~%" libs)
271 (format (current-error-port)
272 "ld-wrapper: invoking `~a' with ~s~%"
274 (apply execl %real-ld (basename %real-ld) args)))
276 ;;; ld-wrapper.scm ends here