| 1 | #!@BASH@ |
| 2 | # -*- mode: scheme; coding: utf-8; -*- |
| 3 | |
| 4 | # XXX: We have to go through Bash because there's no Guile command-line switch to |
| 5 | # ignore the various Guile load path related environment variables. |
| 6 | |
| 7 | # Unset 'GUILE_LOAD_PATH' to make sure we do not stumble upon |
| 8 | # incompatible Guile files (see |
| 9 | # <https://lists.gnu.org/archive/html/guile-devel/2016-03/msg00000.html>). |
| 10 | |
| 11 | unset GUILE_LOAD_PATH |
| 12 | unset GUILE_LOAD_COMPILED_PATH |
| 13 | unset GUILE_SYSTEM_PATH |
| 14 | unset GUILE_SYSTEM_COMPILED_PATH |
| 15 | |
| 16 | # Use `load-compiled' because `load' (and `-l') doesn't otherwise load our |
| 17 | # .go file, or causes extraneous `stat' system calls when the "-C" "/" arguments |
| 18 | # are provided. |
| 19 | main="(@ (gnu build-support ld-wrapper) ld-wrapper)" |
| 20 | exec @GUILE@ -c "(load-compiled \"@[email protected]\") ($main (command-line))" "$@" |
| 21 | !# |
| 22 | ;;; GNU Guix --- Functional package management for GNU |
| 23 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <[email protected]> |
| 24 | ;;; Copyright © 2020 Marius Bakke <[email protected]> |
| 25 | ;;; Copyright © 2024 Maxim Cournoyer <[email protected]> |
| 26 | ;;; |
| 27 | ;;; This file is part of GNU Guix. |
| 28 | ;;; |
| 29 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 30 | ;;; under the terms of the GNU General Public License as published by |
| 31 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 32 | ;;; your option) any later version. |
| 33 | ;;; |
| 34 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 35 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 36 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 37 | ;;; GNU General Public License for more details. |
| 38 | ;;; |
| 39 | ;;; You should have received a copy of the GNU General Public License |
| 40 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 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-module (gnu build-support ld-wrapper) |
| 68 | #:use-module (srfi srfi-1) |
| 69 | #:use-module (ice-9 match) |
| 70 | #:autoload (ice-9 rdelim) (read-delimited) |
| 71 | #:export (ld-wrapper)) |
| 72 | |
| 73 | (define %real-ld |
| 74 | ;; Name of the linker that we wrap. |
| 75 | "@LD@") |
| 76 | |
| 77 | (define %store-directory |
| 78 | ;; File name of the store. |
| 79 | (or (getenv "NIX_STORE") "/gnu/store")) |
| 80 | |
| 81 | (define %temporary-directory |
| 82 | ;; Temporary directory. |
| 83 | (or (getenv "TMPDIR") "/tmp")) |
| 84 | |
| 85 | (define %build-directory |
| 86 | ;; Top build directory when run from a builder. |
| 87 | (getenv "NIX_BUILD_TOP")) |
| 88 | |
| 89 | (define %allow-impurities? |
| 90 | ;; Whether to allow references to libraries outside the store. |
| 91 | ;; Allow them by default for convenience. |
| 92 | (let ((value (getenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES"))) |
| 93 | (or (not value) |
| 94 | (let ((value (string-downcase value))) |
| 95 | (cond ((member value '("yes" "y" "t" "true" "1")) |
| 96 | #t) |
| 97 | ((member value '("no" "n" "f" "false" "0")) |
| 98 | #f) |
| 99 | (else |
| 100 | (format (current-error-port) |
| 101 | "ld-wrapper: ~s: invalid value for \ |
| 102 | 'GUIX_LD_WRAPPER_ALLOW_IMPURITIES'~%" |
| 103 | value))))))) |
| 104 | |
| 105 | (define %debug? |
| 106 | ;; Whether to emit debugging output. |
| 107 | (getenv "GUIX_LD_WRAPPER_DEBUG")) |
| 108 | |
| 109 | (define %disable-rpath? |
| 110 | ;; Whether to disable automatic '-rpath' addition. |
| 111 | (getenv "GUIX_LD_WRAPPER_DISABLE_RPATH")) |
| 112 | |
| 113 | (define (readlink* file) |
| 114 | ;; Call 'readlink' until the result is not a symlink. |
| 115 | (define %max-symlink-depth 50) |
| 116 | |
| 117 | (let loop ((file file) |
| 118 | (depth 0)) |
| 119 | (define (absolute target) |
| 120 | (if (absolute-file-name? target) |
| 121 | target |
| 122 | (string-append (dirname file) "/" target))) |
| 123 | |
| 124 | (if (>= depth %max-symlink-depth) |
| 125 | file |
| 126 | (call-with-values |
| 127 | (lambda () |
| 128 | (catch 'system-error |
| 129 | (lambda () |
| 130 | (values #t (readlink file))) |
| 131 | (lambda args |
| 132 | (let ((errno (system-error-errno args))) |
| 133 | (if (or (= errno EINVAL) (= errno ENOENT)) |
| 134 | (values #f file) |
| 135 | (apply throw args)))))) |
| 136 | (lambda (success? target) |
| 137 | (if success? |
| 138 | (loop (absolute target) (+ depth 1)) |
| 139 | file)))))) |
| 140 | |
| 141 | (define (pure-file-name? file) |
| 142 | ;; Return #t when FILE is the name of a file either within the store |
| 143 | ;; (possibly via a symlink) or within the build directory. |
| 144 | (let ((file (readlink* file))) |
| 145 | (or (not (string-prefix? "/" file)) |
| 146 | (string-prefix? %store-directory file) |
| 147 | (string-prefix? %temporary-directory file) |
| 148 | (and %build-directory |
| 149 | (string-prefix? %build-directory file))))) |
| 150 | |
| 151 | (define (store-file-name? file) |
| 152 | ;; Return #t when FILE is a store file, possibly indirectly. |
| 153 | (string-prefix? %store-directory (readlink* file))) |
| 154 | |
| 155 | (define (shared-library? file) |
| 156 | ;; Return #t when FILE denotes a shared library. |
| 157 | (or (string-suffix? ".so" file) |
| 158 | (let ((index (string-contains file ".so."))) |
| 159 | ;; Since we cannot use regexps during bootstrap, roll our own. |
| 160 | (and index |
| 161 | (string-every (char-set-union (char-set #\.) char-set:digit) |
| 162 | (string-drop file (+ index 3))))))) |
| 163 | |
| 164 | (define (library-search-path args) |
| 165 | ;; Return the library search path as a list of directory names. The GNU ld |
| 166 | ;; manual notes that "[a]ll `-L' options apply to all `-l' options, |
| 167 | ;; regardless of the order in which the options appear", so we must compute |
| 168 | ;; the search path independently of the -l options. |
| 169 | (let loop ((args args) |
| 170 | (path '())) |
| 171 | (match args |
| 172 | (() |
| 173 | (reverse path)) |
| 174 | (("-L" directory . rest) |
| 175 | (loop rest (cons directory path))) |
| 176 | ((argument . rest) |
| 177 | (if (string-prefix? "-L" argument) ;augment the search path |
| 178 | (loop rest |
| 179 | (cons (string-drop argument 2) path)) |
| 180 | (loop rest path)))))) |
| 181 | |
| 182 | (define (library-files-linked args library-path) |
| 183 | ;; Return the absolute file names of shared libraries explicitly linked |
| 184 | ;; against via `-l' or with an absolute file name in ARGS, looking them up |
| 185 | ;; in LIBRARY-PATH. |
| 186 | (define files+args |
| 187 | (fold (lambda (argument result) |
| 188 | (match result |
| 189 | ((library-files ((and flag |
| 190 | (or "-dynamic-linker" "-plugin")) |
| 191 | . rest)) |
| 192 | ;; When passed '-dynamic-linker ld.so', ignore 'ld.so'; when |
| 193 | ;; passed '-plugin liblto_plugin.so', ignore |
| 194 | ;; 'liblto_plugin.so'. See <http://bugs.gnu.org/20102>. |
| 195 | (list library-files |
| 196 | (cons* argument flag rest))) |
| 197 | ((library-files previous-args) |
| 198 | (cond ((string-prefix? "-l" argument) ;add library |
| 199 | (let* ((lib (string-append "lib" |
| 200 | (string-drop argument 2) |
| 201 | ".so")) |
| 202 | (full (search-path library-path lib))) |
| 203 | (list (if full |
| 204 | (cons full library-files) |
| 205 | library-files) |
| 206 | (cons argument previous-args)))) |
| 207 | ((and (string-prefix? %store-directory argument) |
| 208 | (shared-library? argument)) ;add library |
| 209 | (list (cons argument library-files) |
| 210 | (cons argument previous-args))) |
| 211 | (else |
| 212 | (list library-files |
| 213 | (cons argument previous-args))))))) |
| 214 | (list '() '()) |
| 215 | args)) |
| 216 | |
| 217 | (match files+args |
| 218 | ((files arguments) |
| 219 | (reverse files)))) |
| 220 | |
| 221 | (define (rpath-arguments library-files) |
| 222 | ;; Return the `-rpath' argument list for each of LIBRARY-FILES, a list of |
| 223 | ;; absolute file names. |
| 224 | (fold-right (lambda (file args) |
| 225 | ;; Add '-rpath' if and only if FILE is in the store; we don't |
| 226 | ;; want to add '-rpath' for files under %BUILD-DIRECTORY or |
| 227 | ;; %TEMPORARY-DIRECTORY because that could leak to installed |
| 228 | ;; files. |
| 229 | (cond ((and (not %disable-rpath?) |
| 230 | (store-file-name? file)) |
| 231 | (cons* "-rpath" (dirname file) args)) |
| 232 | ((or %allow-impurities? |
| 233 | (pure-file-name? file)) |
| 234 | args) |
| 235 | (else |
| 236 | (begin |
| 237 | (format (current-error-port) |
| 238 | "ld-wrapper: error: attempt to use \ |
| 239 | library outside of ~a: ~s~%" |
| 240 | %store-directory file) |
| 241 | (exit 1))))) |
| 242 | '() |
| 243 | library-files)) |
| 244 | |
| 245 | (define (expand-arguments args) |
| 246 | ;; Expand ARGS such that "response file" arguments, such as "@args.txt", are |
| 247 | ;; expanded (info "(gcc) Overall Options"). |
| 248 | (define (response-file-arguments file) |
| 249 | (define (tokenize port) |
| 250 | ;; Return a list of all strings found in PORT. Quote characters are |
| 251 | ;; removed, but whitespaces within quoted strings are preserved. |
| 252 | (let loop ((tokens '())) |
| 253 | (let* ((token+delimiter (read-delimited " '\"\n" port 'split)) |
| 254 | (token (car token+delimiter)) |
| 255 | (delim (cdr token+delimiter))) |
| 256 | (if (eof-object? token) |
| 257 | (reverse tokens) |
| 258 | (case delim |
| 259 | ((#\") (loop (cons (read-delimited "\"" port) tokens))) |
| 260 | ((#\') (loop (cons (read-delimited "'" port) tokens))) |
| 261 | (else (if (> (string-length token) 0) |
| 262 | (loop (cons token tokens)) |
| 263 | (loop tokens)))))))) |
| 264 | |
| 265 | (when %debug? |
| 266 | (format (current-error-port) |
| 267 | "ld-wrapper: attempting to read arguments from '~a'~%" file)) |
| 268 | |
| 269 | (call-with-input-file file tokenize)) |
| 270 | |
| 271 | (define result |
| 272 | (fold-right (lambda (arg result) |
| 273 | (if (string-prefix? "@" arg) |
| 274 | (let ((file (string-drop arg 1))) |
| 275 | (append (catch 'system-error |
| 276 | (lambda () |
| 277 | (response-file-arguments file)) |
| 278 | (lambda args |
| 279 | ;; FILE doesn't exist or cannot be read so |
| 280 | ;; leave ARG as is. |
| 281 | (list arg))) |
| 282 | result)) |
| 283 | (cons arg result))) |
| 284 | '() |
| 285 | args)) |
| 286 | |
| 287 | ;; If there are "@" arguments in RESULT *and* we can expand them (they don't |
| 288 | ;; refer to nonexistent files), then recurse. |
| 289 | (if (equal? result args) |
| 290 | result |
| 291 | (expand-arguments result))) |
| 292 | |
| 293 | (define (ld-wrapper args) |
| 294 | ;; Invoke the real `ld' with ARGS, augmented with `-rpath' switches. |
| 295 | (let* ((args (expand-arguments (cdr args))) ;strip arg0 |
| 296 | (path (library-search-path args)) |
| 297 | (libs (library-files-linked args path)) |
| 298 | (args (append args (rpath-arguments libs)))) |
| 299 | (when %debug? |
| 300 | (format (current-error-port) |
| 301 | "ld-wrapper: library search path: ~s~%" path) |
| 302 | (format (current-error-port) |
| 303 | "ld-wrapper: libraries linked: ~s~%" libs) |
| 304 | (format (current-error-port) |
| 305 | "ld-wrapper: invoking `~a' with ~s~%" |
| 306 | %real-ld args) |
| 307 | (force-output (current-error-port))) |
| 308 | (apply execl %real-ld (basename %real-ld) args))) |
| 309 | |
| 310 | ;;; ld-wrapper.scm ends here |