Commit | Line | Data |
---|---|---|
dfb53ee2 | 1 | #!@BASH@ |
82dc2b9a LC |
2 | # -*- mode: scheme; coding: utf-8; -*- |
3 | ||
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>). | |
2a5739b4 LC |
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>. | |
82dc2b9a | 12 | |
2a5739b4 | 13 | unset GUILE_LOAD_COMPILED_PATH |
dfb53ee2 | 14 | main="(@ (gnu build-support ld-wrapper) ld-wrapper)" |
9bab6bea | 15 | exec @GUILE@ -c "(load-compiled \"@SELF@.go\") (apply $main (cdr (command-line)))" "$@" |
82dc2b9a | 16 | !# |
4155e2a9 | 17 | ;;; GNU Guix --- Functional package management for GNU |
67645383 | 18 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> |
82dc2b9a | 19 | ;;; |
4155e2a9 | 20 | ;;; This file is part of GNU Guix. |
82dc2b9a | 21 | ;;; |
4155e2a9 | 22 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
82dc2b9a LC |
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. | |
26 | ;;; | |
4155e2a9 | 27 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
82dc2b9a LC |
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. | |
31 | ;;; | |
32 | ;;; You should have received a copy of the GNU General Public License | |
4155e2a9 | 33 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
82dc2b9a | 34 | |
dfb53ee2 | 35 | (define-module (gnu build-support ld-wrapper) |
82dc2b9a | 36 | #:use-module (srfi srfi-1) |
d8491ba5 | 37 | #:use-module (ice-9 match) |
696487d6 | 38 | #:autoload (ice-9 rdelim) (read-string) |
82dc2b9a LC |
39 | #:export (ld-wrapper)) |
40 | ||
41 | ;;; Commentary: | |
42 | ;;; | |
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. | |
46 | ;;; | |
47 | ;;; The alternatives to this hack would be: | |
48 | ;;; | |
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. | |
53 | ;;; | |
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. | |
60 | ;;; | |
61 | ;;; As a bonus, this wrapper checks for "impurities"--i.e., references to | |
62 | ;;; libraries outside the store. | |
63 | ;;; | |
64 | ;;; Code: | |
65 | ||
66 | (define %real-ld | |
67 | ;; Name of the linker that we wrap. | |
68 | "@LD@") | |
69 | ||
70 | (define %store-directory | |
71 | ;; File name of the store. | |
8be3b8a3 | 72 | (or (getenv "NIX_STORE") "/gnu/store")) |
82dc2b9a LC |
73 | |
74 | (define %temporary-directory | |
75 | ;; Temporary directory. | |
76 | (or (getenv "TMPDIR") "/tmp")) | |
77 | ||
78 | (define %build-directory | |
79 | ;; Top build directory when run from a builder. | |
80 | (getenv "NIX_BUILD_TOP")) | |
81 | ||
82 | (define %allow-impurities? | |
83 | ;; Whether to allow references to libraries outside the store. | |
84 | (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES")) | |
85 | ||
86 | (define %debug? | |
87 | ;; Whether to emit debugging output. | |
88 | (getenv "GUIX_LD_WRAPPER_DEBUG")) | |
89 | ||
71b67168 LC |
90 | (define %disable-rpath? |
91 | ;; Whether to disable automatic '-rpath' addition. | |
92 | (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH")) | |
93 | ||
41fc0eb9 LC |
94 | (define (readlink* file) |
95 | ;; Call 'readlink' until the result is not a symlink. | |
cfbf7877 LC |
96 | (define %max-symlink-depth 50) |
97 | ||
98 | (let loop ((file file) | |
99 | (depth 0)) | |
cbbb11c8 LC |
100 | (define (absolute target) |
101 | (if (absolute-file-name? target) | |
102 | target | |
103 | (string-append (dirname file) "/" target))) | |
104 | ||
105 | (if (>= depth %max-symlink-depth) | |
106 | file | |
107 | (call-with-values | |
108 | (lambda () | |
109 | (catch 'system-error | |
110 | (lambda () | |
111 | (values #t (readlink file))) | |
112 | (lambda args | |
113 | (let ((errno (system-error-errno args))) | |
114 | (if (or (= errno EINVAL) (= errno ENOENT)) | |
115 | (values #f file) | |
116 | (apply throw args)))))) | |
117 | (lambda (success? target) | |
118 | (if success? | |
119 | (loop (absolute target) (+ depth 1)) | |
120 | file)))))) | |
41fc0eb9 LC |
121 | |
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. | |
cbbb11c8 | 125 | (let ((file (readlink* file))) |
cfbf7877 LC |
126 | (or (not (string-prefix? "/" file)) |
127 | (string-prefix? %store-directory file) | |
128 | (string-prefix? %temporary-directory file) | |
41fc0eb9 LC |
129 | (and %build-directory |
130 | (string-prefix? %build-directory file))))) | |
82dc2b9a | 131 | |
51d0cd9b LC |
132 | (define (store-file-name? file) |
133 | ;; Return #t when FILE is a store file, possibly indirectly. | |
cbbb11c8 | 134 | (string-prefix? %store-directory (readlink* file))) |
51d0cd9b | 135 | |
f307947e LC |
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. | |
141 | (and index | |
142 | (string-every (char-set-union (char-set #\.) char-set:digit) | |
143 | (string-drop file (+ index 3))))))) | |
144 | ||
e946b609 LC |
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) | |
151 | (path '())) | |
152 | (match args | |
153 | (() | |
154 | (reverse path)) | |
155 | (("-L" directory . rest) | |
156 | (loop rest (cons directory path))) | |
157 | ((argument . rest) | |
158 | (if (string-prefix? "-L" argument) ;augment the search path | |
159 | (loop rest | |
160 | (cons (string-drop argument 2) path)) | |
161 | (loop rest path)))))) | |
162 | ||
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 | |
166 | ;; in LIBRARY-PATH. | |
167 | (define files+args | |
d8491ba5 LC |
168 | (fold (lambda (argument result) |
169 | (match result | |
e946b609 LC |
170 | ((library-files ((and flag |
171 | (or "-dynamic-linker" "-plugin")) | |
172 | . rest)) | |
b5616bc3 LC |
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>. | |
e946b609 | 176 | (list library-files |
b5616bc3 | 177 | (cons* argument flag rest))) |
e946b609 LC |
178 | ((library-files previous-args) |
179 | (cond ((string-prefix? "-l" argument) ;add library | |
d8491ba5 LC |
180 | (let* ((lib (string-append "lib" |
181 | (string-drop argument 2) | |
182 | ".so")) | |
183 | (full (search-path library-path lib))) | |
e946b609 | 184 | (list (if full |
4a2b74bf LC |
185 | (cons full library-files) |
186 | library-files) | |
187 | (cons argument previous-args)))) | |
d8491ba5 | 188 | ((and (string-prefix? %store-directory argument) |
f307947e | 189 | (shared-library? argument)) ;add library |
e946b609 | 190 | (list (cons argument library-files) |
4a2b74bf | 191 | (cons argument previous-args))) |
d8491ba5 | 192 | (else |
e946b609 | 193 | (list library-files |
4a2b74bf | 194 | (cons argument previous-args))))))) |
e946b609 | 195 | (list '() '()) |
d8491ba5 LC |
196 | args)) |
197 | ||
e946b609 LC |
198 | (match files+args |
199 | ((files arguments) | |
d8491ba5 LC |
200 | (reverse files)))) |
201 | ||
202 | (define (rpath-arguments library-files) | |
203 | ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of | |
204 | ;; absolute file names. | |
82dc2b9a | 205 | (fold-right (lambda (file args) |
51d0cd9b LC |
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 | |
209 | ;; files. | |
71b67168 LC |
210 | (cond ((and (not %disable-rpath?) |
211 | (store-file-name? file)) | |
51d0cd9b LC |
212 | (cons* "-rpath" (dirname file) args)) |
213 | ((or %allow-impurities? | |
214 | (pure-file-name? file)) | |
215 | args) | |
216 | (else | |
217 | (begin | |
218 | (format (current-error-port) | |
219 | "ld-wrapper: error: attempt to use \ | |
1a5e07c3 LC |
220 | library outside of ~a: ~s~%" |
221 | %store-directory file) | |
51d0cd9b | 222 | (exit 1))))) |
82dc2b9a LC |
223 | '() |
224 | library-files)) | |
225 | ||
696487d6 LC |
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) | |
230 | (when %debug? | |
231 | (format (current-error-port) | |
232 | "ld-wrapper: attempting to read arguments from '~a'~%" file)) | |
233 | ||
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))) | |
237 | ||
238 | (define result | |
239 | (fold-right (lambda (arg result) | |
240 | (if (string-prefix? "@" arg) | |
241 | (let ((file (string-drop arg 1))) | |
242 | (append (catch 'system-error | |
243 | (lambda () | |
244 | (response-file-arguments file)) | |
245 | (lambda args | |
246 | ;; FILE doesn't exist or cannot be read so | |
247 | ;; leave ARG as is. | |
248 | (list arg))) | |
249 | result)) | |
250 | (cons arg result))) | |
251 | '() | |
252 | args)) | |
253 | ||
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) | |
257 | result | |
258 | (expand-arguments result))) | |
259 | ||
82dc2b9a LC |
260 | (define (ld-wrapper . args) |
261 | ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches. | |
696487d6 LC |
262 | (let* ((args (expand-arguments args)) |
263 | (path (library-search-path args)) | |
e946b609 | 264 | (libs (library-files-linked args path)) |
d8491ba5 LC |
265 | (args (append args (rpath-arguments libs)))) |
266 | (when %debug? | |
e946b609 LC |
267 | (format (current-error-port) |
268 | "ld-wrapper: library search path: ~s~%" path) | |
4267c637 LC |
269 | (format (current-error-port) |
270 | "ld-wrapper: libraries linked: ~s~%" libs) | |
d8491ba5 LC |
271 | (format (current-error-port) |
272 | "ld-wrapper: invoking `~a' with ~s~%" | |
67645383 LC |
273 | %real-ld args) |
274 | (force-output (current-error-port))) | |
82dc2b9a LC |
275 | (apply execl %real-ld (basename %real-ld) args))) |
276 | ||
277 | ;;; ld-wrapper.scm ends here |