Commit | Line | Data |
---|---|---|
45037e75 AW |
1 | ;;; Guile ELF linker |
2 | ||
3 | ;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. | |
4 | ||
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | ;;; Commentary: | |
20 | ;;; | |
21 | ;;; A linker combines several linker objects into an executable or a | |
22 | ;;; loadable library. | |
23 | ;;; | |
24 | ;;; There are several common formats for libraries out there. Since | |
25 | ;;; Guile includes its own linker and loader, we are free to choose any | |
26 | ;;; format, or make up our own. | |
27 | ;;; | |
28 | ;;; There are essentially two requirements for a linker format: | |
29 | ;;; libraries should be able to be loaded with the minimal amount of | |
30 | ;;; work; and they should support introspection in some way, in order to | |
31 | ;;; enable good debugging. | |
32 | ;;; | |
33 | ;;; These requirements are somewhat at odds, as loading should not have | |
34 | ;;; to stumble over features related to introspection. It so happens | |
35 | ;;; that a lot of smart people have thought about this situation, and | |
36 | ;;; the ELF format embodies the outcome of their thinking. Guile uses | |
37 | ;;; ELF as its format, regardless of the platform's native library | |
38 | ;;; format. It's not inconceivable that Guile could interoperate with | |
39 | ;;; the native dynamic loader at some point, but it's not a near-term | |
40 | ;;; goal. | |
41 | ;;; | |
42 | ;;; Guile's linker takes a list of objects, sorts them according to | |
43 | ;;; similarity from the perspective of the loader, then writes them out | |
44 | ;;; into one big bytevector in ELF format. | |
45 | ;;; | |
46 | ;;; It is often the case that different parts of a library need to refer | |
47 | ;;; to each other. For example, program text may need to refer to a | |
48 | ;;; constant from writable memory. When the linker places sections | |
49 | ;;; (linker objects) into specific locations in the linked bytevector, | |
50 | ;;; it needs to fix up those references. This process is called | |
51 | ;;; /relocation/. References needing relocations are recorded in | |
52 | ;;; "linker-reloc" objects, and collected in a list in each | |
53 | ;;; "linker-object". The actual definitions of the references are | |
54 | ;;; stored in "linker-symbol" objects, also collected in a list in each | |
55 | ;;; "linker-object". | |
56 | ;;; | |
57 | ;;; By default, the ELF files created by the linker include some padding | |
58 | ;;; so that different parts of the file can be loaded in with different | |
59 | ;;; permissions. For example, some parts of the file are read-only and | |
60 | ;;; thus can be shared between processes. Some parts of the file don't | |
61 | ;;; need to be loaded at all. However this padding can be too much for | |
62 | ;;; interactive compilation, when the code is never written out to disk; | |
63 | ;;; in that case, pass #:page-aligned? #f to `link-elf'. | |
64 | ;;; | |
65 | ;;; Code: | |
66 | ||
67 | (define-module (system vm linker) | |
68 | #:use-module (rnrs bytevectors) | |
69 | #:use-module (system foreign) | |
70 | #:use-module (system base target) | |
6756d265 | 71 | #:use-module ((srfi srfi-1) #:select (append-map)) |
45037e75 AW |
72 | #:use-module (srfi srfi-9) |
73 | #:use-module (ice-9 receive) | |
74 | #:use-module (ice-9 vlist) | |
6756d265 | 75 | #:use-module (ice-9 match) |
45037e75 | 76 | #:use-module (system vm elf) |
6756d265 | 77 | #:export (make-linker-reloc |
45037e75 AW |
78 | make-linker-symbol |
79 | ||
80 | make-linker-object | |
81 | linker-object? | |
82 | linker-object-section | |
83 | linker-object-bv | |
84 | linker-object-relocs | |
d4da9ba9 | 85 | (linker-object-symbols* . linker-object-symbols) |
45037e75 | 86 | |
6756d265 | 87 | make-string-table |
f5473fba AW |
88 | string-table-intern! |
89 | link-string-table! | |
6756d265 | 90 | |
45037e75 AW |
91 | link-elf)) |
92 | ||
d4da9ba9 AW |
93 | (define-syntax fold-values |
94 | (lambda (x) | |
95 | (syntax-case x () | |
96 | ((_ proc list seed ...) | |
97 | (with-syntax (((s ...) (generate-temporaries #'(seed ...)))) | |
98 | #'(let ((p proc)) | |
99 | (let lp ((l list) (s seed) ...) | |
100 | (match l | |
101 | (() (values s ...)) | |
102 | ((elt . l) | |
103 | (call-with-values (lambda () (p elt s ...)) | |
104 | (lambda (s ...) (lp l s ...)))))))))))) | |
105 | ||
45037e75 AW |
106 | ;; A relocation records a reference to a symbol. When the symbol is |
107 | ;; resolved to an address, the reloc location will be updated to point | |
108 | ;; to the address. | |
109 | ;; | |
110 | ;; Two types. Abs32/1 and Abs64/1 are absolute offsets in bytes. | |
111 | ;; Rel32/4 is a relative signed offset in 32-bit units. Either can have | |
112 | ;; an arbitrary addend as well. | |
113 | ;; | |
114 | (define-record-type <linker-reloc> | |
115 | (make-linker-reloc type loc addend symbol) | |
116 | linker-reloc? | |
117 | (type linker-reloc-type) ;; rel32/4, abs32/1, abs64/1 | |
118 | (loc linker-reloc-loc) | |
119 | (addend linker-reloc-addend) | |
120 | (symbol linker-reloc-symbol)) | |
121 | ||
122 | ;; A symbol is an association between a name and an address. The | |
123 | ;; address is always in regard to some particular address space. When | |
124 | ;; objects come into the linker, their symbols live in the object | |
125 | ;; address space. When the objects are allocated into ELF segments, the | |
126 | ;; symbols will be relocated into memory address space, corresponding to | |
127 | ;; the position the ELF will be loaded at. | |
128 | ;; | |
129 | (define-record-type <linker-symbol> | |
130 | (make-linker-symbol name address) | |
131 | linker-symbol? | |
132 | (name linker-symbol-name) | |
133 | (address linker-symbol-address)) | |
134 | ||
135 | (define-record-type <linker-object> | |
d4da9ba9 | 136 | (%make-linker-object section bv relocs symbols) |
45037e75 AW |
137 | linker-object? |
138 | (section linker-object-section) | |
139 | (bv linker-object-bv) | |
140 | (relocs linker-object-relocs) | |
141 | (symbols linker-object-symbols)) | |
142 | ||
d4da9ba9 AW |
143 | (define (make-linker-object section bv relocs symbols) |
144 | "Create a linker object with the @code{<elf-section>} header | |
145 | @var{section}, bytevector contents @var{bv}, list of linker relocations | |
146 | @var{relocs}, and list of linker symbols @var{symbols}." | |
147 | (%make-linker-object section bv relocs | |
148 | ;; Hide a symbol to the beginning of the section | |
149 | ;; in the symbols. | |
150 | (cons (make-linker-symbol (gensym "*section*") 0) | |
151 | symbols))) | |
152 | (define (linker-object-section-symbol object) | |
153 | "Return the linker symbol corresponding to the start of this section." | |
154 | (car (linker-object-symbols object))) | |
155 | (define (linker-object-symbols* object) | |
156 | "Return the linker symbols defined by the user for this this section." | |
157 | (cdr (linker-object-symbols object))) | |
158 | ||
f5473fba AW |
159 | (define-record-type <string-table> |
160 | (%make-string-table strings linked?) | |
161 | string-table? | |
162 | (strings string-table-strings set-string-table-strings!) | |
163 | (linked? string-table-linked? set-string-table-linked?!)) | |
164 | ||
45037e75 | 165 | (define (make-string-table) |
f5473fba AW |
166 | "Return a string table with one entry: the empty string." |
167 | (%make-string-table '(("" 0 #vu8())) #f)) | |
168 | ||
169 | (define (string-table-length strings) | |
170 | "Return the number of bytes needed for the @var{strings}." | |
171 | (match strings | |
172 | (((str pos bytes) . _) | |
173 | ;; The + 1 is for the trailing NUL byte. | |
174 | (+ pos (bytevector-length bytes) 1)))) | |
175 | ||
176 | (define (string-table-intern! table str) | |
177 | "Ensure that @var{str} is present in the string table @var{table}. | |
178 | Returns the byte index of the string in that table." | |
179 | (match table | |
180 | (($ <string-table> strings linked?) | |
181 | (match (assoc str strings) | |
182 | ((_ pos _) pos) | |
183 | (#f | |
184 | (let ((next (string-table-length strings))) | |
185 | (when linked? | |
186 | (error "string table already linked, can't intern" table str)) | |
187 | (set-string-table-strings! table | |
188 | (cons (list str next (string->utf8 str)) | |
189 | strings)) | |
190 | next)))))) | |
191 | ||
192 | (define (link-string-table! table) | |
d4da9ba9 AW |
193 | "Link the functional string table @var{table} into a sequence of |
194 | bytes, suitable for use as the contents of an ELF string table section." | |
f5473fba AW |
195 | (match table |
196 | (($ <string-table> strings #f) | |
197 | (let ((out (make-bytevector (string-table-length strings) 0))) | |
198 | (for-each | |
199 | (match-lambda | |
200 | ((_ pos bytes) | |
201 | (bytevector-copy! bytes 0 out pos (bytevector-length bytes)))) | |
202 | strings) | |
203 | (set-string-table-linked?! table #t) | |
204 | out)))) | |
45037e75 AW |
205 | |
206 | (define (segment-kind section) | |
d4da9ba9 AW |
207 | "Return the type of segment needed to store @var{section}, as a pair. |
208 | The car is the @code{PT_} segment type, or @code{#f} if the section | |
209 | doesn't need to be present in a loadable segment. The cdr is a bitfield | |
210 | of associated @code{PF_} permissions." | |
45037e75 AW |
211 | (let ((flags (elf-section-flags section))) |
212 | (cons (cond | |
213 | ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC) | |
d4da9ba9 AW |
214 | ;; Sections without SHF_ALLOC don't go in segments. |
215 | ((zero? flags) #f) | |
45037e75 AW |
216 | (else PT_LOAD)) |
217 | (logior (if (zero? (logand SHF_ALLOC flags)) | |
218 | 0 | |
219 | PF_R) | |
220 | (if (zero? (logand SHF_EXECINSTR flags)) | |
221 | 0 | |
222 | PF_X) | |
223 | (if (zero? (logand SHF_WRITE flags)) | |
224 | 0 | |
225 | PF_W))))) | |
226 | ||
d4da9ba9 AW |
227 | (define (count-segments objects) |
228 | "Return the total number of segments needed to represent the linker | |
229 | objects in @var{objects}, including the segment needed for the ELF | |
230 | header and segment table." | |
231 | (length | |
232 | (fold-values (lambda (object kinds) | |
233 | (let ((kind (segment-kind (linker-object-section object)))) | |
234 | (if (and (car kind) (not (member kind kinds))) | |
235 | (cons kind kinds) | |
236 | kinds))) | |
237 | objects | |
238 | ;; We know there will be at least one segment, | |
239 | ;; containing at least the header and segment table. | |
240 | (list (cons PT_LOAD PF_R))))) | |
241 | ||
45037e75 | 242 | (define (group-by-cars ls) |
d4da9ba9 AW |
243 | (let lp ((ls ls) (k #f) (group #f) (out '())) |
244 | (match ls | |
245 | (() | |
246 | (reverse! | |
247 | (if group | |
248 | (cons (cons k (reverse! group)) out) | |
249 | out))) | |
250 | (((k* . v) . ls) | |
251 | (if (and group (equal? k k*)) | |
252 | (lp ls k (cons v group) out) | |
253 | (lp ls k* (list v) | |
254 | (if group | |
255 | (cons (cons k (reverse! group)) out) | |
256 | out))))))) | |
45037e75 AW |
257 | |
258 | (define (collate-objects-into-segments objects) | |
d4da9ba9 AW |
259 | "Given the list of linker objects @var{objects}, group them into |
260 | contiguous ELF segments of the same type and flags. The result is an | |
261 | alist that maps segment types to lists of linker objects. See | |
262 | @code{segment-type} for a description of segment types. Within a | |
263 | segment, the order of the linker objects is preserved." | |
45037e75 AW |
264 | (group-by-cars |
265 | (stable-sort! | |
266 | (map (lambda (o) | |
267 | (cons (segment-kind (linker-object-section o)) o)) | |
268 | objects) | |
269 | (lambda (x y) | |
d4da9ba9 AW |
270 | (let* ((x-kind (car x)) (y-kind (car y)) |
271 | (x-type (car x-kind)) (y-type (car y-kind)) | |
272 | (x-flags (cdr x-kind)) (y-flags (cdr y-kind)) | |
273 | (x-section (linker-object-section (cdr x))) | |
274 | (y-section (linker-object-section (cdr y)))) | |
45037e75 | 275 | (cond |
d4da9ba9 AW |
276 | ((not (equal? x-kind y-kind)) |
277 | (cond | |
278 | ((and x-type y-type) | |
279 | (cond | |
280 | ((not (equal? x-flags y-flags)) | |
281 | (< x-flags y-flags)) | |
282 | (else | |
283 | (< x-type y-type)))) | |
284 | (else | |
285 | (not y-type)))) | |
45037e75 AW |
286 | ((not (equal? (elf-section-type x-section) |
287 | (elf-section-type y-section))) | |
288 | (cond | |
289 | ((equal? (elf-section-type x-section) SHT_NOBITS) #t) | |
290 | ((equal? (elf-section-type y-section) SHT_NOBITS) #f) | |
291 | (else (< (elf-section-type x-section) | |
292 | (elf-section-type y-section))))) | |
293 | (else | |
d4da9ba9 AW |
294 | ;; Leave them in the initial order. This allows us to ensure |
295 | ;; that the ELF header is written first. | |
296 | #f))))))) | |
45037e75 AW |
297 | |
298 | (define (align address alignment) | |
d4da9ba9 AW |
299 | (if (zero? alignment) |
300 | address | |
301 | (+ address | |
302 | (modulo (- alignment (modulo address alignment)) alignment)))) | |
45037e75 | 303 | |
a236867d | 304 | (define (relocate-section-header sec offset) |
d4da9ba9 | 305 | "Return a new section header, just like @var{sec} but with its |
a236867d | 306 | @code{offset} (and @code{addr} if it is loadable) set to @var{offset}." |
6756d265 AW |
307 | (make-elf-section #:index (elf-section-index sec) |
308 | #:name (elf-section-name sec) | |
45037e75 AW |
309 | #:type (elf-section-type sec) |
310 | #:flags (elf-section-flags sec) | |
a236867d AW |
311 | #:addr (if (zero? (logand SHF_ALLOC |
312 | (elf-section-flags sec))) | |
313 | 0 | |
314 | offset) | |
315 | #:offset offset | |
45037e75 AW |
316 | #:size (elf-section-size sec) |
317 | #:link (elf-section-link sec) | |
318 | #:info (elf-section-info sec) | |
319 | #:addralign (elf-section-addralign sec) | |
320 | #:entsize (elf-section-entsize sec))) | |
321 | ||
322 | (define *page-size* 4096) | |
323 | ||
45037e75 | 324 | (define (add-symbols symbols offset symtab) |
d4da9ba9 AW |
325 | "Add @var{symbols} to the symbol table @var{symtab}, relocating them |
326 | from object address space to memory address space. Returns a new symbol | |
327 | table." | |
6756d265 AW |
328 | (fold-values |
329 | (lambda (symbol symtab) | |
330 | (let ((name (linker-symbol-name symbol)) | |
331 | (addr (linker-symbol-address symbol))) | |
332 | (when (vhash-assq name symtab) | |
333 | (error "duplicate symbol" name)) | |
334 | (vhash-consq name (make-linker-symbol name (+ addr offset)) symtab))) | |
335 | symbols | |
336 | symtab)) | |
45037e75 | 337 | |
d4da9ba9 AW |
338 | (define (allocate-segment write-segment-header! |
339 | phidx type flags objects addr symtab alignment) | |
340 | "Given a list of linker objects that should go in a segment, the type | |
341 | and flags that the segment should have, and the address at which the | |
342 | segment should start, compute the positions that each object should have | |
343 | in the segment. | |
344 | ||
345 | Returns three values: the address of the next byte after the segment, a | |
346 | list of relocated objects, and the symbol table. The symbol table is | |
347 | the same as @var{symtab}, augmented with the symbols defined in | |
348 | @var{objects}, relocated to their positions in the image. | |
349 | ||
350 | In what is something of a quirky interface, this routine also patches up | |
351 | the segment table using @code{write-segment-header!}." | |
352 | (let* ((alignment (fold-values (lambda (o alignment) | |
6756d265 AW |
353 | (lcm (elf-section-addralign |
354 | (linker-object-section o)) | |
355 | alignment)) | |
356 | objects | |
357 | alignment)) | |
d4da9ba9 AW |
358 | (addr (align addr alignment))) |
359 | (receive (objects endaddr symtab) | |
6756d265 | 360 | (fold-values |
d4da9ba9 | 361 | (lambda (o out addr symtab) |
6756d265 | 362 | (let* ((section (linker-object-section o)) |
d4da9ba9 | 363 | (addr (align addr (elf-section-addralign section)))) |
6756d265 AW |
364 | (values |
365 | (cons (make-linker-object | |
d4da9ba9 | 366 | (relocate-section-header section addr) |
6756d265 AW |
367 | (linker-object-bv o) |
368 | (linker-object-relocs o) | |
369 | (linker-object-symbols o)) | |
370 | out) | |
d4da9ba9 AW |
371 | (+ addr (elf-section-size section)) |
372 | (add-symbols (linker-object-symbols o) addr symtab)))) | |
373 | objects | |
374 | '() addr symtab) | |
375 | (when type | |
376 | (write-segment-header! | |
377 | (make-elf-segment #:index phidx #:type type | |
378 | #:offset addr #:vaddr addr | |
379 | #:filesz (- endaddr addr) #:memsz (- endaddr addr) | |
380 | #:flags flags #:align alignment))) | |
381 | (values endaddr | |
382 | (reverse objects) | |
383 | symtab)))) | |
384 | ||
385 | (define (process-reloc reloc bv section-offset symtab endianness) | |
386 | "Process a relocation. Given that a section containing @var{reloc} | |
387 | was just written into the image @var{bv} at offset @var{section-offset}, | |
388 | fix it up so that its reference points to the correct position of its | |
389 | symbol, as present in @var{symtab}." | |
390 | (match (vhash-assq (linker-reloc-symbol reloc) symtab) | |
391 | (#f | |
392 | (error "Undefined symbol" (linker-reloc-symbol reloc))) | |
393 | ((name . symbol) | |
394 | ;; The reloc was written at LOC bytes after SECTION-OFFSET. | |
395 | (let* ((offset (+ (linker-reloc-loc reloc) section-offset)) | |
396 | (target (linker-symbol-address symbol))) | |
397 | (case (linker-reloc-type reloc) | |
398 | ((rel32/4) | |
399 | (let ((diff (- target offset))) | |
400 | (unless (zero? (modulo diff 4)) | |
401 | (error "Bad offset" reloc symbol offset)) | |
402 | (bytevector-s32-set! bv offset | |
403 | (+ (/ diff 4) (linker-reloc-addend reloc)) | |
404 | endianness))) | |
405 | ((abs32/1) | |
406 | (bytevector-u32-set! bv offset target endianness)) | |
407 | ((abs64/1) | |
408 | (bytevector-u64-set! bv offset target endianness)) | |
409 | (else | |
410 | (error "bad reloc type" reloc))))))) | |
45037e75 AW |
411 | |
412 | (define (write-linker-object bv o symtab endianness) | |
d4da9ba9 AW |
413 | "Write the bytevector for the section wrapped by the linker object |
414 | @var{o} into the image @var{bv}. The section header in @var{o} should | |
415 | already be relocated its final position in the image. Any relocations | |
416 | in the section will be processed to point to the correct symbol | |
417 | locations, as given in @var{symtab}." | |
45037e75 AW |
418 | (let* ((section (linker-object-section o)) |
419 | (offset (elf-section-offset section)) | |
45037e75 AW |
420 | (len (elf-section-size section)) |
421 | (bytes (linker-object-bv o)) | |
422 | (relocs (linker-object-relocs o))) | |
a236867d AW |
423 | (if (zero? (logand SHF_ALLOC (elf-section-flags section))) |
424 | (unless (zero? (elf-section-addr section)) | |
425 | (error "non-loadable section has non-zero addr" section)) | |
426 | (unless (= offset (elf-section-addr section)) | |
427 | (error "loadable section has offset != addr" section))) | |
45037e75 AW |
428 | (if (not (= (elf-section-type section) SHT_NOBITS)) |
429 | (begin | |
6756d265 | 430 | (if (not (= len (bytevector-length bytes))) |
45037e75 AW |
431 | (error "unexpected length" section bytes)) |
432 | (bytevector-copy! bytes 0 bv offset len) | |
433 | (for-each (lambda (reloc) | |
d4da9ba9 | 434 | (process-reloc reloc bv offset symtab endianness)) |
45037e75 AW |
435 | relocs))))) |
436 | ||
6756d265 | 437 | (define (find-shstrndx objects) |
d4da9ba9 AW |
438 | "Find the section name string table in @var{objects}, and return its |
439 | section index." | |
6756d265 AW |
440 | (or-map (lambda (object) |
441 | (let* ((section (linker-object-section object)) | |
442 | (bv (linker-object-bv object)) | |
443 | (name (elf-section-name section))) | |
444 | (and (= (elf-section-type section) SHT_STRTAB) | |
445 | (equal? (false-if-exception (string-table-ref bv name)) | |
446 | ".shstrtab") | |
447 | (elf-section-index section)))) | |
448 | objects)) | |
449 | ||
d4da9ba9 AW |
450 | (define (add-elf-objects objects endianness word-size) |
451 | "Given the list of linker objects supplied by the user, add linker | |
452 | objects corresponding to parts of the ELF file: the null object, the ELF | |
453 | header, and the section table. | |
454 | ||
455 | Both of these internal objects include relocs, allowing their | |
456 | inter-object references to be patched up when the final image allocation | |
457 | is known. There is special support for patching up the segment table, | |
458 | however. Because the segment table needs to know the segment sizes, | |
459 | which is the difference between two symbols in image space, and there is | |
460 | no reloc kind that is the difference between two symbols, we make a hack | |
461 | and return a closure that patches up segment table entries. It seems to | |
462 | work. | |
463 | ||
464 | Returns two values: the procedure to patch the segment table, and the | |
465 | list of objects, augmented with objects for the special ELF sections." | |
466 | (define phoff (elf-header-len word-size)) | |
467 | (define phentsize (elf-program-header-len word-size)) | |
468 | (define shentsize (elf-section-header-len word-size)) | |
469 | (define shnum (+ (length objects) 3)) | |
470 | (define reloc-kind | |
471 | (case word-size | |
472 | ((4) 'abs32/1) | |
473 | ((8) 'abs64/1) | |
474 | (else (error "bad word size" word-size)))) | |
475 | ||
476 | ;; ELF requires that the first entry in the section table be of type | |
477 | ;; SHT_NULL. | |
478 | ;; | |
479 | (define (make-null-section) | |
480 | (make-linker-object (make-elf-section #:index 0 #:type SHT_NULL | |
481 | #:flags 0 #:addralign 0) | |
482 | #vu8() '() '())) | |
483 | ||
484 | ;; The ELF header and the segment table. | |
485 | ;; | |
486 | (define (make-header phnum index shoff-label) | |
487 | (let* ((header (make-elf #:byte-order endianness #:word-size word-size | |
488 | #:phoff phoff #:phnum phnum #:phentsize phentsize | |
489 | #:shoff 0 #:shnum shnum #:shentsize shentsize | |
490 | #:shstrndx (or (find-shstrndx objects) SHN_UNDEF))) | |
491 | (shoff-reloc (make-linker-reloc reloc-kind | |
492 | (elf-header-shoff-offset word-size) | |
493 | 0 | |
494 | shoff-label)) | |
495 | (size (+ phoff (* phnum phentsize))) | |
496 | (bv (make-bytevector size 0))) | |
497 | (write-elf-header bv header) | |
498 | ;; Leave the segment table uninitialized; it will be filled in | |
499 | ;; later by calls to the write-segment-header! closure. | |
500 | (make-linker-object (make-elf-section #:index index #:type SHT_PROGBITS | |
501 | #:flags SHF_ALLOC #:size size) | |
502 | bv | |
503 | (list shoff-reloc) | |
504 | '()))) | |
505 | ||
506 | ;; The section table. | |
507 | ;; | |
508 | (define (make-footer objects shoff-label) | |
509 | (let* ((size (* shentsize shnum)) | |
510 | (bv (make-bytevector size 0)) | |
511 | (section-table (make-elf-section #:index (length objects) | |
512 | #:type SHT_PROGBITS | |
513 | #:flags 0 | |
514 | #:size size))) | |
515 | (define (write-and-reloc section-label section relocs) | |
516 | (let ((offset (* shentsize (elf-section-index section)))) | |
517 | (write-elf-section-header bv offset endianness word-size section) | |
518 | (if (= (elf-section-type section) SHT_NULL) | |
519 | relocs | |
812c83d4 AW |
520 | (let ((relocs |
521 | (cons (make-linker-reloc | |
522 | reloc-kind | |
523 | (+ offset | |
524 | (elf-section-header-offset-offset word-size)) | |
525 | 0 | |
526 | section-label) | |
527 | relocs))) | |
528 | (if (zero? (logand SHF_ALLOC (elf-section-flags section))) | |
529 | relocs | |
530 | (cons (make-linker-reloc | |
531 | reloc-kind | |
532 | (+ offset | |
533 | (elf-section-header-addr-offset word-size)) | |
534 | 0 | |
535 | section-label) | |
536 | relocs)))))) | |
d4da9ba9 AW |
537 | (let ((relocs (fold-values |
538 | (lambda (object relocs) | |
539 | (write-and-reloc | |
540 | (linker-symbol-name | |
541 | (linker-object-section-symbol object)) | |
542 | (linker-object-section object) | |
543 | relocs)) | |
544 | objects | |
545 | (write-and-reloc shoff-label section-table '())))) | |
546 | (%make-linker-object section-table bv relocs | |
547 | (list (make-linker-symbol shoff-label 0)))))) | |
548 | ||
549 | (let* ((null-section (make-null-section)) | |
550 | (objects (cons null-section objects)) | |
551 | ||
552 | (shoff (gensym "*section-table*")) | |
553 | (header (make-header (count-segments objects) (length objects) shoff)) | |
554 | (objects (cons header objects)) | |
555 | ||
556 | (footer (make-footer objects shoff)) | |
557 | (objects (cons footer objects))) | |
558 | ||
559 | ;; The header includes the segment table, which needs offsets and | |
560 | ;; sizes of the segments. Normally we would use relocs to rewrite | |
561 | ;; these values, but there is no reloc type that would allow us to | |
562 | ;; compute size. Such a reloc would need to take the difference | |
563 | ;; between two symbols, and it's probably a bad idea architecturally | |
564 | ;; to create one. | |
565 | ;; | |
566 | ;; So instead we return a closure to patch up the segment table. | |
567 | ;; Normally we'd shy away from such destructive interfaces, but it's | |
568 | ;; OK as we create the header section ourselves. | |
569 | ;; | |
570 | (define (write-segment-header! segment) | |
571 | (let ((bv (linker-object-bv header)) | |
572 | (offset (+ phoff (* (elf-segment-index segment) phentsize)))) | |
573 | (write-elf-program-header bv offset endianness word-size segment))) | |
574 | ||
575 | (values write-segment-header! objects))) | |
576 | ||
6756d265 | 577 | (define (allocate-elf objects page-aligned? endianness word-size) |
d4da9ba9 AW |
578 | "Lay out @var{objects} into an ELF image, computing the size of the |
579 | file, the positions of the objects, and the global symbol table. | |
580 | ||
581 | If @var{page-aligned?} is true, read-only and writable data are | |
582 | separated so that only those writable parts of the image need be mapped | |
583 | with writable permissions. This makes the resulting image larger. It | |
584 | is more suitable to situations where you would write a file out to disk | |
585 | and read it in with mmap. Otherwise if @var{page-aligned?} is false, | |
586 | sections default to 8-byte alignment. | |
587 | ||
588 | Returns three values: the total image size, a list of objects with | |
589 | relocated headers, and the global symbol table." | |
590 | (receive (write-segment-header! objects) | |
591 | (add-elf-objects objects endianness word-size) | |
592 | (let lp ((seglists (collate-objects-into-segments objects)) | |
6756d265 AW |
593 | (objects '()) |
594 | (phidx 0) | |
d4da9ba9 | 595 | (addr 0) |
6756d265 AW |
596 | (symtab vlist-null) |
597 | (prev-flags 0)) | |
598 | (match seglists | |
599 | ((((type . flags) objs-in ...) seglists ...) | |
d4da9ba9 AW |
600 | (receive (addr objs-out symtab) |
601 | (allocate-segment | |
602 | write-segment-header! | |
603 | phidx type flags objs-in addr symtab | |
604 | (if (and page-aligned? | |
605 | (not (= flags prev-flags)) | |
606 | ;; Allow sections that are not in | |
607 | ;; loadable segments to share pages | |
608 | ;; with PF_R segments. | |
609 | (not (and (not type) (= PF_R prev-flags)))) | |
610 | *page-size* | |
611 | 8)) | |
6756d265 | 612 | (lp seglists |
6756d265 | 613 | (fold-values cons objs-out objects) |
d4da9ba9 AW |
614 | (if type (1+ phidx) phidx) |
615 | addr | |
6756d265 AW |
616 | symtab |
617 | flags))) | |
618 | (() | |
d4da9ba9 AW |
619 | (values addr |
620 | (reverse objects) | |
621 | symtab)))))) | |
6756d265 AW |
622 | |
623 | (define (check-section-numbers objects) | |
d4da9ba9 AW |
624 | "Verify that taken as a whole, that all objects have distinct, |
625 | contiguous section numbers, starting from 1. (Section 0 is the null | |
626 | section.)" | |
6756d265 AW |
627 | (let* ((nsections (1+ (length objects))) ; 1+ for initial NULL section. |
628 | (sections (make-vector nsections #f))) | |
629 | (for-each (lambda (object) | |
630 | (let ((n (elf-section-index (linker-object-section object)))) | |
631 | (cond | |
632 | ((< n 1) | |
633 | (error "Invalid section number" object)) | |
634 | ((>= n nsections) | |
635 | (error "Invalid section number" object)) | |
636 | ((vector-ref sections n) | |
637 | (error "Duplicate section" (vector-ref sections n) object)) | |
638 | (else | |
639 | (vector-set! sections n object))))) | |
640 | objects))) | |
45037e75 | 641 | |
d4da9ba9 AW |
642 | ;; Given a list of linker objects, collate the objects into segments, |
643 | ;; allocate the segments, allocate the ELF bytevector, and write the | |
644 | ;; segments into the bytevector, relocating as we go. | |
45037e75 AW |
645 | ;; |
646 | (define* (link-elf objects #:key | |
647 | (page-aligned? #t) | |
648 | (endianness (target-endianness)) | |
649 | (word-size (target-word-size))) | |
d4da9ba9 AW |
650 | "Create an ELF image from the linker objects, @var{objects}. |
651 | ||
652 | If @var{page-aligned?} is true, read-only and writable data are | |
653 | separated so that only those writable parts of the image need be mapped | |
654 | with writable permissions. This is suitable for situations where you | |
655 | would write a file out to disk and read it in with @code{mmap}. | |
656 | Otherwise if @var{page-aligned?} is false, sections default to 8-byte | |
657 | alignment. | |
658 | ||
659 | Returns a bytevector." | |
6756d265 | 660 | (check-section-numbers objects) |
d4da9ba9 | 661 | (receive (size objects symtab) |
6756d265 | 662 | (allocate-elf objects page-aligned? endianness word-size) |
d4da9ba9 AW |
663 | (let ((bv (make-bytevector size 0))) |
664 | (for-each | |
665 | (lambda (object) | |
666 | (write-linker-object bv object symtab endianness)) | |
667 | objects) | |
668 | bv))) |