mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 20:30:28 +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)
|
(lambda (table idx)
|
||||||
(set! string-table table)
|
(set! string-table table)
|
||||||
idx)))
|
idx)))
|
||||||
(define (make-object name bv relocs . kwargs)
|
(define (make-object index name bv relocs . kwargs)
|
||||||
(let ((name-idx (intern-string! (symbol->string name))))
|
(let ((name-idx (intern-string! (symbol->string name))))
|
||||||
(make-linker-object (apply make-elf-section
|
(make-linker-object (apply make-elf-section
|
||||||
|
#:index index
|
||||||
#:name name-idx
|
#:name name-idx
|
||||||
#:size (bytevector-length bv)
|
#:size (bytevector-length bv)
|
||||||
kwargs)
|
kwargs)
|
||||||
bv relocs
|
bv relocs
|
||||||
(list (make-linker-symbol name 0)))))
|
(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)
|
(define (make-dynamic-section/32)
|
||||||
(let ((bv (make-bytevector 24 0)))
|
(let ((bv (make-bytevector 24 0)))
|
||||||
(bytevector-u32-set! bv 0 DT_GUILE_RTL_VERSION endianness)
|
(bytevector-u32-set! bv 0 DT_GUILE_RTL_VERSION endianness)
|
||||||
|
|
@ -74,19 +75,19 @@
|
||||||
((8) (make-dynamic-section/64))
|
((8) (make-dynamic-section/64))
|
||||||
(else (error "unexpected word size" word-size))))
|
(else (error "unexpected word size" word-size))))
|
||||||
(lambda (bv reloc)
|
(lambda (bv reloc)
|
||||||
(make-object '.dynamic bv (list reloc)
|
(make-object index '.dynamic bv (list reloc)
|
||||||
#:type SHT_DYNAMIC #:flags SHF_ALLOC))))
|
#:type SHT_DYNAMIC #:flags SHF_ALLOC))))
|
||||||
(define (make-string-table)
|
(define (make-string-table index)
|
||||||
(intern-string! ".shstrtab")
|
(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))
|
#:type SHT_STRTAB #:flags 0))
|
||||||
(let* ((word-size (target-word-size))
|
(let* ((word-size (target-word-size))
|
||||||
(endianness (target-endianness))
|
(endianness (target-endianness))
|
||||||
(text (make-object '.rtl-text bv '()))
|
(text (make-object 1 '.rtl-text bv '()))
|
||||||
(dt (make-dynamic-section word-size endianness))
|
(dt (make-dynamic-section 2 word-size endianness))
|
||||||
;; This needs to be linked last, because linking other
|
;; This needs to be linked last, because linking other
|
||||||
;; sections adds entries to the string table.
|
;; sections adds entries to the string table.
|
||||||
(shstrtab (make-string-table)))
|
(shstrtab (make-string-table 3)))
|
||||||
(link-elf (list text dt shstrtab)
|
(link-elf (list text dt shstrtab)
|
||||||
#:endianness endianness #:word-size word-size))))
|
#:endianness endianness #:word-size word-size))))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -16,6 +16,19 @@
|
||||||
;;;; License along with this library; if not, write to the Free Software
|
;;;; License along with this library; if not, write to the Free Software
|
||||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
;;;; 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:
|
;;; Code:
|
||||||
|
|
||||||
(define-module (system vm elf)
|
(define-module (system vm elf)
|
||||||
|
|
@ -27,7 +40,8 @@
|
||||||
#:use-module (ice-9 vlist)
|
#:use-module (ice-9 vlist)
|
||||||
#:export (has-elf-header?
|
#:export (has-elf-header?
|
||||||
|
|
||||||
make-elf elf?
|
(make-elf* . make-elf)
|
||||||
|
elf?
|
||||||
elf-bytes elf-word-size elf-byte-order
|
elf-bytes elf-word-size elf-byte-order
|
||||||
elf-abi elf-type elf-machine-type
|
elf-abi elf-type elf-machine-type
|
||||||
elf-entry elf-phoff elf-shoff elf-flags elf-ehsize
|
elf-entry elf-phoff elf-shoff elf-flags elf-ehsize
|
||||||
|
|
@ -37,6 +51,7 @@
|
||||||
|
|
||||||
(make-elf-segment* . make-elf-segment)
|
(make-elf-segment* . make-elf-segment)
|
||||||
elf-segment?
|
elf-segment?
|
||||||
|
elf-segment-index
|
||||||
elf-segment-type elf-segment-offset elf-segment-vaddr
|
elf-segment-type elf-segment-offset elf-segment-vaddr
|
||||||
elf-segment-paddr elf-segment-filesz elf-segment-memsz
|
elf-segment-paddr elf-segment-filesz elf-segment-memsz
|
||||||
elf-segment-flags elf-segment-align
|
elf-segment-flags elf-segment-align
|
||||||
|
|
@ -51,6 +66,7 @@
|
||||||
|
|
||||||
(make-elf-section* . make-elf-section)
|
(make-elf-section* . make-elf-section)
|
||||||
elf-section?
|
elf-section?
|
||||||
|
elf-section-index
|
||||||
elf-section-name elf-section-type elf-section-flags
|
elf-section-name elf-section-type elf-section-flags
|
||||||
elf-section-addr elf-section-offset elf-section-size
|
elf-section-addr elf-section-offset elf-section-size
|
||||||
elf-section-link elf-section-info elf-section-addralign
|
elf-section-link elf-section-info elf-section-addralign
|
||||||
|
|
@ -242,6 +258,26 @@
|
||||||
(shnum elf-shnum)
|
(shnum elf-shnum)
|
||||||
(shstrndx elf-shstrndx))
|
(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)
|
(define (parse-elf32 bv byte-order)
|
||||||
(make-elf bv 4 byte-order
|
(make-elf bv 4 byte-order
|
||||||
(bytevector-u8-ref bv 7)
|
(bytevector-u8-ref bv 7)
|
||||||
|
|
@ -276,28 +312,27 @@
|
||||||
(bytevector-u8-set! bv 14 0)
|
(bytevector-u8-set! bv 14 0)
|
||||||
(bytevector-u8-set! bv 15 0))
|
(bytevector-u8-set! bv 15 0))
|
||||||
|
|
||||||
(define (write-elf32 bv byte-order abi type machine-type
|
(define (write-elf32-header bv elf)
|
||||||
entry phoff shoff flags ehsize phentsize phnum
|
(let ((byte-order (elf-byte-order elf)))
|
||||||
shentsize shnum shstrndx)
|
|
||||||
(write-elf-ident bv ELFCLASS32
|
(write-elf-ident bv ELFCLASS32
|
||||||
(case byte-order
|
(case byte-order
|
||||||
((little) ELFDATA2LSB)
|
((little) ELFDATA2LSB)
|
||||||
((big) ELFDATA2MSB)
|
((big) ELFDATA2MSB)
|
||||||
(else (error "unknown endianness" byte-order)))
|
(else (error "unknown endianness" byte-order)))
|
||||||
abi)
|
(elf-abi elf))
|
||||||
(bytevector-u16-set! bv 16 type byte-order)
|
(bytevector-u16-set! bv 16 (elf-type elf) byte-order)
|
||||||
(bytevector-u16-set! bv 18 machine-type 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 20 EV_CURRENT byte-order)
|
||||||
(bytevector-u32-set! bv 24 entry byte-order)
|
(bytevector-u32-set! bv 24 (elf-entry elf) byte-order)
|
||||||
(bytevector-u32-set! bv 28 phoff byte-order)
|
(bytevector-u32-set! bv 28 (elf-phoff elf) byte-order)
|
||||||
(bytevector-u32-set! bv 32 shoff byte-order)
|
(bytevector-u32-set! bv 32 (elf-shoff elf) byte-order)
|
||||||
(bytevector-u32-set! bv 36 flags byte-order)
|
(bytevector-u32-set! bv 36 (elf-flags elf) byte-order)
|
||||||
(bytevector-u16-set! bv 40 ehsize byte-order)
|
(bytevector-u16-set! bv 40 (elf-ehsize elf) byte-order)
|
||||||
(bytevector-u16-set! bv 42 phentsize byte-order)
|
(bytevector-u16-set! bv 42 (elf-phentsize elf) byte-order)
|
||||||
(bytevector-u16-set! bv 44 phnum byte-order)
|
(bytevector-u16-set! bv 44 (elf-phnum elf) byte-order)
|
||||||
(bytevector-u16-set! bv 46 shentsize byte-order)
|
(bytevector-u16-set! bv 46 (elf-shentsize elf) byte-order)
|
||||||
(bytevector-u16-set! bv 48 shnum byte-order)
|
(bytevector-u16-set! bv 48 (elf-shnum elf) byte-order)
|
||||||
(bytevector-u16-set! bv 50 shstrndx byte-order))
|
(bytevector-u16-set! bv 50 (elf-shstrndx elf) byte-order)))
|
||||||
|
|
||||||
(define (parse-elf64 bv byte-order)
|
(define (parse-elf64 bv byte-order)
|
||||||
(make-elf bv 8 byte-order
|
(make-elf bv 8 byte-order
|
||||||
|
|
@ -315,28 +350,27 @@
|
||||||
(bytevector-u16-ref bv 60 byte-order)
|
(bytevector-u16-ref bv 60 byte-order)
|
||||||
(bytevector-u16-ref bv 62 byte-order)))
|
(bytevector-u16-ref bv 62 byte-order)))
|
||||||
|
|
||||||
(define (write-elf64 bv byte-order abi type machine-type
|
(define (write-elf64-header bv elf)
|
||||||
entry phoff shoff flags ehsize phentsize phnum
|
(let ((byte-order (elf-byte-order elf)))
|
||||||
shentsize shnum shstrndx)
|
|
||||||
(write-elf-ident bv ELFCLASS64
|
(write-elf-ident bv ELFCLASS64
|
||||||
(case byte-order
|
(case byte-order
|
||||||
((little) ELFDATA2LSB)
|
((little) ELFDATA2LSB)
|
||||||
((big) ELFDATA2MSB)
|
((big) ELFDATA2MSB)
|
||||||
(else (error "unknown endianness" byte-order)))
|
(else (error "unknown endianness" byte-order)))
|
||||||
abi)
|
(elf-abi elf))
|
||||||
(bytevector-u16-set! bv 16 type byte-order)
|
(bytevector-u16-set! bv 16 (elf-type elf) byte-order)
|
||||||
(bytevector-u16-set! bv 18 machine-type 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 20 EV_CURRENT byte-order)
|
||||||
(bytevector-u64-set! bv 24 entry byte-order)
|
(bytevector-u64-set! bv 24 (elf-entry elf) byte-order)
|
||||||
(bytevector-u64-set! bv 32 phoff byte-order)
|
(bytevector-u64-set! bv 32 (elf-phoff elf) byte-order)
|
||||||
(bytevector-u64-set! bv 40 shoff byte-order)
|
(bytevector-u64-set! bv 40 (elf-shoff elf) byte-order)
|
||||||
(bytevector-u32-set! bv 48 flags byte-order)
|
(bytevector-u32-set! bv 48 (elf-flags elf) byte-order)
|
||||||
(bytevector-u16-set! bv 52 ehsize byte-order)
|
(bytevector-u16-set! bv 52 (elf-ehsize elf) byte-order)
|
||||||
(bytevector-u16-set! bv 54 phentsize byte-order)
|
(bytevector-u16-set! bv 54 (elf-phentsize elf) byte-order)
|
||||||
(bytevector-u16-set! bv 56 phnum byte-order)
|
(bytevector-u16-set! bv 56 (elf-phnum elf) byte-order)
|
||||||
(bytevector-u16-set! bv 58 shentsize byte-order)
|
(bytevector-u16-set! bv 58 (elf-shentsize elf) byte-order)
|
||||||
(bytevector-u16-set! bv 60 shnum byte-order)
|
(bytevector-u16-set! bv 60 (elf-shnum elf) byte-order)
|
||||||
(bytevector-u16-set! bv 62 shstrndx byte-order))
|
(bytevector-u16-set! bv 62 (elf-shstrndx elf) byte-order)))
|
||||||
|
|
||||||
(define (parse-elf bv)
|
(define (parse-elf bv)
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -354,28 +388,12 @@
|
||||||
(else
|
(else
|
||||||
(error "Invalid ELF" bv))))
|
(error "Invalid ELF" bv))))
|
||||||
|
|
||||||
(define* (write-elf-header bv #:key
|
(define* (write-elf-header bv elf)
|
||||||
(byte-order (target-endianness))
|
((case (elf-word-size elf)
|
||||||
(word-size (target-word-size))
|
((4) write-elf32-header)
|
||||||
(abi ELFOSABI_STANDALONE)
|
((8) write-elf64-header)
|
||||||
(type ET_DYN)
|
(else (error "unknown word size" (elf-word-size elf))))
|
||||||
(machine-type EM_NONE)
|
bv elf))
|
||||||
(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))
|
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Segment types
|
;; Segment types
|
||||||
|
|
@ -402,8 +420,9 @@
|
||||||
(define PF_R (ash 1 2)) ; Segment is readable
|
(define PF_R (ash 1 2)) ; Segment is readable
|
||||||
|
|
||||||
(define-record-type <elf-segment>
|
(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?
|
elf-segment?
|
||||||
|
(index elf-segment-index)
|
||||||
(type elf-segment-type)
|
(type elf-segment-type)
|
||||||
(offset elf-segment-offset)
|
(offset elf-segment-offset)
|
||||||
(vaddr elf-segment-vaddr)
|
(vaddr elf-segment-vaddr)
|
||||||
|
|
@ -413,11 +432,11 @@
|
||||||
(flags elf-segment-flags)
|
(flags elf-segment-flags)
|
||||||
(align elf-segment-align))
|
(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)
|
(paddr 0) (filesz 0) (memsz filesz)
|
||||||
(flags (logior PF_W PF_R))
|
(flags (logior PF_W PF_R))
|
||||||
(align 8))
|
(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 {
|
;; typedef struct {
|
||||||
;; uint32_t p_type;
|
;; uint32_t p_type;
|
||||||
|
|
@ -430,9 +449,10 @@
|
||||||
;; uint32_t p_align;
|
;; uint32_t p_align;
|
||||||
;; } Elf32_Phdr;
|
;; } 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))
|
(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 4) byte-order)
|
||||||
(bytevector-u32-ref bv (+ offset 8) byte-order)
|
(bytevector-u32-ref bv (+ offset 8) byte-order)
|
||||||
(bytevector-u32-ref bv (+ offset 12) byte-order)
|
(bytevector-u32-ref bv (+ offset 12) byte-order)
|
||||||
|
|
@ -466,9 +486,10 @@
|
||||||
|
|
||||||
;; NB: position of `flags' is different!
|
;; 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))
|
(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 8) byte-order)
|
||||||
(bytevector-u64-ref bv (+ offset 16) byte-order)
|
(bytevector-u64-ref bv (+ offset 16) byte-order)
|
||||||
(bytevector-u64-ref bv (+ offset 24) byte-order)
|
(bytevector-u64-ref bv (+ offset 24) byte-order)
|
||||||
|
|
@ -519,8 +540,10 @@
|
||||||
(lp (1- n) (cons (elf-segment elf (1- n)) out)))))
|
(lp (1- n) (cons (elf-segment elf (1- n)) out)))))
|
||||||
|
|
||||||
(define-record-type <elf-section>
|
(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?
|
elf-section?
|
||||||
|
(index elf-section-index)
|
||||||
(name elf-section-name)
|
(name elf-section-name)
|
||||||
(type elf-section-type)
|
(type elf-section-type)
|
||||||
(flags elf-section-flags)
|
(flags elf-section-flags)
|
||||||
|
|
@ -532,10 +555,10 @@
|
||||||
(addralign elf-section-addralign)
|
(addralign elf-section-addralign)
|
||||||
(entsize elf-section-entsize))
|
(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)
|
(flags SHF_ALLOC) (addr 0) (offset 0) (size 0)
|
||||||
(link 0) (info 0) (addralign 8) (entsize 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))
|
entsize))
|
||||||
|
|
||||||
;; typedef struct {
|
;; typedef struct {
|
||||||
|
|
@ -551,9 +574,10 @@
|
||||||
;; uint32_t sh_entsize;
|
;; uint32_t sh_entsize;
|
||||||
;; } Elf32_Shdr;
|
;; } 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))
|
(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 4) byte-order)
|
||||||
(bytevector-u32-ref bv (+ offset 8) byte-order)
|
(bytevector-u32-ref bv (+ offset 8) byte-order)
|
||||||
(bytevector-u32-ref bv (+ offset 12) byte-order)
|
(bytevector-u32-ref bv (+ offset 12) byte-order)
|
||||||
|
|
@ -597,9 +621,10 @@
|
||||||
((8) 64)
|
((8) 64)
|
||||||
(else (error "bad word size" word-size))))
|
(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))
|
(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-u32-ref bv (+ offset 4) byte-order)
|
||||||
(bytevector-u64-ref bv (+ offset 8) byte-order)
|
(bytevector-u64-ref bv (+ offset 8) byte-order)
|
||||||
(bytevector-u64-ref bv (+ offset 16) byte-order)
|
(bytevector-u64-ref bv (+ offset 16) byte-order)
|
||||||
|
|
@ -630,6 +655,7 @@
|
||||||
((4) parse-elf32-section-header)
|
((4) parse-elf32-section-header)
|
||||||
((8) parse-elf64-section-header)
|
((8) parse-elf64-section-header)
|
||||||
(else (error "unhandled pointer size")))
|
(else (error "unhandled pointer size")))
|
||||||
|
n
|
||||||
(elf-bytes elf)
|
(elf-bytes elf)
|
||||||
(+ (elf-shoff elf) (* n (elf-shentsize elf)))
|
(+ (elf-shoff elf) (* n (elf-shentsize elf)))
|
||||||
(elf-byte-order elf)))
|
(elf-byte-order elf)))
|
||||||
|
|
|
||||||
|
|
@ -68,15 +68,13 @@
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
#:use-module (system base target)
|
#:use-module (system base target)
|
||||||
|
#:use-module ((srfi srfi-1) #:select (append-map))
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module (ice-9 receive)
|
#:use-module (ice-9 receive)
|
||||||
#:use-module (ice-9 vlist)
|
#:use-module (ice-9 vlist)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
#:use-module (system vm elf)
|
#:use-module (system vm elf)
|
||||||
#:export (make-string-table
|
#:export (make-linker-reloc
|
||||||
string-table-intern
|
|
||||||
link-string-table
|
|
||||||
|
|
||||||
make-linker-reloc
|
|
||||||
make-linker-symbol
|
make-linker-symbol
|
||||||
|
|
||||||
make-linker-object
|
make-linker-object
|
||||||
|
|
@ -86,6 +84,10 @@
|
||||||
linker-object-relocs
|
linker-object-relocs
|
||||||
linker-object-symbols
|
linker-object-symbols
|
||||||
|
|
||||||
|
make-string-table
|
||||||
|
string-table-intern
|
||||||
|
link-string-table
|
||||||
|
|
||||||
link-elf))
|
link-elf))
|
||||||
|
|
||||||
;; A relocation records a reference to a symbol. When the symbol is
|
;; A relocation records a reference to a symbol. When the symbol is
|
||||||
|
|
@ -216,35 +218,22 @@
|
||||||
(+ address
|
(+ address
|
||||||
(modulo (- alignment (modulo address alignment)) alignment)))
|
(modulo (- alignment (modulo address alignment)) alignment)))
|
||||||
|
|
||||||
(define (fold1 proc ls s0)
|
(define-syntax fold-values
|
||||||
(let lp ((ls ls) (s0 s0))
|
(lambda (x)
|
||||||
(if (null? ls)
|
(syntax-case x ()
|
||||||
s0
|
((_ proc list seed ...)
|
||||||
(lp (cdr ls) (proc (car ls) s0)))))
|
(with-syntax (((s ...) (generate-temporaries #'(seed ...))))
|
||||||
|
#'(let ((p proc))
|
||||||
(define (fold2 proc ls s0 s1)
|
(let lp ((l list) (s seed) ...)
|
||||||
(let lp ((ls ls) (s0 s0) (s1 s1))
|
(match l
|
||||||
(if (null? ls)
|
(() (values s ...))
|
||||||
(values s0 s1)
|
((elt . l)
|
||||||
(receive (s0 s1) (proc (car ls) s0 s1)
|
(call-with-values (lambda () (p elt s ...))
|
||||||
(lp (cdr ls) s0 s1)))))
|
(lambda (s ...) (lp l s ...))))))))))))
|
||||||
|
|
||||||
(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 (relocate-section-header sec fileaddr memaddr)
|
(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)
|
#:type (elf-section-type sec)
|
||||||
#:flags (elf-section-flags sec)
|
#:flags (elf-section-flags sec)
|
||||||
#:addr memaddr
|
#:addr memaddr
|
||||||
|
|
@ -260,7 +249,8 @@
|
||||||
;; Adds object symbols to global table, relocating them from object
|
;; Adds object symbols to global table, relocating them from object
|
||||||
;; address space to memory address space.
|
;; address space to memory address space.
|
||||||
(define (add-symbols symbols offset symtab)
|
(define (add-symbols symbols offset symtab)
|
||||||
(fold1 (lambda (symbol symtab)
|
(fold-values
|
||||||
|
(lambda (symbol symtab)
|
||||||
(let ((name (linker-symbol-name symbol))
|
(let ((name (linker-symbol-name symbol))
|
||||||
(addr (linker-symbol-address symbol)))
|
(addr (linker-symbol-address symbol)))
|
||||||
(when (vhash-assq name symtab)
|
(when (vhash-assq name symtab)
|
||||||
|
|
@ -269,9 +259,10 @@
|
||||||
symbols
|
symbols
|
||||||
symtab))
|
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)))
|
(let* ((loadable? (not (zero? flags)))
|
||||||
(alignment (fold1 (lambda (o alignment)
|
(alignment (fold-values (lambda (o alignment)
|
||||||
(lcm (elf-section-addralign
|
(lcm (elf-section-addralign
|
||||||
(linker-object-section o))
|
(linker-object-section o))
|
||||||
alignment))
|
alignment))
|
||||||
|
|
@ -280,7 +271,8 @@
|
||||||
(fileaddr (align fileaddr alignment))
|
(fileaddr (align fileaddr alignment))
|
||||||
(memaddr (align memaddr alignment)))
|
(memaddr (align memaddr alignment)))
|
||||||
(receive (objects fileend memend symtab)
|
(receive (objects fileend memend symtab)
|
||||||
(fold4 (lambda (o out fileaddr memaddr symtab)
|
(fold-values
|
||||||
|
(lambda (o out fileaddr memaddr symtab)
|
||||||
(let* ((section (linker-object-section o))
|
(let* ((section (linker-object-section o))
|
||||||
(fileaddr
|
(fileaddr
|
||||||
(if (= (elf-section-type section) SHT_NOBITS)
|
(if (= (elf-section-type section) SHT_NOBITS)
|
||||||
|
|
@ -303,7 +295,8 @@
|
||||||
(add-symbols (linker-object-symbols o) memaddr symtab))))
|
(add-symbols (linker-object-symbols o) memaddr symtab))))
|
||||||
objects '() fileaddr memaddr symtab)
|
objects '() fileaddr memaddr symtab)
|
||||||
(values
|
(values
|
||||||
(make-elf-segment #:type type #:offset fileaddr
|
(make-elf-segment #:index phidx
|
||||||
|
#:type type #:offset fileaddr
|
||||||
#:vaddr (if loadable? memaddr 0)
|
#:vaddr (if loadable? memaddr 0)
|
||||||
#:filesz (- fileend fileaddr)
|
#:filesz (- fileend fileaddr)
|
||||||
#:memsz (if loadable? (- memend memaddr) 0)
|
#:memsz (if loadable? (- memend memaddr) 0)
|
||||||
|
|
@ -342,34 +335,113 @@
|
||||||
(relocs (linker-object-relocs o)))
|
(relocs (linker-object-relocs o)))
|
||||||
(if (not (= (elf-section-type section) SHT_NOBITS))
|
(if (not (= (elf-section-type section) SHT_NOBITS))
|
||||||
(begin
|
(begin
|
||||||
(if (not (= (elf-section-size section) (bytevector-length bytes)))
|
(if (not (= len (bytevector-length bytes)))
|
||||||
(error "unexpected length" section bytes))
|
(error "unexpected length" section bytes))
|
||||||
(bytevector-copy! bytes 0 bv offset len)
|
(bytevector-copy! bytes 0 bv offset len)
|
||||||
(for-each (lambda (reloc)
|
(for-each (lambda (reloc)
|
||||||
(process-reloc reloc bv offset addr symtab endianness))
|
(process-reloc reloc bv offset addr symtab endianness))
|
||||||
relocs)))))
|
relocs)))))
|
||||||
|
|
||||||
(define (compute-sections-by-name seglists)
|
(define (find-shstrndx objects)
|
||||||
(let lp ((in (apply append (map cdr seglists)))
|
(or-map (lambda (object)
|
||||||
(n 1) (out '()) (shstrtab #f))
|
(let* ((section (linker-object-section object))
|
||||||
(if (null? in)
|
(bv (linker-object-bv object))
|
||||||
(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)))
|
(name (elf-section-name section)))
|
||||||
(lp (cdr in) (1+ n) (acons name n out)
|
|
||||||
(or shstrtab
|
|
||||||
(and (= (elf-section-type section) SHT_STRTAB)
|
(and (= (elf-section-type section) SHT_STRTAB)
|
||||||
(equal? (false-if-exception
|
(equal? (false-if-exception (string-table-ref bv name))
|
||||||
(string-table-ref bv name))
|
|
||||||
".shstrtab")
|
".shstrtab")
|
||||||
bv)))))))
|
(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
|
;; Given a list of section-header/bytevector pairs, collate the sections
|
||||||
;; into segments, allocate the segments, allocate the ELF bytevector,
|
;; into segments, allocate the segments, allocate the ELF bytevector,
|
||||||
|
|
@ -379,64 +451,7 @@
|
||||||
(page-aligned? #t)
|
(page-aligned? #t)
|
||||||
(endianness (target-endianness))
|
(endianness (target-endianness))
|
||||||
(word-size (target-word-size)))
|
(word-size (target-word-size)))
|
||||||
(let* ((seglists (collate-objects-into-segments objects))
|
(check-section-numbers objects)
|
||||||
(sections-by-name (compute-sections-by-name seglists))
|
(receive (header segments objects symtab)
|
||||||
(nsegments (length seglists))
|
(allocate-elf objects page-aligned? endianness word-size)
|
||||||
(nsections (1+ (length objects))) ;; 1+ for the first reserved entry.
|
(write-elf header segments objects symtab)))
|
||||||
(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))))
|
|
||||||
|
|
|
||||||
|
|
@ -31,9 +31,10 @@
|
||||||
(lambda (table idx)
|
(lambda (table idx)
|
||||||
(set! string-table table)
|
(set! string-table table)
|
||||||
idx)))
|
idx)))
|
||||||
(define (make-object name bv relocs . kwargs)
|
(define (make-object index name bv relocs . kwargs)
|
||||||
(let ((name-idx (intern-string! (symbol->string name))))
|
(let ((name-idx (intern-string! (symbol->string name))))
|
||||||
(make-linker-object (apply make-elf-section
|
(make-linker-object (apply make-elf-section
|
||||||
|
#:index index
|
||||||
#:name name-idx
|
#:name name-idx
|
||||||
#:size (bytevector-length bv)
|
#:size (bytevector-length bv)
|
||||||
kwargs)
|
kwargs)
|
||||||
|
|
@ -41,11 +42,11 @@
|
||||||
(list (make-linker-symbol name 0)))))
|
(list (make-linker-symbol name 0)))))
|
||||||
(define (make-string-table)
|
(define (make-string-table)
|
||||||
(intern-string! ".shstrtab")
|
(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))
|
#:type SHT_STRTAB #:flags 0))
|
||||||
(let* ((word-size (target-word-size))
|
(let* ((word-size (target-word-size))
|
||||||
(endianness (target-endianness))
|
(endianness (target-endianness))
|
||||||
(sec (make-object name bytes '()))
|
(sec (make-object 1 name bytes '()))
|
||||||
;; This needs to be linked last, because linking other
|
;; This needs to be linked last, because linking other
|
||||||
;; sections adds entries to the string table.
|
;; sections adds entries to the string table.
|
||||||
(shstrtab (make-string-table)))
|
(shstrtab (make-string-table)))
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue