mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 04:40:29 +02:00
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.
This commit is contained in:
Andy Wingo
parent
45037e7527
commit
6756d265ed
4 changed files with 288 additions and 245 deletions
|
|
@ -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))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue