Commit | Line | Data |
---|---|---|
25590118 MB |
1 | #!@BASH@ |
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>). | |
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>. | |
12 | ||
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)))" "$@" | |
16 | !# | |
17 | ;;; GNU Guix --- Functional package management for GNU | |
18 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> | |
19 | ;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com> | |
20 | ;;; | |
21 | ;;; This file is part of GNU Guix. | |
22 | ;;; | |
23 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
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 | ;;; | |
28 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
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 | |
34 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
35 | ||
36 | (define-module (gnu build-support ld-wrapper) | |
37 | #:use-module (srfi srfi-1) | |
38 | #:use-module (ice-9 match) | |
39 | #:autoload (ice-9 rdelim) (read-delimited) | |
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. | |
73 | (or (getenv "NIX_STORE") "/gnu/store")) | |
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. | |
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))))))) | |
98 | ||
99 | (define %debug? | |
100 | ;; Whether to emit debugging output. | |
101 | (getenv "GUIX_LD_WRAPPER_DEBUG")) | |
102 | ||
103 | (define %disable-rpath? | |
104 | ;; Whether to disable automatic '-rpath' addition. | |
105 | (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH")) | |
106 | ||
107 | (define (readlink* file) | |
108 | ;; Call 'readlink' until the result is not a symlink. | |
109 | (define %max-symlink-depth 50) | |
110 | ||
111 | (let loop ((file file) | |
112 | (depth 0)) | |
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)))))) | |
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. | |
138 | (let ((file (readlink* file))) | |
139 | (or (not (string-prefix? "/" file)) | |
140 | (string-prefix? %store-directory file) | |
141 | (string-prefix? %temporary-directory file) | |
142 | (and %build-directory | |
143 | (string-prefix? %build-directory file))))) | |
144 | ||
145 | (define (store-file-name? file) | |
146 | ;; Return #t when FILE is a store file, possibly indirectly. | |
147 | (string-prefix? %store-directory (readlink* file))) | |
148 | ||
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 | ||
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 | |
181 | (fold (lambda (argument result) | |
182 | (match result | |
183 | ((library-files ((and flag | |
184 | (or "-dynamic-linker" "-plugin")) | |
185 | . rest)) | |
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>. | |
189 | (list library-files | |
190 | (cons* argument flag rest))) | |
191 | ((library-files previous-args) | |
192 | (cond ((string-prefix? "-l" argument) ;add library | |
193 | (let* ((lib (string-append "lib" | |
194 | (string-drop argument 2) | |
195 | ".so")) | |
196 | (full (search-path library-path lib))) | |
197 | (list (if full | |
198 | (cons full library-files) | |
199 | library-files) | |
200 | (cons argument previous-args)))) | |
201 | ((and (string-prefix? %store-directory argument) | |
202 | (shared-library? argument)) ;add library | |
203 | (list (cons argument library-files) | |
204 | (cons argument previous-args))) | |
205 | (else | |
206 | (list library-files | |
207 | (cons argument previous-args))))))) | |
208 | (list '() '()) | |
209 | args)) | |
210 | ||
211 | (match files+args | |
212 | ((files arguments) | |
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. | |
218 | (fold-right (lambda (file args) | |
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. | |
223 | (cond ((and (not %disable-rpath?) | |
224 | (store-file-name? file)) | |
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 \ | |
233 | library outside of ~a: ~s~%" | |
234 | %store-directory file) | |
235 | (exit 1))))) | |
236 | '() | |
237 | library-files)) | |
238 | ||
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) | |
243 | (define (tokenize port) | |
244 | ;; Return a list of all strings found in PORT. Quote characters are removed, | |
245 | ;; but whitespaces within quoted strings are preserved. | |
246 | (let loop ((words '())) | |
247 | (let* ((word (read-delimited " '\"" port 'split)) | |
248 | (token (car word)) | |
249 | (delim (cdr word))) | |
250 | (if (eof-object? delim) | |
251 | (reverse words) | |
252 | (case delim | |
253 | ((#\") (loop (cons (read-delimited "\"" port) words))) | |
254 | ((#\') (loop (cons (read-delimited "'" port) words))) | |
255 | ((#\ ) (if (> 0 (string-length token)) | |
256 | (loop (cons token words)) | |
257 | (loop words))) | |
258 | (else (loop words))))))) | |
259 | ||
260 | (when %debug? | |
261 | (format (current-error-port) | |
262 | "ld-wrapper: attempting to read arguments from '~a'~%" file)) | |
263 | ||
264 | (call-with-input-file file tokenize)) | |
265 | ||
266 | (define result | |
267 | (fold-right (lambda (arg result) | |
268 | (if (string-prefix? "@" arg) | |
269 | (let ((file (string-drop arg 1))) | |
270 | (append (catch 'system-error | |
271 | (lambda () | |
272 | (response-file-arguments file)) | |
273 | (lambda args | |
274 | ;; FILE doesn't exist or cannot be read so | |
275 | ;; leave ARG as is. | |
276 | (list arg))) | |
277 | result)) | |
278 | (cons arg result))) | |
279 | '() | |
280 | args)) | |
281 | ||
282 | ;; If there are "@" arguments in RESULT *and* we can expand them (they don't | |
283 | ;; refer to nonexistent files), then recurse. | |
284 | (if (equal? result args) | |
285 | result | |
286 | (expand-arguments result))) | |
287 | ||
288 | (define (ld-wrapper . args) | |
289 | ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches. | |
290 | (let* ((args (expand-arguments args)) | |
291 | (path (library-search-path args)) | |
292 | (libs (library-files-linked args path)) | |
293 | (args (append args (rpath-arguments libs)))) | |
294 | (when %debug? | |
295 | (format (current-error-port) | |
296 | "ld-wrapper: library search path: ~s~%" path) | |
297 | (format (current-error-port) | |
298 | "ld-wrapper: libraries linked: ~s~%" libs) | |
299 | (format (current-error-port) | |
300 | "ld-wrapper: invoking `~a' with ~s~%" | |
301 | %real-ld args) | |
302 | (force-output (current-error-port))) | |
303 | (apply execl %real-ld (basename %real-ld) args))) | |
304 | ||
305 | ;;; ld-wrapper.scm ends here |