[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 2/6] ELF refactor and consequent linker simplifications
|
From: |
Andy Wingo |
|
Subject: |
[PATCH 2/6] ELF refactor and consequent linker simplifications |
|
Date: |
Sat, 18 May 2013 17:05:36 +0200 |
* module/system/vm/elf.scm: Add commentary.
(make-elf): Add a constructor similar to make-elf-segment and
make-elf-section.
(write-elf32-header, write-elf64-header, write-elf-header): Take an
<elf> instead of all the fields separately.
(<elf-segment>, <elf-section>): Add "index" property. Adapt
constructors accordingly.
* module/language/objcode/elf.scm (bytecode->elf): Arrange to set the
section indexes when creating ELF sections.
* module/system/vm/linker.scm (alloc-segment, relocate-section-header):
Arrange to set segment and section indexes.
(find-shstrndx): New helper, replaces compute-sections-by-name. Now
that sections know their indexes, this is easier.
(allocate-elf, write-elf): New helpers, factored out of link-elf.
Easier now that sections have indexes.
(link-elf): Simplify. Check that the incoming objects have sensible
numbers.
* test-suite/tests/linker.test: Update to set #:index on the linker
objects.
---
module/language/objcode/elf.scm | 17 +--
module/system/vm/elf.scm | 188 +++++++++++++++++++--------------
module/system/vm/linker.scm | 223 +++++++++++++++++++++------------------
test-suite/tests/linker.test | 7 +-
4 files changed, 238 insertions(+), 197 deletions(-)
diff --git a/module/language/objcode/elf.scm b/module/language/objcode/elf.scm
index 1edfdcf..981c398 100644
--- a/module/language/objcode/elf.scm
+++ b/module/language/objcode/elf.scm
@@ -41,15 +41,16 @@
(lambda (table idx)
(set! string-table table)
idx)))
- (define (make-object name bv relocs . kwargs)
+ (define (make-object index name bv relocs . kwargs)
(let ((name-idx (intern-string! (symbol->string name))))
(make-linker-object (apply make-elf-section
+ #:index index
#:name name-idx
#:size (bytevector-length bv)
kwargs)
bv relocs
(list (make-linker-symbol name 0)))))
- (define (make-dynamic-section word-size endianness)
+ (define (make-dynamic-section index word-size endianness)
(define (make-dynamic-section/32)
(let ((bv (make-bytevector 24 0)))
(bytevector-u32-set! bv 0 DT_GUILE_RTL_VERSION endianness)
@@ -74,19 +75,19 @@
((8) (make-dynamic-section/64))
(else (error "unexpected word size" word-size))))
(lambda (bv reloc)
- (make-object '.dynamic bv (list reloc)
+ (make-object index '.dynamic bv (list reloc)
#:type SHT_DYNAMIC #:flags SHF_ALLOC))))
- (define (make-string-table)
+ (define (make-string-table index)
(intern-string! ".shstrtab")
- (make-object '.shstrtab (link-string-table string-table) '()
+ (make-object index '.shstrtab (link-string-table string-table) '()
#:type SHT_STRTAB #:flags 0))
(let* ((word-size (target-word-size))
(endianness (target-endianness))
- (text (make-object '.rtl-text bv '()))
- (dt (make-dynamic-section word-size endianness))
+ (text (make-object 1 '.rtl-text bv '()))
+ (dt (make-dynamic-section 2 word-size endianness))
;; This needs to be linked last, because linking other
;; sections adds entries to the string table.
- (shstrtab (make-string-table)))
+ (shstrtab (make-string-table 3)))
(link-elf (list text dt shstrtab)
#:endianness endianness #:word-size word-size))))
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
index e2b2454..efa9782 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -16,6 +16,19 @@
;;;; 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 module to read and write Executable and Linking Format (ELF)
+;;; files.
+;;;
+;;; This module exports a number of record types that represent the
+;;; various parts that make up ELF files. Fundamentally this is the
+;;; main header, the segment headers (program headers), and the section
+;;; headers. It also exports bindings for symbolic constants and
+;;; utilities to parse and write special kinds of ELF sections.
+;;;
+;;; See elf(5) for more information on ELF.
+;;;
;;; Code:
(define-module (system vm elf)
@@ -27,7 +40,8 @@
#:use-module (ice-9 vlist)
#:export (has-elf-header?
- make-elf elf?
+ (make-elf* . make-elf)
+ elf?
elf-bytes elf-word-size elf-byte-order
elf-abi elf-type elf-machine-type
elf-entry elf-phoff elf-shoff elf-flags elf-ehsize
@@ -37,6 +51,7 @@
(make-elf-segment* . make-elf-segment)
elf-segment?
+ elf-segment-index
elf-segment-type elf-segment-offset elf-segment-vaddr
elf-segment-paddr elf-segment-filesz elf-segment-memsz
elf-segment-flags elf-segment-align
@@ -51,6 +66,7 @@
(make-elf-section* . make-elf-section)
elf-section?
+ elf-section-index
elf-section-name elf-section-type elf-section-flags
elf-section-addr elf-section-offset elf-section-size
elf-section-link elf-section-info elf-section-addralign
@@ -242,6 +258,26 @@
(shnum elf-shnum)
(shstrndx elf-shstrndx))
+(define* (make-elf* #:key (bytes #f)
+ (byte-order (target-endianness))
+ (word-size (target-word-size))
+ (abi ELFOSABI_STANDALONE)
+ (type ET_DYN)
+ (machine-type EM_NONE)
+ (entry 0)
+ (phoff (elf-header-len word-size))
+ (shoff -1)
+ (flags 0)
+ (ehsize (elf-header-len word-size))
+ (phentsize (elf-program-header-len word-size))
+ (phnum 0)
+ (shentsize (elf-section-header-len word-size))
+ (shnum 0)
+ (shstrndx SHN_UNDEF))
+ (make-elf bytes word-size byte-order abi type machine-type
+ entry phoff shoff flags ehsize
+ phentsize phnum shentsize shnum shstrndx))
+
(define (parse-elf32 bv byte-order)
(make-elf bv 4 byte-order
(bytevector-u8-ref bv 7)
@@ -276,28 +312,27 @@
(bytevector-u8-set! bv 14 0)
(bytevector-u8-set! bv 15 0))
-(define (write-elf32 bv byte-order abi type machine-type
- entry phoff shoff flags ehsize phentsize phnum
- shentsize shnum shstrndx)
- (write-elf-ident bv ELFCLASS32
- (case byte-order
- ((little) ELFDATA2LSB)
- ((big) ELFDATA2MSB)
- (else (error "unknown endianness" byte-order)))
- abi)
- (bytevector-u16-set! bv 16 type byte-order)
- (bytevector-u16-set! bv 18 machine-type byte-order)
- (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
- (bytevector-u32-set! bv 24 entry byte-order)
- (bytevector-u32-set! bv 28 phoff byte-order)
- (bytevector-u32-set! bv 32 shoff byte-order)
- (bytevector-u32-set! bv 36 flags byte-order)
- (bytevector-u16-set! bv 40 ehsize byte-order)
- (bytevector-u16-set! bv 42 phentsize byte-order)
- (bytevector-u16-set! bv 44 phnum byte-order)
- (bytevector-u16-set! bv 46 shentsize byte-order)
- (bytevector-u16-set! bv 48 shnum byte-order)
- (bytevector-u16-set! bv 50 shstrndx byte-order))
+(define (write-elf32-header bv elf)
+ (let ((byte-order (elf-byte-order elf)))
+ (write-elf-ident bv ELFCLASS32
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ (elf-abi elf))
+ (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
+ (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u32-set! bv 24 (elf-entry elf) byte-order)
+ (bytevector-u32-set! bv 28 (elf-phoff elf) byte-order)
+ (bytevector-u32-set! bv 32 (elf-shoff elf) byte-order)
+ (bytevector-u32-set! bv 36 (elf-flags elf) byte-order)
+ (bytevector-u16-set! bv 40 (elf-ehsize elf) byte-order)
+ (bytevector-u16-set! bv 42 (elf-phentsize elf) byte-order)
+ (bytevector-u16-set! bv 44 (elf-phnum elf) byte-order)
+ (bytevector-u16-set! bv 46 (elf-shentsize elf) byte-order)
+ (bytevector-u16-set! bv 48 (elf-shnum elf) byte-order)
+ (bytevector-u16-set! bv 50 (elf-shstrndx elf) byte-order)))
(define (parse-elf64 bv byte-order)
(make-elf bv 8 byte-order
@@ -315,28 +350,27 @@
(bytevector-u16-ref bv 60 byte-order)
(bytevector-u16-ref bv 62 byte-order)))
-(define (write-elf64 bv byte-order abi type machine-type
- entry phoff shoff flags ehsize phentsize phnum
- shentsize shnum shstrndx)
- (write-elf-ident bv ELFCLASS64
- (case byte-order
- ((little) ELFDATA2LSB)
- ((big) ELFDATA2MSB)
- (else (error "unknown endianness" byte-order)))
- abi)
- (bytevector-u16-set! bv 16 type byte-order)
- (bytevector-u16-set! bv 18 machine-type byte-order)
- (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
- (bytevector-u64-set! bv 24 entry byte-order)
- (bytevector-u64-set! bv 32 phoff byte-order)
- (bytevector-u64-set! bv 40 shoff byte-order)
- (bytevector-u32-set! bv 48 flags byte-order)
- (bytevector-u16-set! bv 52 ehsize byte-order)
- (bytevector-u16-set! bv 54 phentsize byte-order)
- (bytevector-u16-set! bv 56 phnum byte-order)
- (bytevector-u16-set! bv 58 shentsize byte-order)
- (bytevector-u16-set! bv 60 shnum byte-order)
- (bytevector-u16-set! bv 62 shstrndx byte-order))
+(define (write-elf64-header bv elf)
+ (let ((byte-order (elf-byte-order elf)))
+ (write-elf-ident bv ELFCLASS64
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ (elf-abi elf))
+ (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
+ (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u64-set! bv 24 (elf-entry elf) byte-order)
+ (bytevector-u64-set! bv 32 (elf-phoff elf) byte-order)
+ (bytevector-u64-set! bv 40 (elf-shoff elf) byte-order)
+ (bytevector-u32-set! bv 48 (elf-flags elf) byte-order)
+ (bytevector-u16-set! bv 52 (elf-ehsize elf) byte-order)
+ (bytevector-u16-set! bv 54 (elf-phentsize elf) byte-order)
+ (bytevector-u16-set! bv 56 (elf-phnum elf) byte-order)
+ (bytevector-u16-set! bv 58 (elf-shentsize elf) byte-order)
+ (bytevector-u16-set! bv 60 (elf-shnum elf) byte-order)
+ (bytevector-u16-set! bv 62 (elf-shstrndx elf) byte-order)))
(define (parse-elf bv)
(cond
@@ -354,28 +388,12 @@
(else
(error "Invalid ELF" bv))))
-(define* (write-elf-header bv #:key
- (byte-order (target-endianness))
- (word-size (target-word-size))
- (abi ELFOSABI_STANDALONE)
- (type ET_DYN)
- (machine-type EM_NONE)
- (entry 0)
- (phoff (elf-header-len word-size))
- (shoff -1)
- (flags 0)
- (ehsize (elf-header-len word-size))
- (phentsize (elf-program-header-len word-size))
- (phnum 0)
- (shentsize (elf-section-header-len word-size))
- (shnum 0)
- (shstrndx SHN_UNDEF))
- ((case word-size
- ((4) write-elf32)
- ((8) write-elf64)
- (else (error "unknown word size" word-size)))
- bv byte-order abi type machine-type entry phoff shoff
- flags ehsize phentsize phnum shentsize shnum shstrndx))
+(define* (write-elf-header bv elf)
+ ((case (elf-word-size elf)
+ ((4) write-elf32-header)
+ ((8) write-elf64-header)
+ (else (error "unknown word size" (elf-word-size elf))))
+ bv elf))
;;
;; Segment types
@@ -402,8 +420,9 @@
(define PF_R (ash 1 2)) ; Segment is readable
(define-record-type <elf-segment>
- (make-elf-segment type offset vaddr paddr filesz memsz flags align)
+ (make-elf-segment index type offset vaddr paddr filesz memsz flags align)
elf-segment?
+ (index elf-segment-index)
(type elf-segment-type)
(offset elf-segment-offset)
(vaddr elf-segment-vaddr)
@@ -413,11 +432,11 @@
(flags elf-segment-flags)
(align elf-segment-align))
-(define* (make-elf-segment* #:key (type PT_LOAD) (offset 0) (vaddr 0)
+(define* (make-elf-segment* #:key (index -1) (type PT_LOAD) (offset 0) (vaddr
0)
(paddr 0) (filesz 0) (memsz filesz)
(flags (logior PF_W PF_R))
(align 8))
- (make-elf-segment type offset vaddr paddr filesz memsz flags align))
+ (make-elf-segment index type offset vaddr paddr filesz memsz flags align))
;; typedef struct {
;; uint32_t p_type;
@@ -430,9 +449,10 @@
;; uint32_t p_align;
;; } Elf32_Phdr;
-(define (parse-elf32-program-header bv offset byte-order)
+(define (parse-elf32-program-header index bv offset byte-order)
(if (<= (+ offset 32) (bytevector-length bv))
- (make-elf-segment (bytevector-u32-ref bv offset byte-order)
+ (make-elf-segment index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u32-ref bv (+ offset 4) byte-order)
(bytevector-u32-ref bv (+ offset 8) byte-order)
(bytevector-u32-ref bv (+ offset 12) byte-order)
@@ -466,9 +486,10 @@
;; NB: position of `flags' is different!
-(define (parse-elf64-program-header bv offset byte-order)
+(define (parse-elf64-program-header index bv offset byte-order)
(if (<= (+ offset 56) (bytevector-length bv))
- (make-elf-segment (bytevector-u32-ref bv offset byte-order)
+ (make-elf-segment index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u64-ref bv (+ offset 8) byte-order)
(bytevector-u64-ref bv (+ offset 16) byte-order)
(bytevector-u64-ref bv (+ offset 24) byte-order)
@@ -519,8 +540,10 @@
(lp (1- n) (cons (elf-segment elf (1- n)) out)))))
(define-record-type <elf-section>
- (make-elf-section name type flags addr offset size link info addralign
entsize)
+ (make-elf-section index name type flags
+ addr offset size link info addralign entsize)
elf-section?
+ (index elf-section-index)
(name elf-section-name)
(type elf-section-type)
(flags elf-section-flags)
@@ -532,10 +555,10 @@
(addralign elf-section-addralign)
(entsize elf-section-entsize))
-(define* (make-elf-section* #:key (name 0) (type SHT_PROGBITS)
+(define* (make-elf-section* #:key (index SHN_UNDEF) (name 0) (type
SHT_PROGBITS)
(flags SHF_ALLOC) (addr 0) (offset 0) (size 0)
(link 0) (info 0) (addralign 8) (entsize 0))
- (make-elf-section name type flags addr offset size link info addralign
+ (make-elf-section index name type flags addr offset size link info addralign
entsize))
;; typedef struct {
@@ -551,9 +574,10 @@
;; uint32_t sh_entsize;
;; } Elf32_Shdr;
-(define (parse-elf32-section-header bv offset byte-order)
+(define (parse-elf32-section-header index bv offset byte-order)
(if (<= (+ offset 40) (bytevector-length bv))
- (make-elf-section (bytevector-u32-ref bv offset byte-order)
+ (make-elf-section index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u32-ref bv (+ offset 4) byte-order)
(bytevector-u32-ref bv (+ offset 8) byte-order)
(bytevector-u32-ref bv (+ offset 12) byte-order)
@@ -597,9 +621,10 @@
((8) 64)
(else (error "bad word size" word-size))))
-(define (parse-elf64-section-header bv offset byte-order)
+(define (parse-elf64-section-header index bv offset byte-order)
(if (<= (+ offset 64) (bytevector-length bv))
- (make-elf-section (bytevector-u32-ref bv offset byte-order)
+ (make-elf-section index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u32-ref bv (+ offset 4) byte-order)
(bytevector-u64-ref bv (+ offset 8) byte-order)
(bytevector-u64-ref bv (+ offset 16) byte-order)
@@ -630,6 +655,7 @@
((4) parse-elf32-section-header)
((8) parse-elf64-section-header)
(else (error "unhandled pointer size")))
+ n
(elf-bytes elf)
(+ (elf-shoff elf) (* n (elf-shentsize elf)))
(elf-byte-order elf)))
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
index e9dca71..580981a 100644
--- a/module/system/vm/linker.scm
+++ b/module/system/vm/linker.scm
@@ -68,15 +68,13 @@
#: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-string-table
- string-table-intern
- link-string-table
-
- make-linker-reloc
+ #:export (make-linker-reloc
make-linker-symbol
make-linker-object
@@ -86,6 +84,10 @@
linker-object-relocs
linker-object-symbols
+ make-string-table
+ string-table-intern
+ link-string-table
+
link-elf))
;; A relocation records a reference to a symbol. When the symbol is
@@ -222,13 +224,6 @@
s0
(lp (cdr ls) (proc (car ls) s0)))))
-(define (fold2 proc ls s0 s1)
- (let lp ((ls ls) (s0 s0) (s1 s1))
- (if (null? ls)
- (values s0 s1)
- (receive (s0 s1) (proc (car ls) s0 s1)
- (lp (cdr ls) s0 s1)))))
-
(define (fold4 proc ls s0 s1 s2 s3)
(let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2) (s3 s3))
(if (null? ls)
@@ -236,15 +231,9 @@
(receive (s0 s1 s2 s3) (proc (car ls) s0 s1 s2 s3)
(lp (cdr ls) s0 s1 s2 s3)))))
-(define (fold5 proc ls s0 s1 s2 s3 s4)
- (let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2) (s3 s3) (s4 s4))
- (if (null? ls)
- (values s0 s1 s2 s3 s4)
- (receive (s0 s1 s2 s3 s4) (proc (car ls) s0 s1 s2 s3 s4)
- (lp (cdr ls) s0 s1 s2 s3 s4)))))
-
(define (relocate-section-header sec fileaddr memaddr)
- (make-elf-section #:name (elf-section-name sec)
+ (make-elf-section #:index (elf-section-index sec)
+ #:name (elf-section-name sec)
#:type (elf-section-type sec)
#:flags (elf-section-flags sec)
#:addr memaddr
@@ -269,7 +258,8 @@
symbols
symtab))
-(define (alloc-segment type flags objects fileaddr memaddr symtab alignment)
+(define (alloc-segment phidx type flags objects
+ fileaddr memaddr symtab alignment)
(let* ((loadable? (not (zero? flags)))
(alignment (fold1 (lambda (o alignment)
(lcm (elf-section-addralign
@@ -303,7 +293,8 @@
(add-symbols (linker-object-symbols o) memaddr symtab))))
objects '() fileaddr memaddr symtab)
(values
- (make-elf-segment #:type type #:offset fileaddr
+ (make-elf-segment #:index phidx
+ #:type type #:offset fileaddr
#:vaddr (if loadable? memaddr 0)
#:filesz (- fileend fileaddr)
#:memsz (if loadable? (- memend memaddr) 0)
@@ -342,34 +333,113 @@
(relocs (linker-object-relocs o)))
(if (not (= (elf-section-type section) SHT_NOBITS))
(begin
- (if (not (= (elf-section-size section) (bytevector-length bytes)))
+ (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 addr symtab endianness))
relocs)))))
-(define (compute-sections-by-name seglists)
- (let lp ((in (apply append (map cdr seglists)))
- (n 1) (out '()) (shstrtab #f))
- (if (null? in)
- (fold1 (lambda (x tail)
- (cond
- ((false-if-exception
- (string-table-ref shstrtab (car x)))
- => (lambda (str) (acons str (cdr x) tail)))
- (else tail)))
- out '())
- (let* ((section (linker-object-section (car in)))
- (bv (linker-object-bv (car in)))
- (name (elf-section-name section)))
- (lp (cdr in) (1+ n) (acons name n out)
- (or shstrtab
- (and (= (elf-section-type section) SHT_STRTAB)
- (equal? (false-if-exception
- (string-table-ref bv name))
- ".shstrtab")
- bv)))))))
+(define (find-shstrndx objects)
+ (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))
+
+;; objects ::= list of <linker-object>
+;; => 3 values: ELF header, program headers, objects
+(define (allocate-elf objects page-aligned? endianness word-size)
+ (let* ((seglists (collate-objects-into-segments objects))
+ (nsegments (length seglists))
+ (nsections (1+ (length objects))) ;; 1+ for the first reserved entry.
+ (program-headers-offset (elf-header-len word-size))
+ (fileaddr (+ program-headers-offset
+ (* nsegments (elf-program-header-len word-size))))
+ (memaddr 0))
+ (let lp ((seglists seglists)
+ (segments '())
+ (objects '())
+ (phidx 0)
+ (fileaddr fileaddr)
+ (memaddr memaddr)
+ (symtab vlist-null)
+ (prev-flags 0))
+ (match seglists
+ ((((type . flags) objs-in ...) seglists ...)
+ (receive (segment objs-out symtab)
+ (alloc-segment phidx type flags objs-in fileaddr memaddr symtab
+ (if (and page-aligned?
+ (not (= flags prev-flags)))
+ *page-size*
+ 8))
+ (lp seglists
+ (cons segment segments)
+ (fold1 cons objs-out objects)
+ (1+ phidx)
+ (+ (elf-segment-offset segment) (elf-segment-filesz segment))
+ (if (zero? (elf-segment-memsz segment))
+ memaddr
+ (+ (elf-segment-vaddr segment)
+ (elf-segment-memsz segment)))
+ symtab
+ flags)))
+ (()
+ (let ((section-table-offset (+ (align fileaddr word-size))))
+ (values
+ (make-elf #:byte-order endianness #:word-size word-size
+ #:phoff program-headers-offset #:phnum nsegments
+ #:shoff section-table-offset #:shnum nsections
+ #:shstrndx (or (find-shstrndx objects) SHN_UNDEF))
+ (reverse segments)
+ (let ((null-section (make-elf-section #:index 0 #:type SHT_NULL
+ #:flags 0 #:addralign 0)))
+ (cons (make-linker-object null-section #vu8() '() '())
+ (reverse objects)))
+ symtab)))))))
+
+(define (write-elf header segments objects symtab)
+ (define (phoff n)
+ (+ (elf-phoff header) (* n (elf-phentsize header))))
+ (define (shoff n)
+ (+ (elf-shoff header) (* n (elf-shentsize header))))
+ (let ((endianness (elf-byte-order header))
+ (word-size (elf-word-size header))
+ (bv (make-bytevector (shoff (elf-shnum header)) 0)))
+ (write-elf-header bv header)
+ (for-each
+ (lambda (segment)
+ (write-elf-program-header bv (phoff (elf-segment-index segment))
+ endianness word-size segment))
+ segments)
+ (for-each
+ (lambda (object)
+ (let ((section (linker-object-section object)))
+ (write-elf-section-header bv (shoff (elf-section-index section))
+ endianness word-size section))
+ (write-linker-object bv object symtab endianness))
+ objects)
+ bv))
+
+(define (check-section-numbers objects)
+ (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 section-header/bytevector pairs, collate the sections
;; into segments, allocate the segments, allocate the ELF bytevector,
@@ -379,64 +449,7 @@
(page-aligned? #t)
(endianness (target-endianness))
(word-size (target-word-size)))
- (let* ((seglists (collate-objects-into-segments objects))
- (sections-by-name (compute-sections-by-name seglists))
- (nsegments (length seglists))
- (nsections (1+ (length objects))) ;; 1+ for the first reserved entry.
- (program-headers-offset (elf-header-len word-size))
- (fileaddr (+ program-headers-offset
- (* nsegments (elf-program-header-len word-size))))
- (memaddr 0))
- (receive (out fileend memend symtab _)
- (fold5
- (lambda (x out fileaddr memaddr symtab prev-flags)
- (let ((type (caar x))
- (flags (cdar x))
- (objects (cdr x)))
- (receive (segment objects symtab)
- (alloc-segment type flags objects fileaddr memaddr symtab
- (if (and page-aligned?
- (not (= flags prev-flags)))
- *page-size*
- 8))
- (values
- (cons (cons segment objects) out)
- (+ (elf-segment-offset segment) (elf-segment-filesz segment))
- (if (zero? (elf-segment-memsz segment))
- memaddr
- (+ (elf-segment-vaddr segment)
- (elf-segment-memsz segment)))
- symtab
- flags))))
- seglists '() fileaddr memaddr vlist-null 0)
- (let* ((out (reverse! out))
- (section-table-offset (+ (align fileend word-size)))
- (fileend (+ section-table-offset
- (* nsections (elf-section-header-len word-size))))
- (bv (make-bytevector fileend 0)))
- (write-elf-header bv #:byte-order endianness #:word-size word-size
- #:phoff program-headers-offset #:phnum nsegments
- #:shoff section-table-offset #:shnum nsections
- #:shstrndx (or (assoc-ref sections-by-name
".shstrtab")
- SHN_UNDEF))
- (write-elf-section-header bv section-table-offset
- endianness word-size
- (make-elf-section #:type SHT_NULL #:flags 0
- #:addralign 0))
- (fold2 (lambda (x phidx shidx)
- (write-elf-program-header
- bv (+ program-headers-offset
- (* (elf-program-header-len word-size) phidx))
- endianness word-size (car x))
- (values
- (1+ phidx)
- (fold1 (lambda (o shidx)
- (write-linker-object bv o symtab endianness)
- (write-elf-section-header
- bv (+ section-table-offset
- (* (elf-section-header-len word-size) shidx))
- endianness word-size (linker-object-section o))
- (1+ shidx))
- (cdr x) shidx)))
- out 0 1)
- bv))))
+ (check-section-numbers objects)
+ (receive (header segments objects symtab)
+ (allocate-elf objects page-aligned? endianness word-size)
+ (write-elf header segments objects symtab)))
diff --git a/test-suite/tests/linker.test b/test-suite/tests/linker.test
index 7ea2631..97f7912 100644
--- a/test-suite/tests/linker.test
+++ b/test-suite/tests/linker.test
@@ -31,9 +31,10 @@
(lambda (table idx)
(set! string-table table)
idx)))
- (define (make-object name bv relocs . kwargs)
+ (define (make-object index name bv relocs . kwargs)
(let ((name-idx (intern-string! (symbol->string name))))
(make-linker-object (apply make-elf-section
+ #:index index
#:name name-idx
#:size (bytevector-length bv)
kwargs)
@@ -41,11 +42,11 @@
(list (make-linker-symbol name 0)))))
(define (make-string-table)
(intern-string! ".shstrtab")
- (make-object '.shstrtab (link-string-table string-table) '()
+ (make-object 2 '.shstrtab (link-string-table string-table) '()
#:type SHT_STRTAB #:flags 0))
(let* ((word-size (target-word-size))
(endianness (target-endianness))
- (sec (make-object name bytes '()))
+ (sec (make-object 1 name bytes '()))
;; This needs to be linked last, because linking other
;; sections adds entries to the string table.
(shstrtab (make-string-table)))
--
1.7.10.4