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> |
feb8c5da | 19 | ;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com> |
82dc2b9a | 20 | ;;; |
4155e2a9 | 21 | ;;; This file is part of GNU Guix. |
82dc2b9a | 22 | ;;; |
4155e2a9 | 23 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
82dc2b9a LC |
24 | ;;; under the terms of the GNU General Public License as published by |
25 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
26 | ;;; your option) any later version. | |
27 | ;;; | |
4155e2a9 | 28 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
82dc2b9a LC |
29 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
30 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
31 | ;;; GNU General Public License for more details. | |
32 | ;;; | |
33 | ;;; You should have received a copy of the GNU General Public License | |
4155e2a9 | 34 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
82dc2b9a | 35 | |
dfb53ee2 | 36 | (define-module (gnu build-support ld-wrapper) |
82dc2b9a | 37 | #:use-module (srfi srfi-1) |
d8491ba5 | 38 | #:use-module (ice-9 match) |
feb8c5da | 39 | #:autoload (ice-9 rdelim) (read-delimited) |
82dc2b9a LC |
40 | #:export (ld-wrapper)) |
41 | ||
42 | ;;; Commentary: | |
43 | ;;; | |
44 | ;;; This is a wrapper for the linker. Its purpose is to inspect the -L and | |
45 | ;;; -l switches passed to the linker, add corresponding -rpath arguments, and | |
46 | ;;; invoke the actual linker with this new set of arguments. | |
47 | ;;; | |
48 | ;;; The alternatives to this hack would be: | |
49 | ;;; | |
50 | ;;; 1. Using $LD_RUN_PATH. However, that would tend to include more than | |
51 | ;;; needed in the RPATH; for instance, given a package with `libfoo' as | |
52 | ;;; an input, all its binaries would have libfoo in their RPATH, | |
53 | ;;; regardless of whether they actually NEED it. | |
54 | ;;; | |
55 | ;;; 2. Use a GCC "lib" spec string such as `%{L*:-rpath %*}', which adds a | |
56 | ;;; `-rpath LIBDIR' argument for each occurrence of `-L LIBDIR'. | |
57 | ;;; However, this doesn't work when $LIBRARY_PATH is used, because the | |
58 | ;;; additional `-L' switches are not matched by the above rule, because | |
59 | ;;; the rule only matches explicit user-provided switches. See | |
60 | ;;; <http://gcc.gnu.org/ml/gcc-help/2012-09/msg00110.html> for details. | |
61 | ;;; | |
62 | ;;; As a bonus, this wrapper checks for "impurities"--i.e., references to | |
63 | ;;; libraries outside the store. | |
64 | ;;; | |
65 | ;;; Code: | |
66 | ||
67 | (define %real-ld | |
68 | ;; Name of the linker that we wrap. | |
69 | "@LD@") | |
70 | ||
71 | (define %store-directory | |
72 | ;; File name of the store. | |
8be3b8a3 | 73 | (or (getenv "NIX_STORE") "/gnu/store")) |
82dc2b9a LC |
74 | |
75 | (define %temporary-directory | |
76 | ;; Temporary directory. | |
77 | (or (getenv "TMPDIR") "/tmp")) | |
78 | ||
79 | (define %build-directory | |
80 | ;; Top build directory when run from a builder. | |
81 | (getenv "NIX_BUILD_TOP")) | |
82 | ||
83 | (define %allow-impurities? | |
84 | ;; Whether to allow references to libraries outside the store. | |
d0a2db47 LC |
85 | ;; Allow them by default for convenience. |
86 | (let ((value (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES"))) | |
87 | (or (not value) | |
88 | (let ((value (string-downcase value))) | |
89 | (cond ((member value '("yes" "y" "t" "true" "1")) | |
90 | #t) | |
91 | ((member value '("no" "n" "f" "false" "0")) | |
92 | #f) | |
93 | (else | |
94 | (format (current-error-port) | |
95 | "ld-wrapper: ~s: invalid value for \ | |
96 | 'GUIX_LD_WRAPPER_ALLOW_IMPURITIES'~%" | |
97 | value))))))) | |
82dc2b9a LC |
98 | |
99 | (define %debug? | |
100 | ;; Whether to emit debugging output. | |
101 | (getenv "GUIX_LD_WRAPPER_DEBUG")) | |
102 | ||
71b67168 LC |
103 | (define %disable-rpath? |
104 | ;; Whether to disable automatic '-rpath' addition. | |
105 | (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH")) | |
106 | ||
41fc0eb9 LC |
107 | (define (readlink* file) |
108 | ;; Call 'readlink' until the result is not a symlink. | |
cfbf7877 LC |
109 | (define %max-symlink-depth 50) |
110 | ||
111 | (let loop ((file file) | |
112 | (depth 0)) | |
cbbb11c8 LC |
113 | (define (absolute target) |
114 | (if (absolute-file-name? target) | |
115 | target | |
116 | (string-append (dirname file) "/" target))) | |
117 | ||
118 | (if (>= depth %max-symlink-depth) | |
119 | file | |
120 | (call-with-values | |
121 | (lambda () | |
122 | (catch 'system-error | |
123 | (lambda () | |
124 | (values #t (readlink file))) | |
125 | (lambda args | |
126 | (let ((errno (system-error-errno args))) | |
127 | (if (or (= errno EINVAL) (= errno ENOENT)) | |
128 | (values #f file) | |
129 | (apply throw args)))))) | |
130 | (lambda (success? target) | |
131 | (if success? | |
132 | (loop (absolute target) (+ depth 1)) | |
133 | file)))))) | |
41fc0eb9 LC |
134 | |
135 | (define (pure-file-name? file) | |
136 | ;; Return #t when FILE is the name of a file either within the store | |
137 | ;; (possibly via a symlink) or within the build directory. | |
cbbb11c8 | 138 | (let ((file (readlink* file))) |
cfbf7877 LC |
139 | (or (not (string-prefix? "/" file)) |
140 | (string-prefix? %store-directory file) | |
141 | (string-prefix? %temporary-directory file) | |
41fc0eb9 LC |
142 | (and %build-directory |
143 | (string-prefix? %build-directory file))))) | |
82dc2b9a | 144 | |
51d0cd9b LC |
145 | (define (store-file-name? file) |
146 | ;; Return #t when FILE is a store file, possibly indirectly. | |
cbbb11c8 | 147 | (string-prefix? %store-directory (readlink* file))) |
51d0cd9b | 148 | |
f307947e LC |
149 | (define (shared-library? file) |
150 | ;; Return #t when FILE denotes a shared library. | |
151 | (or (string-suffix? ".so" file) | |
152 | (let ((index (string-contains file ".so."))) | |
153 | ;; Since we cannot use regexps during bootstrap, roll our own. | |
154 | (and index | |
155 | (string-every (char-set-union (char-set #\.) char-set:digit) | |
156 | (string-drop file (+ index 3))))))) | |
157 | ||
e946b609 LC |
158 | (define (library-search-path args) |
159 | ;; Return the library search path as a list of directory names. The GNU ld | |
160 | ;; manual notes that "[a]ll `-L' options apply to all `-l' options, | |
161 | ;; regardless of the order in which the options appear", so we must compute | |
162 | ;; the search path independently of the -l options. | |
163 | (let loop ((args args) | |
164 | (path '())) | |
165 | (match args | |
166 | (() | |
167 | (reverse path)) | |
168 | (("-L" directory . rest) | |
169 | (loop rest (cons directory path))) | |
170 | ((argument . rest) | |
171 | (if (string-prefix? "-L" argument) ;augment the search path | |
172 | (loop rest | |
173 | (cons (string-drop argument 2) path)) | |
174 | (loop rest path)))))) | |
175 | ||
176 | (define (library-files-linked args library-path) | |
177 | ;; Return the absolute file names of shared libraries explicitly linked | |
178 | ;; against via `-l' or with an absolute file name in ARGS, looking them up | |
179 | ;; in LIBRARY-PATH. | |
180 | (define files+args | |
d8491ba5 LC |
181 | (fold (lambda (argument result) |
182 | (match result | |
e946b609 LC |
183 | ((library-files ((and flag |
184 | (or "-dynamic-linker" "-plugin")) | |
185 | . rest)) | |
b5616bc3 LC |
186 | ;; When passed '-dynamic-linker ld.so', ignore 'ld.so'; when |
187 | ;; passed '-plugin liblto_plugin.so', ignore | |
188 | ;; 'liblto_plugin.so'. See <http://bugs.gnu.org/20102>. | |
e946b609 | 189 | (list library-files |
b5616bc3 | 190 | (cons* argument flag rest))) |
e946b609 LC |
191 | ((library-files previous-args) |
192 | (cond ((string-prefix? "-l" argument) ;add library | |
d8491ba5 LC |
193 | (let* ((lib (string-append "lib" |
194 | (string-drop argument 2) | |
195 | ".so")) | |
196 | (full (search-path library-path lib))) | |
e946b609 | 197 | (list (if full |
4a2b74bf LC |
198 | (cons full library-files) |
199 | library-files) | |
200 | (cons argument previous-args)))) | |
d8491ba5 | 201 | ((and (string-prefix? %store-directory argument) |
f307947e | 202 | (shared-library? argument)) ;add library |
e946b609 | 203 | (list (cons argument library-files) |
4a2b74bf | 204 | (cons argument previous-args))) |
d8491ba5 | 205 | (else |
e946b609 | 206 | (list library-files |
4a2b74bf | 207 | (cons argument previous-args))))))) |
e946b609 | 208 | (list '() '()) |
d8491ba5 LC |
209 | args)) |
210 | ||
e946b609 LC |
211 | (match files+args |
212 | ((files arguments) | |
d8491ba5 LC |
213 | (reverse files)))) |
214 | ||
215 | (define (rpath-arguments library-files) | |
216 | ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of | |
217 | ;; absolute file names. | |
82dc2b9a | 218 | (fold-right (lambda (file args) |
51d0cd9b LC |
219 | ;; Add '-rpath' if and only if FILE is in the store; we don't |
220 | ;; want to add '-rpath' for files under %BUILD-DIRECTORY or | |
221 | ;; %TEMPORARY-DIRECTORY because that could leak to installed | |
222 | ;; files. | |
71b67168 LC |
223 | (cond ((and (not %disable-rpath?) |
224 | (store-file-name? file)) | |
51d0cd9b LC |
225 | (cons* "-rpath" (dirname file) args)) |
226 | ((or %allow-impurities? | |
227 | (pure-file-name? file)) | |
228 | args) | |
229 | (else | |
230 | (begin | |
231 | (format (current-error-port) | |
232 | "ld-wrapper: error: attempt to use \ | |
1a5e07c3 LC |
233 | library outside of ~a: ~s~%" |
234 | %store-directory file) | |
51d0cd9b | 235 | (exit 1))))) |
82dc2b9a LC |
236 | '() |
237 | library-files)) | |
238 | ||
696487d6 LC |
239 | (define (expand-arguments args) |
240 | ;; Expand ARGS such that "response file" arguments, such as "@args.txt", are | |
241 | ;; expanded (info "(gcc) Overall Options"). | |
242 | (define (response-file-arguments file) | |
feb8c5da MB |
243 | (define (tokenize port) |
244 | ;; Return a list of all strings found in PORT. Quote characters are | |
245 | ;; removed, but whitespaces within quoted strings are preserved. | |
246 | (let loop ((tokens '())) | |
247 | (let* ((token+delimiter (read-delimited " '\"\n" port 'split)) | |
248 | (token (car token+delimiter)) | |
249 | (delim (cdr token+delimiter))) | |
250 | (if (eof-object? token) | |
251 | (reverse tokens) | |
252 | (case delim | |
253 | ((#\") (loop (cons (read-delimited "\"" port) tokens))) | |
254 | ((#\') (loop (cons (read-delimited "'" port) tokens))) | |
255 | (else (if (> (string-length token) 0) | |
256 | (loop (cons token tokens)) | |
257 | (loop tokens)))))))) | |
258 | ||
696487d6 LC |
259 | (when %debug? |
260 | (format (current-error-port) | |
261 | "ld-wrapper: attempting to read arguments from '~a'~%" file)) | |
262 | ||
feb8c5da | 263 | (call-with-input-file file tokenize)) |
696487d6 LC |
264 | |
265 | (define result | |
266 | (fold-right (lambda (arg result) | |
267 | (if (string-prefix? "@" arg) | |
268 | (let ((file (string-drop arg 1))) | |
269 | (append (catch 'system-error | |
270 | (lambda () | |
271 | (response-file-arguments file)) | |
272 | (lambda args | |
273 | ;; FILE doesn't exist or cannot be read so | |
274 | ;; leave ARG as is. | |
275 | (list arg))) | |
276 | result)) | |
277 | (cons arg result))) | |
278 | '() | |
279 | args)) | |
280 | ||
281 | ;; If there are "@" arguments in RESULT *and* we can expand them (they don't | |
282 | ;; refer to nonexistent files), then recurse. | |
283 | (if (equal? result args) | |
284 | result | |
285 | (expand-arguments result))) | |
286 | ||
82dc2b9a LC |
287 | (define (ld-wrapper . args) |
288 | ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches. | |
696487d6 LC |
289 | (let* ((args (expand-arguments args)) |
290 | (path (library-search-path args)) | |
e946b609 | 291 | (libs (library-files-linked args path)) |
d8491ba5 LC |
292 | (args (append args (rpath-arguments libs)))) |
293 | (when %debug? | |
e946b609 LC |
294 | (format (current-error-port) |
295 | "ld-wrapper: library search path: ~s~%" path) | |
4267c637 LC |
296 | (format (current-error-port) |
297 | "ld-wrapper: libraries linked: ~s~%" libs) | |
d8491ba5 LC |
298 | (format (current-error-port) |
299 | "ld-wrapper: invoking `~a' with ~s~%" | |
67645383 LC |
300 | %real-ld args) |
301 | (force-output (current-error-port))) | |
82dc2b9a LC |
302 | (apply execl %real-ld (basename %real-ld) args))) |
303 | ||
304 | ;;; ld-wrapper.scm ends here |