gnu: Add cl-ana.statistical-learning.
[jackhill/guix/guix.git] / gnu / packages / ld-wrapper.in
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 ;;;
20 ;;; This file is part of GNU Guix.
21 ;;;
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.
26 ;;;
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.
31 ;;;
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/>.
34
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))
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.
72 (or (getenv "NIX_STORE") "/gnu/store"))
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 ;; Allow them by default for convenience.
85 (let ((value (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES")))
86 (or (not value)
87 (let ((value (string-downcase value)))
88 (cond ((member value '("yes" "y" "t" "true" "1"))
89 #t)
90 ((member value '("no" "n" "f" "false" "0"))
91 #f)
92 (else
93 (format (current-error-port)
94 "ld-wrapper: ~s: invalid value for \
95 'GUIX_LD_WRAPPER_ALLOW_IMPURITIES'~%"
96 value)))))))
97
98 (define %debug?
99 ;; Whether to emit debugging output.
100 (getenv "GUIX_LD_WRAPPER_DEBUG"))
101
102 (define %disable-rpath?
103 ;; Whether to disable automatic '-rpath' addition.
104 (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH"))
105
106 (define (readlink* file)
107 ;; Call 'readlink' until the result is not a symlink.
108 (define %max-symlink-depth 50)
109
110 (let loop ((file file)
111 (depth 0))
112 (define (absolute target)
113 (if (absolute-file-name? target)
114 target
115 (string-append (dirname file) "/" target)))
116
117 (if (>= depth %max-symlink-depth)
118 file
119 (call-with-values
120 (lambda ()
121 (catch 'system-error
122 (lambda ()
123 (values #t (readlink file)))
124 (lambda args
125 (let ((errno (system-error-errno args)))
126 (if (or (= errno EINVAL) (= errno ENOENT))
127 (values #f file)
128 (apply throw args))))))
129 (lambda (success? target)
130 (if success?
131 (loop (absolute target) (+ depth 1))
132 file))))))
133
134 (define (pure-file-name? file)
135 ;; Return #t when FILE is the name of a file either within the store
136 ;; (possibly via a symlink) or within the build directory.
137 (let ((file (readlink* file)))
138 (or (not (string-prefix? "/" file))
139 (string-prefix? %store-directory file)
140 (string-prefix? %temporary-directory file)
141 (and %build-directory
142 (string-prefix? %build-directory file)))))
143
144 (define (store-file-name? file)
145 ;; Return #t when FILE is a store file, possibly indirectly.
146 (string-prefix? %store-directory (readlink* file)))
147
148 (define (shared-library? file)
149 ;; Return #t when FILE denotes a shared library.
150 (or (string-suffix? ".so" file)
151 (let ((index (string-contains file ".so.")))
152 ;; Since we cannot use regexps during bootstrap, roll our own.
153 (and index
154 (string-every (char-set-union (char-set #\.) char-set:digit)
155 (string-drop file (+ index 3)))))))
156
157 (define (library-search-path args)
158 ;; Return the library search path as a list of directory names. The GNU ld
159 ;; manual notes that "[a]ll `-L' options apply to all `-l' options,
160 ;; regardless of the order in which the options appear", so we must compute
161 ;; the search path independently of the -l options.
162 (let loop ((args args)
163 (path '()))
164 (match args
165 (()
166 (reverse path))
167 (("-L" directory . rest)
168 (loop rest (cons directory path)))
169 ((argument . rest)
170 (if (string-prefix? "-L" argument) ;augment the search path
171 (loop rest
172 (cons (string-drop argument 2) path))
173 (loop rest path))))))
174
175 (define (library-files-linked args library-path)
176 ;; Return the absolute file names of shared libraries explicitly linked
177 ;; against via `-l' or with an absolute file name in ARGS, looking them up
178 ;; in LIBRARY-PATH.
179 (define files+args
180 (fold (lambda (argument result)
181 (match result
182 ((library-files ((and flag
183 (or "-dynamic-linker" "-plugin"))
184 . rest))
185 ;; When passed '-dynamic-linker ld.so', ignore 'ld.so'; when
186 ;; passed '-plugin liblto_plugin.so', ignore
187 ;; 'liblto_plugin.so'. See <http://bugs.gnu.org/20102>.
188 (list library-files
189 (cons* argument flag rest)))
190 ((library-files previous-args)
191 (cond ((string-prefix? "-l" argument) ;add library
192 (let* ((lib (string-append "lib"
193 (string-drop argument 2)
194 ".so"))
195 (full (search-path library-path lib)))
196 (list (if full
197 (cons full library-files)
198 library-files)
199 (cons argument previous-args))))
200 ((and (string-prefix? %store-directory argument)
201 (shared-library? argument)) ;add library
202 (list (cons argument library-files)
203 (cons argument previous-args)))
204 (else
205 (list library-files
206 (cons argument previous-args)))))))
207 (list '() '())
208 args))
209
210 (match files+args
211 ((files arguments)
212 (reverse files))))
213
214 (define (rpath-arguments library-files)
215 ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of
216 ;; absolute file names.
217 (fold-right (lambda (file args)
218 ;; Add '-rpath' if and only if FILE is in the store; we don't
219 ;; want to add '-rpath' for files under %BUILD-DIRECTORY or
220 ;; %TEMPORARY-DIRECTORY because that could leak to installed
221 ;; files.
222 (cond ((and (not %disable-rpath?)
223 (store-file-name? file))
224 (cons* "-rpath" (dirname file) args))
225 ((or %allow-impurities?
226 (pure-file-name? file))
227 args)
228 (else
229 (begin
230 (format (current-error-port)
231 "ld-wrapper: error: attempt to use \
232 library outside of ~a: ~s~%"
233 %store-directory file)
234 (exit 1)))))
235 '()
236 library-files))
237
238 (define (expand-arguments args)
239 ;; Expand ARGS such that "response file" arguments, such as "@args.txt", are
240 ;; expanded (info "(gcc) Overall Options").
241 (define (response-file-arguments file)
242 (when %debug?
243 (format (current-error-port)
244 "ld-wrapper: attempting to read arguments from '~a'~%" file))
245
246 ;; FIXME: Options can contain whitespace if they are protected by single
247 ;; or double quotes; this is not implemented here.
248 (string-tokenize (call-with-input-file file read-string)))
249
250 (define result
251 (fold-right (lambda (arg result)
252 (if (string-prefix? "@" arg)
253 (let ((file (string-drop arg 1)))
254 (append (catch 'system-error
255 (lambda ()
256 (response-file-arguments file))
257 (lambda args
258 ;; FILE doesn't exist or cannot be read so
259 ;; leave ARG as is.
260 (list arg)))
261 result))
262 (cons arg result)))
263 '()
264 args))
265
266 ;; If there are "@" arguments in RESULT *and* we can expand them (they don't
267 ;; refer to nonexistent files), then recurse.
268 (if (equal? result args)
269 result
270 (expand-arguments result)))
271
272 (define (ld-wrapper . args)
273 ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches.
274 (let* ((args (expand-arguments args))
275 (path (library-search-path args))
276 (libs (library-files-linked args path))
277 (args (append args (rpath-arguments libs))))
278 (when %debug?
279 (format (current-error-port)
280 "ld-wrapper: library search path: ~s~%" path)
281 (format (current-error-port)
282 "ld-wrapper: libraries linked: ~s~%" libs)
283 (format (current-error-port)
284 "ld-wrapper: invoking `~a' with ~s~%"
285 %real-ld args)
286 (force-output (current-error-port)))
287 (apply execl %real-ld (basename %real-ld) args)))
288
289 ;;; ld-wrapper.scm ends here