summaryrefslogtreecommitdiff
path: root/module/system/vm/linker.scm
blob: 9a51778574c31cb59c73f446c03bc43a6aacc40c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
;;; Guile ELF linker

;; Copyright (C)  2011, 2012, 2013 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:
;;;
;;; A linker combines several linker objects into an executable or a
;;; loadable library.
;;;
;;; There are several common formats for libraries out there.  Since
;;; Guile includes its own linker and loader, we are free to choose any
;;; format, or make up our own.
;;;
;;; There are essentially two requirements for a linker format:
;;; libraries should be able to be loaded with the minimal amount of
;;; work; and they should support introspection in some way, in order to
;;; enable good debugging.
;;;
;;; These requirements are somewhat at odds, as loading should not have
;;; to stumble over features related to introspection.  It so happens
;;; that a lot of smart people have thought about this situation, and
;;; the ELF format embodies the outcome of their thinking.  Guile uses
;;; ELF as its format, regardless of the platform's native library
;;; format.  It's not inconceivable that Guile could interoperate with
;;; the native dynamic loader at some point, but it's not a near-term
;;; goal.
;;;
;;; Guile's linker takes a list of objects, sorts them according to
;;; similarity from the perspective of the loader, then writes them out
;;; into one big bytevector in ELF format.
;;;
;;; It is often the case that different parts of a library need to refer
;;; to each other.  For example, program text may need to refer to a
;;; constant from writable memory.  When the linker places sections
;;; (linker objects) into specific locations in the linked bytevector,
;;; it needs to fix up those references.  This process is called
;;; /relocation/.  References needing relocations are recorded in
;;; "linker-reloc" objects, and collected in a list in each
;;; "linker-object".  The actual definitions of the references are
;;; stored in "linker-symbol" objects, also collected in a list in each
;;; "linker-object".
;;;
;;; By default, the ELF files created by the linker include some padding
;;; so that different parts of the file can be loaded in with different
;;; permissions.  For example, some parts of the file are read-only and
;;; thus can be shared between processes.  Some parts of the file don't
;;; need to be loaded at all.  However this padding can be too much for
;;; interactive compilation, when the code is never written out to disk;
;;; in that case, pass #:page-aligned? #f to `link-elf'.
;;;
;;; Code:

(define-module (system vm linker)
  #:use-module (rnrs bytevectors)
  #:use-module (system foreign)
  #:use-module (system base target)
  #:use-module ((srfi srfi-1) #:select (append-map))
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 match)
  #:use-module (system vm elf)
  #:export (make-linker-reloc
            make-linker-symbol

            make-linker-object
            linker-object?
            linker-object-section
            linker-object-bv
            linker-object-relocs
            (linker-object-symbols* . linker-object-symbols)

            make-string-table
            string-table-intern!
            link-string-table!

            link-elf))

(define-syntax fold-values
  (lambda (x)
    (syntax-case x ()
      ((_ proc list seed ...)
       (with-syntax (((s ...) (generate-temporaries #'(seed ...))))
         #'(let ((p proc))
             (let lp ((l list) (s seed) ...)
               (match l
                 (() (values s ...))
                 ((elt . l)
                  (call-with-values (lambda () (p elt s ...))
                    (lambda (s ...) (lp l s ...))))))))))))

;; A relocation records a reference to a symbol.  When the symbol is
;; resolved to an address, the reloc location will be updated to point
;; to the address.
;;
;; Two types.  Abs32/1 and Abs64/1 are absolute offsets in bytes.
;; Rel32/4 is a relative signed offset in 32-bit units.  Either can have
;; an arbitrary addend as well.
;;
(define-record-type <linker-reloc>
  (make-linker-reloc type loc addend symbol)
  linker-reloc?
  (type linker-reloc-type) ;; rel32/4, abs32/1, abs64/1
  (loc linker-reloc-loc)
  (addend linker-reloc-addend)
  (symbol linker-reloc-symbol))

;; A symbol is an association between a name and an address.  The
;; address is always in regard to some particular address space.  When
;; objects come into the linker, their symbols live in the object
;; address space.  When the objects are allocated into ELF segments, the
;; symbols will be relocated into memory address space, corresponding to
;; the position the ELF will be loaded at.
;;
(define-record-type <linker-symbol>
  (make-linker-symbol name address)
  linker-symbol?
  (name linker-symbol-name)
  (address linker-symbol-address))

(define-record-type <linker-object>
  (%make-linker-object section bv relocs symbols)
  linker-object?
  (section linker-object-section)
  (bv linker-object-bv)
  (relocs linker-object-relocs)
  (symbols linker-object-symbols))

(define (make-linker-object section bv relocs symbols)
  "Create a linker object with the @code{<elf-section>} header
@var{section}, bytevector contents @var{bv}, list of linker relocations
@var{relocs}, and list of linker symbols @var{symbols}."
  (%make-linker-object section bv relocs
                       ;; Hide a symbol to the beginning of the section
                       ;; in the symbols.
                       (cons (make-linker-symbol (gensym "*section*") 0)
                             symbols)))
(define (linker-object-section-symbol object)
  "Return the linker symbol corresponding to the start of this section."
  (car (linker-object-symbols object)))
(define (linker-object-symbols* object)
  "Return the linker symbols defined by the user for this this section."
  (cdr (linker-object-symbols object)))

(define-record-type <string-table>
  (%make-string-table strings linked?)
  string-table?
  (strings string-table-strings set-string-table-strings!)
  (linked? string-table-linked? set-string-table-linked?!))

(define (make-string-table)
  "Return a string table with one entry: the empty string."
  (%make-string-table '(("" 0 #vu8())) #f))

(define (string-table-length strings)
  "Return the number of bytes needed for the @var{strings}."
  (match strings
    (((str pos bytes) . _)
     ;; The + 1 is for the trailing NUL byte.
     (+ pos (bytevector-length bytes) 1))))

(define (string-table-intern! table str)
  "Ensure that @var{str} is present in the string table @var{table}.
Returns the byte index of the string in that table."
  (match table
    (($ <string-table> strings linked?)
     (match (assoc str strings)
       ((_ pos _) pos)
       (#f
        (let ((next (string-table-length strings)))
          (when linked?
            (error "string table already linked, can't intern" table str))
          (set-string-table-strings! table
                                     (cons (list str next (string->utf8 str))
                                           strings))
          next))))))

(define (link-string-table! table)
  "Link the functional string table @var{table} into a sequence of
bytes, suitable for use as the contents of an ELF string table section."
  (match table
    (($ <string-table> strings #f)
     (let ((out (make-bytevector (string-table-length strings) 0)))
       (for-each
        (match-lambda
         ((_ pos bytes)
          (bytevector-copy! bytes 0 out pos (bytevector-length bytes))))
        strings)
       (set-string-table-linked?! table #t)
       out))))

(define (segment-kind section)
  "Return the type of segment needed to store @var{section}, as a pair.
The car is the @code{PT_} segment type, or @code{#f} if the section
doesn't need to be present in a loadable segment.  The cdr is a bitfield
of associated @code{PF_} permissions."
  (let ((flags (elf-section-flags section)))
    (cons (cond
           ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
           ;; Sections without SHF_ALLOC don't go in segments.
           ((zero? flags) #f)
           (else PT_LOAD))
          (logior (if (zero? (logand SHF_ALLOC flags))
                      0
                      PF_R)
                  (if (zero? (logand SHF_EXECINSTR flags))
                      0
                      PF_X)
                  (if (zero? (logand SHF_WRITE flags))
                      0
                      PF_W)))))

(define (count-segments objects)
  "Return the total number of segments needed to represent the linker
objects in @var{objects}, including the segment needed for the ELF
header and segment table."
  (length
   (fold-values (lambda (object kinds)
                  (let ((kind (segment-kind (linker-object-section object))))
                    (if (and (car kind) (not (member kind kinds)))
                        (cons kind kinds)
                        kinds)))
                objects
                ;; We know there will be at least one segment,
                ;; containing at least the header and segment table.
                (list (cons PT_LOAD PF_R)))))

(define (group-by-cars ls)
  (let lp ((ls ls) (k #f) (group #f) (out '()))
    (match ls
      (()
       (reverse!
        (if group
            (cons (cons k (reverse! group)) out)
            out)))
      (((k* . v) . ls)
       (if (and group (equal? k k*))
           (lp ls k (cons v group) out)
           (lp ls k* (list v)
               (if group
                   (cons (cons k (reverse! group)) out)
                   out)))))))

(define (collate-objects-into-segments objects)
  "Given the list of linker objects @var{objects}, group them into
contiguous ELF segments of the same type and flags.  The result is an
alist that maps segment types to lists of linker objects.  See
@code{segment-type} for a description of segment types.  Within a
segment, the order of the linker objects is preserved."
  (group-by-cars
   (stable-sort!
    (map (lambda (o)
           (cons (segment-kind (linker-object-section o)) o))
         objects)
    (lambda (x y)
      (let* ((x-kind (car x)) (y-kind (car y))
             (x-type (car x-kind)) (y-type (car y-kind))
             (x-flags (cdr x-kind)) (y-flags (cdr y-kind))
             (x-section (linker-object-section (cdr x)))
             (y-section (linker-object-section (cdr y))))
        (cond
         ((not (equal? x-kind y-kind))
          (cond
           ((and x-type y-type)
            (cond
             ((not (equal? x-flags y-flags))
              (< x-flags y-flags))
             (else
              (< x-type y-type))))
           (else
            (not y-type))))
         ((not (equal? (elf-section-type x-section)
                       (elf-section-type y-section)))
          (cond
           ((equal? (elf-section-type x-section) SHT_NOBITS) #t)
           ((equal? (elf-section-type y-section) SHT_NOBITS) #f)
           (else (< (elf-section-type x-section)
                    (elf-section-type y-section)))))
         (else
          ;; Leave them in the initial order.  This allows us to ensure
          ;; that the ELF header is written first.
          #f)))))))

(define (align address alignment)
  (if (zero? alignment)
      address
      (+ address
         (modulo (- alignment (modulo address alignment)) alignment))))

(define (relocate-section-header sec addr)
  "Return a new section header, just like @var{sec} but with its
@code{addr} and @code{offset} set to @var{addr}."
  (make-elf-section #:index (elf-section-index sec)
                    #:name (elf-section-name sec)
                    #:type (elf-section-type sec)
                    #:flags (elf-section-flags sec)
                    #:addr addr
                    #:offset addr
                    #:size (elf-section-size sec)
                    #:link (elf-section-link sec)
                    #:info (elf-section-info sec)
                    #:addralign (elf-section-addralign sec)
                    #:entsize (elf-section-entsize sec)))

(define *page-size* 4096)

(define (add-symbols symbols offset symtab)
  "Add @var{symbols} to the symbol table @var{symtab}, relocating them
from object address space to memory address space.  Returns a new symbol
table."
  (fold-values
   (lambda (symbol symtab)
     (let ((name (linker-symbol-name symbol))
           (addr (linker-symbol-address symbol)))
       (when (vhash-assq name symtab)
         (error "duplicate symbol" name))
       (vhash-consq name (make-linker-symbol name (+ addr offset)) symtab)))
   symbols
   symtab))

(define (allocate-segment write-segment-header!
                          phidx type flags objects addr symtab alignment)
  "Given a list of linker objects that should go in a segment, the type
and flags that the segment should have, and the address at which the
segment should start, compute the positions that each object should have
in the segment.

Returns three values: the address of the next byte after the segment, a
list of relocated objects, and the symbol table.  The symbol table is
the same as @var{symtab}, augmented with the symbols defined in
@var{objects}, relocated to their positions in the image.

In what is something of a quirky interface, this routine also patches up
the segment table using @code{write-segment-header!}."
  (let* ((alignment (fold-values (lambda (o alignment)
                                   (lcm (elf-section-addralign
                                         (linker-object-section o))
                                        alignment))
                                 objects
                                 alignment))
         (addr (align addr alignment)))
    (receive (objects endaddr symtab)
        (fold-values
         (lambda (o out addr symtab)
           (let* ((section (linker-object-section o))
                  (addr (align addr (elf-section-addralign section))))
             (values
              (cons (make-linker-object
                     (relocate-section-header section addr)
                     (linker-object-bv o)
                     (linker-object-relocs o)
                     (linker-object-symbols o))
                    out)
              (+ addr (elf-section-size section))
              (add-symbols (linker-object-symbols o) addr symtab))))
         objects
         '() addr symtab)
      (when type
        (write-segment-header!
         (make-elf-segment #:index phidx #:type type
                           #:offset addr #:vaddr addr
                           #:filesz (- endaddr addr) #:memsz (- endaddr addr)
                           #:flags flags #:align alignment)))
      (values endaddr
              (reverse objects)
              symtab))))

(define (process-reloc reloc bv section-offset symtab endianness)
  "Process a relocation.  Given that a section containing @var{reloc}
was just written into the image @var{bv} at offset @var{section-offset},
fix it up so that its reference points to the correct position of its
symbol, as present in @var{symtab}."
  (match (vhash-assq (linker-reloc-symbol reloc) symtab)
    (#f
     (error "Undefined symbol" (linker-reloc-symbol reloc)))
    ((name . symbol)
     ;; The reloc was written at LOC bytes after SECTION-OFFSET.
     (let* ((offset (+ (linker-reloc-loc reloc) section-offset))
            (target (linker-symbol-address symbol)))
       (case (linker-reloc-type reloc)
         ((rel32/4)
          (let ((diff (- target offset)))
            (unless (zero? (modulo diff 4))
              (error "Bad offset" reloc symbol offset))
            (bytevector-s32-set! bv offset
                                 (+ (/ diff 4) (linker-reloc-addend reloc))
                                 endianness)))
         ((abs32/1)
          (bytevector-u32-set! bv offset target endianness))
         ((abs64/1)
          (bytevector-u64-set! bv offset target endianness))
         (else
          (error "bad reloc type" reloc)))))))

(define (write-linker-object bv o symtab endianness)
  "Write the bytevector for the section wrapped by the linker object
@var{o} into the image @var{bv}.  The section header in @var{o} should
already be relocated its final position in the image.  Any relocations
in the section will be processed to point to the correct symbol
locations, as given in @var{symtab}."
  (let* ((section (linker-object-section o))
         (offset (elf-section-offset section))
         (len (elf-section-size section))
         (bytes (linker-object-bv o))
         (relocs (linker-object-relocs o)))
    (unless (= offset (elf-section-addr section))
      (error "offset != addr" section))
    (if (not (= (elf-section-type section) SHT_NOBITS))
        (begin
          (if (not (= len (bytevector-length bytes)))
              (error "unexpected length" section bytes))
          (bytevector-copy! bytes 0 bv offset len)
          (for-each (lambda (reloc)
                      (process-reloc reloc bv offset symtab endianness))
                    relocs)))))

(define (find-shstrndx objects)
  "Find the section name string table in @var{objects}, and return its
section index."
  (or-map (lambda (object)
            (let* ((section (linker-object-section object))
                   (bv (linker-object-bv object))
                   (name (elf-section-name section)))
              (and (= (elf-section-type section) SHT_STRTAB)
                   (equal? (false-if-exception (string-table-ref bv name))
                           ".shstrtab")
                   (elf-section-index section))))
          objects))

(define (add-elf-objects objects endianness word-size)
  "Given the list of linker objects supplied by the user, add linker
objects corresponding to parts of the ELF file: the null object, the ELF
header, and the section table.

Both of these internal objects include relocs, allowing their
inter-object references to be patched up when the final image allocation
is known.  There is special support for patching up the segment table,
however.  Because the segment table needs to know the segment sizes,
which is the difference between two symbols in image space, and there is
no reloc kind that is the difference between two symbols, we make a hack
and return a closure that patches up segment table entries.  It seems to
work.

Returns two values: the procedure to patch the segment table, and the
list of objects, augmented with objects for the special ELF sections."
  (define phoff (elf-header-len word-size))
  (define phentsize (elf-program-header-len word-size))
  (define shentsize (elf-section-header-len word-size))
  (define shnum (+ (length objects) 3))
  (define reloc-kind
    (case word-size
      ((4) 'abs32/1)
      ((8) 'abs64/1)
      (else (error "bad word size" word-size))))

  ;; ELF requires that the first entry in the section table be of type
  ;; SHT_NULL.
  ;;
  (define (make-null-section)
    (make-linker-object (make-elf-section #:index 0 #:type SHT_NULL
                                          #:flags 0 #:addralign 0)
                        #vu8() '() '()))

  ;; The ELF header and the segment table.
  ;;
  (define (make-header phnum index shoff-label)
    (let* ((header (make-elf #:byte-order endianness #:word-size word-size
                             #:phoff phoff #:phnum phnum #:phentsize phentsize
                             #:shoff 0 #:shnum shnum #:shentsize shentsize
                             #:shstrndx (or (find-shstrndx objects) SHN_UNDEF)))
           (shoff-reloc (make-linker-reloc reloc-kind
                                           (elf-header-shoff-offset word-size)
                                           0
                                           shoff-label))
           (size (+ phoff (* phnum phentsize)))
           (bv (make-bytevector size 0)))
      (write-elf-header bv header)
      ;; Leave the segment table uninitialized; it will be filled in
      ;; later by calls to the write-segment-header! closure.
      (make-linker-object (make-elf-section #:index index #:type SHT_PROGBITS
                                            #:flags SHF_ALLOC #:size size)
                          bv
                          (list shoff-reloc)
                          '())))

  ;; The section table.
  ;;
  (define (make-footer objects shoff-label)
    (let* ((size (* shentsize shnum))
           (bv (make-bytevector size 0))
           (section-table (make-elf-section #:index (length objects)
                                            #:type SHT_PROGBITS
                                            #:flags 0
                                            #:size size)))
      (define (write-and-reloc section-label section relocs)
        (let ((offset (* shentsize (elf-section-index section))))
          (write-elf-section-header bv offset endianness word-size section)
          (if (= (elf-section-type section) SHT_NULL)
              relocs
              (cons* (make-linker-reloc
                      reloc-kind
                      (+ offset (elf-section-header-addr-offset word-size))
                      0
                      section-label)
                     (make-linker-reloc
                      reloc-kind
                      (+ offset (elf-section-header-offset-offset word-size))
                      0
                      section-label)
                     relocs))))
      (let ((relocs (fold-values
                     (lambda (object relocs)
                       (write-and-reloc
                        (linker-symbol-name
                         (linker-object-section-symbol object))
                        (linker-object-section object)
                        relocs))
                     objects
                     (write-and-reloc shoff-label section-table '()))))
        (%make-linker-object section-table bv relocs
                             (list (make-linker-symbol shoff-label 0))))))

  (let* ((null-section (make-null-section))
         (objects (cons null-section objects))

         (shoff (gensym "*section-table*"))
         (header (make-header (count-segments objects) (length objects) shoff))
         (objects (cons header objects))

         (footer (make-footer objects shoff))
         (objects (cons footer objects)))

    ;; The header includes the segment table, which needs offsets and
    ;; sizes of the segments.  Normally we would use relocs to rewrite
    ;; these values, but there is no reloc type that would allow us to
    ;; compute size.  Such a reloc would need to take the difference
    ;; between two symbols, and it's probably a bad idea architecturally
    ;; to create one.
    ;;
    ;; So instead we return a closure to patch up the segment table.
    ;; Normally we'd shy away from such destructive interfaces, but it's
    ;; OK as we create the header section ourselves.
    ;;
    (define (write-segment-header! segment)
      (let ((bv (linker-object-bv header))
            (offset (+ phoff (* (elf-segment-index segment) phentsize))))
        (write-elf-program-header bv offset endianness word-size segment)))

    (values write-segment-header! objects)))

(define (allocate-elf objects page-aligned? endianness word-size)
  "Lay out @var{objects} into an ELF image, computing the size of the
file, the positions of the objects, and the global symbol table.

If @var{page-aligned?} is true, read-only and writable data are
separated so that only those writable parts of the image need be mapped
with writable permissions.  This makes the resulting image larger.  It
is more suitable to situations where you would write a file out to disk
and read it in with mmap.  Otherwise if @var{page-aligned?} is false,
sections default to 8-byte alignment.

Returns three values: the total image size, a list of objects with
relocated headers, and the global symbol table."
  (receive (write-segment-header! objects)
      (add-elf-objects objects endianness word-size)
    (let lp ((seglists (collate-objects-into-segments objects))
             (objects '())
             (phidx 0)
             (addr 0)
             (symtab vlist-null)
             (prev-flags 0))
      (match seglists
        ((((type . flags) objs-in ...) seglists ...)
         (receive (addr objs-out symtab)
             (allocate-segment
              write-segment-header!
              phidx type flags objs-in addr symtab
              (if (and page-aligned?
                       (not (= flags prev-flags))
                       ;; Allow sections that are not in
                       ;; loadable segments to share pages
                       ;; with PF_R segments.
                       (not (and (not type) (= PF_R prev-flags))))
                  *page-size*
                  8))
           (lp seglists
               (fold-values cons objs-out objects)
               (if type (1+ phidx) phidx)
               addr
               symtab
               flags)))
        (()
         (values addr
                 (reverse objects)
                 symtab))))))

(define (check-section-numbers objects)
  "Verify that taken as a whole, that all objects have distinct,
contiguous section numbers, starting from 1.  (Section 0 is the null
section.)"
  (let* ((nsections (1+ (length objects))) ; 1+ for initial NULL section.
         (sections (make-vector nsections #f)))
    (for-each (lambda (object)
                (let ((n (elf-section-index (linker-object-section object))))
                  (cond
                   ((< n 1)
                    (error "Invalid section number" object))
                   ((>= n nsections)
                    (error "Invalid section number" object))
                   ((vector-ref sections n)
                    (error "Duplicate section" (vector-ref sections n) object))
                   (else
                    (vector-set! sections n object)))))
              objects)))

;; Given a list of linker objects, collate the objects into segments,
;; allocate the segments, allocate the ELF bytevector, and write the
;; segments into the bytevector, relocating as we go.
;;
(define* (link-elf objects #:key
                   (page-aligned? #t)
                   (endianness (target-endianness))
                   (word-size (target-word-size)))
  "Create an ELF image from the linker objects, @var{objects}.

If @var{page-aligned?} is true, read-only and writable data are
separated so that only those writable parts of the image need be mapped
with writable permissions.  This is suitable for situations where you
would write a file out to disk and read it in with @code{mmap}.
Otherwise if @var{page-aligned?} is false, sections default to 8-byte
alignment.

Returns a bytevector."
  (check-section-numbers objects)
  (receive (size objects symtab)
      (allocate-elf objects page-aligned? endianness word-size)
    (let ((bv (make-bytevector size 0)))
      (for-each
       (lambda (object)
         (write-linker-object bv object symtab endianness))
       objects)
      bv)))