diff options
author | Andy Wingo <wingo@pobox.com> | 2013-04-21 16:06:36 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-05-23 11:02:02 +0200 |
commit | 6756d265ed53d7b107d31746e8455f10e2ecebdd (patch) | |
tree | 098cc14e9ff6f481e3d0ccad6a929faa310bbc8e | |
parent | 45037e75277b622334f347ef261ea347eec6e28d (diff) | |
download | guile-6756d265ed53d7b107d31746e8455f10e2ecebdd.tar.gz |
ELF refactor and consequent linker simplifications
* 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 (fold-values): New helper.
(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.
-rw-r--r-- | module/language/objcode/elf.scm | 17 | ||||
-rw-r--r-- | module/system/vm/elf.scm | 188 | ||||
-rw-r--r-- | module/system/vm/linker.scm | 321 | ||||
-rw-r--r-- | test-suite/tests/linker.test | 7 |
4 files changed, 288 insertions, 245 deletions
diff --git a/module/language/objcode/elf.scm b/module/language/objcode/elf.scm index 1edfdcf98..981c398af 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 e2b245452..efa978256 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 e9dca7171..dfe863a16 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 @@ -216,35 +218,22 @@ (+ address (modulo (- alignment (modulo address alignment)) alignment))) -(define (fold1 proc ls s0) - (let lp ((ls ls) (s0 s0)) - (if (null? ls) - 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) - (values s0 s1 s2 s3) - (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-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 ...)))))))))))) (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 @@ -260,50 +249,54 @@ ;; Adds object symbols to global table, relocating them from object ;; address space to memory address space. (define (add-symbols symbols offset symtab) - (fold1 (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)) + (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 (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 - (linker-object-section o)) - alignment)) - objects - alignment)) + (alignment (fold-values (lambda (o alignment) + (lcm (elf-section-addralign + (linker-object-section o)) + alignment)) + objects + alignment)) (fileaddr (align fileaddr alignment)) (memaddr (align memaddr alignment))) (receive (objects fileend memend symtab) - (fold4 (lambda (o out fileaddr memaddr symtab) - (let* ((section (linker-object-section o)) - (fileaddr - (if (= (elf-section-type section) SHT_NOBITS) - fileaddr - (align fileaddr (elf-section-addralign section)))) - (memaddr - (align memaddr (elf-section-addralign section)))) - (values - (cons (make-linker-object - (relocate-section-header section fileaddr - memaddr) - (linker-object-bv o) - (linker-object-relocs o) - (linker-object-symbols o)) - out) - (if (= (elf-section-type section) SHT_NOBITS) - fileaddr - (+ fileaddr (elf-section-size section))) - (+ memaddr (elf-section-size section)) - (add-symbols (linker-object-symbols o) memaddr symtab)))) - objects '() fileaddr memaddr symtab) + (fold-values + (lambda (o out fileaddr memaddr symtab) + (let* ((section (linker-object-section o)) + (fileaddr + (if (= (elf-section-type section) SHT_NOBITS) + fileaddr + (align fileaddr (elf-section-addralign section)))) + (memaddr + (align memaddr (elf-section-addralign section)))) + (values + (cons (make-linker-object + (relocate-section-header section fileaddr + memaddr) + (linker-object-bv o) + (linker-object-relocs o) + (linker-object-symbols o)) + out) + (if (= (elf-section-type section) SHT_NOBITS) + fileaddr + (+ fileaddr (elf-section-size section))) + (+ memaddr (elf-section-size section)) + (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 +335,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) + (fold-values 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 +451,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 7ea263199..97f791210 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))) |