mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
9e1c07bda6
* module/system/vm/assembler.scm (u32-ref, u32-set!, s32-ref, s32-set!): Remove these helpers. * module/system/vm/assembler.scm (<asm>): Track offsets in bytes, not u32 units. (emit, assembler, process-relocs, process-labels, link-text-object) (link-frame-maps, link-symtab, write-arities, link-docstrs) (link-procprops, link-debug): Adapt. * module/system/vm/linker.scm (process-reloc): Add addend before dividing by 4 for rel32/4 symbols.
697 lines
29 KiB
Scheme
697 lines
29 KiB
Scheme
;;; Guile ELF linker
|
|
|
|
;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
|
|
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Lesser General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; A linker combines several linker objects into an executable or a
|
|
;;; loadable library.
|
|
;;;
|
|
;;; There are several common formats for libraries out there. Since
|
|
;;; Guile includes its own linker and loader, we are free to choose any
|
|
;;; format, or make up our own.
|
|
;;;
|
|
;;; There are essentially two requirements for a linker format:
|
|
;;; libraries should be able to be loaded with the minimal amount of
|
|
;;; work; and they should support introspection in some way, in order to
|
|
;;; enable good debugging.
|
|
;;;
|
|
;;; These requirements are somewhat at odds, as loading should not have
|
|
;;; to stumble over features related to introspection. It so happens
|
|
;;; that a lot of smart people have thought about this situation, and
|
|
;;; the ELF format embodies the outcome of their thinking. Guile uses
|
|
;;; ELF as its format, regardless of the platform's native library
|
|
;;; format. It's not inconceivable that Guile could interoperate with
|
|
;;; the native dynamic loader at some point, but it's not a near-term
|
|
;;; goal.
|
|
;;;
|
|
;;; Guile's linker takes a list of objects, sorts them according to
|
|
;;; similarity from the perspective of the loader, then writes them out
|
|
;;; into one big bytevector in ELF format.
|
|
;;;
|
|
;;; It is often the case that different parts of a library need to refer
|
|
;;; to each other. For example, program text may need to refer to a
|
|
;;; constant from writable memory. When the linker places sections
|
|
;;; (linker objects) into specific locations in the linked bytevector,
|
|
;;; it needs to fix up those references. This process is called
|
|
;;; /relocation/. References needing relocations are recorded in
|
|
;;; "linker-reloc" objects, and collected in a list in each
|
|
;;; "linker-object". The actual definitions of the references are
|
|
;;; stored in "linker-symbol" objects, also collected in a list in each
|
|
;;; "linker-object".
|
|
;;;
|
|
;;; By default, the ELF files created by the linker include some padding
|
|
;;; so that different parts of the file can be loaded in with different
|
|
;;; permissions. For example, some parts of the file are read-only and
|
|
;;; thus can be shared between processes. Some parts of the file don't
|
|
;;; need to be loaded at all. However this padding can be too much for
|
|
;;; interactive compilation, when the code is never written out to disk;
|
|
;;; in that case, pass #:page-aligned? #f to `link-elf'.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define-module (system vm linker)
|
|
#:use-module (rnrs bytevectors)
|
|
#:use-module (system foreign)
|
|
#:use-module (system base target)
|
|
#:use-module ((srfi srfi-1) #:select (append-map))
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (ice-9 receive)
|
|
#:use-module (ice-9 vlist)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (system vm elf)
|
|
#:export (make-linker-reloc
|
|
make-linker-symbol
|
|
|
|
make-linker-object
|
|
linker-object?
|
|
linker-object-section
|
|
linker-object-bv
|
|
linker-object-relocs
|
|
(linker-object-symbols* . linker-object-symbols)
|
|
|
|
make-string-table
|
|
string-table-intern!
|
|
link-string-table!
|
|
|
|
link-elf))
|
|
|
|
(define-syntax fold-values
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ proc list seed ...)
|
|
(with-syntax (((s ...) (generate-temporaries #'(seed ...))))
|
|
#'(let ((p proc))
|
|
(let lp ((l list) (s seed) ...)
|
|
(match l
|
|
(() (values s ...))
|
|
((elt . l)
|
|
(call-with-values (lambda () (p elt s ...))
|
|
(lambda (s ...) (lp l s ...))))))))))))
|
|
|
|
;; A relocation records a reference to a symbol. When the symbol is
|
|
;; resolved to an address, the reloc location will be updated to point
|
|
;; to the address.
|
|
;;
|
|
;; Two types. Abs32/1 and Abs64/1 are absolute offsets in bytes.
|
|
;; Rel32/1 and Rel32/1 are relative signed offsets, in 8-bit or 32-bit
|
|
;; units, respectively. Either can have an arbitrary addend as well.
|
|
;;
|
|
(define-record-type <linker-reloc>
|
|
(make-linker-reloc type loc addend symbol)
|
|
linker-reloc?
|
|
(type linker-reloc-type) ;; rel32/1, rel32/4, abs32/1, abs64/1
|
|
(loc linker-reloc-loc)
|
|
(addend linker-reloc-addend)
|
|
(symbol linker-reloc-symbol))
|
|
|
|
;; A symbol is an association between a name and an address. The
|
|
;; address is always in regard to some particular address space. When
|
|
;; objects come into the linker, their symbols live in the object
|
|
;; address space. When the objects are allocated into ELF segments, the
|
|
;; symbols will be relocated into memory address space, corresponding to
|
|
;; the position the ELF will be loaded at.
|
|
;;
|
|
(define-record-type <linker-symbol>
|
|
(make-linker-symbol name address)
|
|
linker-symbol?
|
|
(name linker-symbol-name)
|
|
(address linker-symbol-address))
|
|
|
|
(define-record-type <linker-object>
|
|
(%make-linker-object section bv relocs symbols)
|
|
linker-object?
|
|
(section linker-object-section)
|
|
(bv linker-object-bv)
|
|
(relocs linker-object-relocs)
|
|
(symbols linker-object-symbols))
|
|
|
|
(define (make-linker-object section bv relocs symbols)
|
|
"Create a linker object with the @code{<elf-section>} header
|
|
@var{section}, bytevector contents @var{bv}, list of linker relocations
|
|
@var{relocs}, and list of linker symbols @var{symbols}."
|
|
(%make-linker-object section bv relocs
|
|
;; Hide a symbol to the beginning of the section
|
|
;; in the symbols.
|
|
(cons (make-linker-symbol (gensym "*section*") 0)
|
|
symbols)))
|
|
(define (linker-object-section-symbol object)
|
|
"Return the linker symbol corresponding to the start of this section."
|
|
(car (linker-object-symbols object)))
|
|
(define (linker-object-symbols* object)
|
|
"Return the linker symbols defined by the user for this this section."
|
|
(cdr (linker-object-symbols object)))
|
|
|
|
(define-record-type <string-table>
|
|
(%make-string-table strings linked?)
|
|
string-table?
|
|
(strings string-table-strings set-string-table-strings!)
|
|
(linked? string-table-linked? set-string-table-linked?!))
|
|
|
|
(define (make-string-table)
|
|
"Return a string table with one entry: the empty string."
|
|
(%make-string-table '(("" 0 #vu8())) #f))
|
|
|
|
(define (string-table-length strings)
|
|
"Return the number of bytes needed for the @var{strings}."
|
|
(match strings
|
|
(((str pos bytes) . _)
|
|
;; The + 1 is for the trailing NUL byte.
|
|
(+ pos (bytevector-length bytes) 1))))
|
|
|
|
(define (string-table-intern! table str)
|
|
"Ensure that @var{str} is present in the string table @var{table}.
|
|
Returns the byte index of the string in that table."
|
|
(match table
|
|
(($ <string-table> strings linked?)
|
|
(match (assoc str strings)
|
|
((_ pos _) pos)
|
|
(#f
|
|
(let ((next (string-table-length strings)))
|
|
(when linked?
|
|
(error "string table already linked, can't intern" table str))
|
|
(set-string-table-strings! table
|
|
(cons (list str next (string->utf8 str))
|
|
strings))
|
|
next))))))
|
|
|
|
(define (link-string-table! table)
|
|
"Link the functional string table @var{table} into a sequence of
|
|
bytes, suitable for use as the contents of an ELF string table section."
|
|
(match table
|
|
(($ <string-table> strings #f)
|
|
(let ((out (make-bytevector (string-table-length strings) 0)))
|
|
(for-each
|
|
(match-lambda
|
|
((_ pos bytes)
|
|
(bytevector-copy! bytes 0 out pos (bytevector-length bytes))))
|
|
strings)
|
|
(set-string-table-linked?! table #t)
|
|
out))))
|
|
|
|
(define (segment-kind section)
|
|
"Return the type of segment needed to store @var{section}, as a pair.
|
|
The car is the @code{PT_} segment type, or @code{#f} if the section
|
|
doesn't need to be present in a loadable segment. The cdr is a bitfield
|
|
of associated @code{PF_} permissions."
|
|
(let ((flags (elf-section-flags section)))
|
|
;; Sections without SHF_ALLOC don't go in segments.
|
|
(cons (if (zero? flags) #f PT_LOAD)
|
|
(logior (if (logtest SHF_ALLOC flags) PF_R 0)
|
|
(if (logtest SHF_EXECINSTR flags) PF_X 0)
|
|
(if (logtest SHF_WRITE flags) PF_W 0)))))
|
|
|
|
(define (count-segments objects)
|
|
"Return the total number of segments needed to represent the linker
|
|
objects in @var{objects}, including the segment needed for the ELF
|
|
header and segment table."
|
|
(define (adjoin x xs)
|
|
(if (member x xs) xs (cons x xs)))
|
|
(length
|
|
(fold-values (lambda (object kinds)
|
|
(let ((kind (segment-kind (linker-object-section object))))
|
|
(if (= (elf-section-type (linker-object-section object))
|
|
SHT_DYNAMIC)
|
|
;; The dynamic section is part of a loadable
|
|
;; segment, and also gets the additional
|
|
;; PT_DYNAMIC segment header.
|
|
(cons (cons PT_DYNAMIC (cdr kind))
|
|
(adjoin kind kinds))
|
|
(if (car kind) (adjoin kind kinds) kinds))))
|
|
objects
|
|
;; We know there will be at least one segment,
|
|
;; containing at least the header and segment table.
|
|
(list (cons PT_LOAD PF_R)))))
|
|
|
|
(define (group-by-cars ls)
|
|
(let lp ((ls ls) (k #f) (group #f) (out '()))
|
|
(match ls
|
|
(()
|
|
(reverse!
|
|
(if group
|
|
(cons (cons k (reverse! group)) out)
|
|
out)))
|
|
(((k* . v) . ls)
|
|
(if (and group (equal? k k*))
|
|
(lp ls k (cons v group) out)
|
|
(lp ls k* (list v)
|
|
(if group
|
|
(cons (cons k (reverse! group)) out)
|
|
out)))))))
|
|
|
|
(define (collate-objects-into-segments objects)
|
|
"Given the list of linker objects @var{objects}, group them into
|
|
contiguous ELF segments of the same type and flags. The result is an
|
|
alist that maps segment types to lists of linker objects. See
|
|
@code{segment-type} for a description of segment types. Within a
|
|
segment, the order of the linker objects is preserved."
|
|
(group-by-cars
|
|
(stable-sort!
|
|
(map (lambda (o)
|
|
(cons (segment-kind (linker-object-section o)) o))
|
|
objects)
|
|
(lambda (x y)
|
|
(let* ((x-kind (car x)) (y-kind (car y))
|
|
(x-type (car x-kind)) (y-type (car y-kind))
|
|
(x-flags (cdr x-kind)) (y-flags (cdr y-kind))
|
|
(x-section (linker-object-section (cdr x)))
|
|
(y-section (linker-object-section (cdr y))))
|
|
(cond
|
|
((not (equal? x-kind y-kind))
|
|
(cond
|
|
((and x-type y-type)
|
|
(cond
|
|
((not (equal? x-flags y-flags))
|
|
(< x-flags y-flags))
|
|
(else
|
|
(< x-type y-type))))
|
|
(else
|
|
(not y-type))))
|
|
((not (equal? (elf-section-type x-section)
|
|
(elf-section-type y-section)))
|
|
(cond
|
|
((equal? (elf-section-type x-section) SHT_NOBITS) #t)
|
|
((equal? (elf-section-type y-section) SHT_NOBITS) #f)
|
|
(else (< (elf-section-type x-section)
|
|
(elf-section-type y-section)))))
|
|
(else
|
|
;; Leave them in the initial order. This allows us to ensure
|
|
;; that the ELF header is written first.
|
|
#f)))))))
|
|
|
|
(define (align address alignment)
|
|
(if (zero? alignment)
|
|
address
|
|
(+ address
|
|
(modulo (- alignment (modulo address alignment)) alignment))))
|
|
|
|
(define (relocate-section-header sec offset)
|
|
"Return a new section header, just like @var{sec} but with its
|
|
@code{offset} (and @code{addr} if it is loadable) set to @var{offset}."
|
|
(make-elf-section #:index (elf-section-index sec)
|
|
#:name (elf-section-name sec)
|
|
#:type (elf-section-type sec)
|
|
#:flags (elf-section-flags sec)
|
|
#:addr (if (zero? (logand SHF_ALLOC
|
|
(elf-section-flags sec)))
|
|
0
|
|
offset)
|
|
#:offset offset
|
|
#:size (elf-section-size sec)
|
|
#:link (elf-section-link sec)
|
|
#:info (elf-section-info sec)
|
|
#:addralign (elf-section-addralign sec)
|
|
#:entsize (elf-section-entsize sec)))
|
|
|
|
(define *page-size* 4096)
|
|
|
|
(define (add-symbols symbols offset symtab)
|
|
"Add @var{symbols} to the symbol table @var{symtab}, relocating them
|
|
from object address space to memory address space. Returns a new symbol
|
|
table."
|
|
(fold-values
|
|
(lambda (symbol symtab)
|
|
(let ((name (linker-symbol-name symbol))
|
|
(addr (linker-symbol-address symbol)))
|
|
(when (vhash-assq name symtab)
|
|
(error "duplicate symbol" name))
|
|
(vhash-consq name (make-linker-symbol name (+ addr offset)) symtab)))
|
|
symbols
|
|
symtab))
|
|
|
|
(define (allocate-segment write-segment-header!
|
|
phidx type flags objects addr symtab alignment)
|
|
"Given a list of linker objects that should go in a segment, the type
|
|
and flags that the segment should have, and the address at which the
|
|
segment should start, compute the positions that each object should have
|
|
in the segment.
|
|
|
|
Returns three values: the address of the next byte after the segment, a
|
|
list of relocated objects, and the symbol table. The symbol table is
|
|
the same as @var{symtab}, augmented with the symbols defined in
|
|
@var{objects}, relocated to their positions in the image.
|
|
|
|
In what is something of a quirky interface, this routine also patches up
|
|
the segment table using @code{write-segment-header!}."
|
|
(let* ((alignment (fold-values (lambda (o alignment)
|
|
(lcm (elf-section-addralign
|
|
(linker-object-section o))
|
|
alignment))
|
|
objects
|
|
alignment))
|
|
(addr (align addr alignment)))
|
|
(receive (objects endaddr symtab)
|
|
(fold-values
|
|
(lambda (o out addr symtab)
|
|
(let* ((section (linker-object-section o))
|
|
(addr (align addr (elf-section-addralign section))))
|
|
(values
|
|
(cons (make-linker-object
|
|
(relocate-section-header section addr)
|
|
(linker-object-bv o)
|
|
(linker-object-relocs o)
|
|
(linker-object-symbols o))
|
|
out)
|
|
(+ addr (elf-section-size section))
|
|
(add-symbols (linker-object-symbols o) addr symtab))))
|
|
objects
|
|
'() addr symtab)
|
|
(when type
|
|
(write-segment-header!
|
|
(make-elf-segment #:index phidx #:type type
|
|
#:offset addr #:vaddr addr #:paddr addr
|
|
#:filesz (- endaddr addr) #:memsz (- endaddr addr)
|
|
#:flags flags #:align alignment)))
|
|
(values endaddr
|
|
(reverse objects)
|
|
symtab))))
|
|
|
|
(define (process-reloc reloc bv section-offset symtab endianness)
|
|
"Process a relocation. Given that a section containing @var{reloc}
|
|
was just written into the image @var{bv} at offset @var{section-offset},
|
|
fix it up so that its reference points to the correct position of its
|
|
symbol, as present in @var{symtab}."
|
|
(match (vhash-assq (linker-reloc-symbol reloc) symtab)
|
|
(#f
|
|
(error "Undefined symbol" (linker-reloc-symbol reloc)))
|
|
((name . symbol)
|
|
;; The reloc was written at LOC bytes after SECTION-OFFSET.
|
|
(let* ((offset (+ (linker-reloc-loc reloc) section-offset))
|
|
(target (linker-symbol-address symbol)))
|
|
(case (linker-reloc-type reloc)
|
|
((rel32/4)
|
|
(let ((diff (+ (- target offset) (linker-reloc-addend reloc))))
|
|
(unless (zero? (modulo diff 4))
|
|
(error "Bad offset" reloc symbol offset))
|
|
(bytevector-s32-set! bv offset (/ diff 4) endianness)))
|
|
((rel32/1)
|
|
(let ((diff (- target offset)))
|
|
(bytevector-s32-set! bv offset
|
|
(+ diff (linker-reloc-addend reloc))
|
|
endianness)))
|
|
((abs32/1)
|
|
(bytevector-u32-set! bv offset target endianness))
|
|
((abs64/1)
|
|
(bytevector-u64-set! bv offset target endianness))
|
|
(else
|
|
(error "bad reloc type" reloc)))))))
|
|
|
|
(define (write-linker-object bv o symtab endianness)
|
|
"Write the bytevector for the section wrapped by the linker object
|
|
@var{o} into the image @var{bv}. The section header in @var{o} should
|
|
already be relocated its final position in the image. Any relocations
|
|
in the section will be processed to point to the correct symbol
|
|
locations, as given in @var{symtab}."
|
|
(let* ((section (linker-object-section o))
|
|
(offset (elf-section-offset section))
|
|
(len (elf-section-size section))
|
|
(bytes (linker-object-bv o))
|
|
(relocs (linker-object-relocs o)))
|
|
(if (zero? (logand SHF_ALLOC (elf-section-flags section)))
|
|
(unless (zero? (elf-section-addr section))
|
|
(error "non-loadable section has non-zero addr" section))
|
|
(unless (= offset (elf-section-addr section))
|
|
(error "loadable section has offset != addr" section)))
|
|
(if (not (= (elf-section-type section) SHT_NOBITS))
|
|
(begin
|
|
(if (not (= len (bytevector-length bytes)))
|
|
(error "unexpected length" section bytes))
|
|
(bytevector-copy! bytes 0 bv offset len)
|
|
(for-each (lambda (reloc)
|
|
(process-reloc reloc bv offset symtab endianness))
|
|
relocs)))))
|
|
|
|
(define (find-shstrndx objects)
|
|
"Find the section name string table in @var{objects}, and return its
|
|
section index."
|
|
(or-map (lambda (object)
|
|
(let* ((section (linker-object-section object))
|
|
(bv (linker-object-bv object))
|
|
(name (elf-section-name section)))
|
|
(and (= (elf-section-type section) SHT_STRTAB)
|
|
(equal? (false-if-exception (string-table-ref bv name))
|
|
".shstrtab")
|
|
(elf-section-index section))))
|
|
objects))
|
|
|
|
(define (add-elf-objects objects endianness word-size abi type machine-type)
|
|
"Given the list of linker objects supplied by the user, add linker
|
|
objects corresponding to parts of the ELF file: the null object, the ELF
|
|
header, and the section table.
|
|
|
|
Both of these internal objects include relocs, allowing their
|
|
inter-object references to be patched up when the final image allocation
|
|
is known. There is special support for patching up the segment table,
|
|
however. Because the segment table needs to know the segment sizes,
|
|
which is the difference between two symbols in image space, and there is
|
|
no reloc kind that is the difference between two symbols, we make a hack
|
|
and return a closure that patches up segment table entries. It seems to
|
|
work.
|
|
|
|
Returns two values: the procedure to patch the segment table, and the
|
|
list of objects, augmented with objects for the special ELF sections."
|
|
(define phoff (elf-header-len word-size))
|
|
(define phentsize (elf-program-header-len word-size))
|
|
(define shentsize (elf-section-header-len word-size))
|
|
(define shnum (+ (length objects) 3))
|
|
(define reloc-kind
|
|
(case word-size
|
|
((4) 'abs32/1)
|
|
((8) 'abs64/1)
|
|
(else (error "bad word size" word-size))))
|
|
|
|
;; ELF requires that the first entry in the section table be of type
|
|
;; SHT_NULL.
|
|
;;
|
|
(define (make-null-section)
|
|
(make-linker-object (make-elf-section #:index 0 #:type SHT_NULL
|
|
#:flags 0 #:addralign 0)
|
|
#vu8() '() '()))
|
|
|
|
;; The ELF header and the segment table.
|
|
;;
|
|
(define (make-header phnum index shoff-label)
|
|
(let* ((header (make-elf #:byte-order endianness #:word-size word-size
|
|
#:abi abi #:type type #:machine-type machine-type
|
|
#:phoff phoff #:phnum phnum #:phentsize phentsize
|
|
#:shoff 0 #:shnum shnum #:shentsize shentsize
|
|
#:shstrndx (or (find-shstrndx objects) SHN_UNDEF)))
|
|
(shoff-reloc (make-linker-reloc reloc-kind
|
|
(elf-header-shoff-offset word-size)
|
|
0
|
|
shoff-label))
|
|
(size (+ phoff (* phnum phentsize)))
|
|
(bv (make-bytevector size 0)))
|
|
(write-elf-header bv header)
|
|
;; Leave the segment table uninitialized; it will be filled in
|
|
;; later by calls to the write-segment-header! closure.
|
|
(make-linker-object (make-elf-section #:index index #:type SHT_PROGBITS
|
|
#:flags SHF_ALLOC #:size size)
|
|
bv
|
|
(list shoff-reloc)
|
|
'())))
|
|
|
|
;; The section table.
|
|
;;
|
|
(define (make-footer objects shoff-label)
|
|
(let* ((size (* shentsize shnum))
|
|
(bv (make-bytevector size 0))
|
|
(section-table (make-elf-section #:index (length objects)
|
|
#:type SHT_PROGBITS
|
|
#:flags 0
|
|
#:size size)))
|
|
(define (write-and-reloc section-label section relocs)
|
|
(let ((offset (* shentsize (elf-section-index section))))
|
|
(write-elf-section-header bv offset endianness word-size section)
|
|
(if (= (elf-section-type section) SHT_NULL)
|
|
relocs
|
|
(let ((relocs
|
|
(cons (make-linker-reloc
|
|
reloc-kind
|
|
(+ offset
|
|
(elf-section-header-offset-offset word-size))
|
|
0
|
|
section-label)
|
|
relocs)))
|
|
(if (zero? (logand SHF_ALLOC (elf-section-flags section)))
|
|
relocs
|
|
(cons (make-linker-reloc
|
|
reloc-kind
|
|
(+ offset
|
|
(elf-section-header-addr-offset word-size))
|
|
0
|
|
section-label)
|
|
relocs))))))
|
|
(let ((relocs (fold-values
|
|
(lambda (object relocs)
|
|
(write-and-reloc
|
|
(linker-symbol-name
|
|
(linker-object-section-symbol object))
|
|
(linker-object-section object)
|
|
relocs))
|
|
objects
|
|
(write-and-reloc shoff-label section-table '()))))
|
|
(%make-linker-object section-table bv relocs
|
|
(list (make-linker-symbol shoff-label 0))))))
|
|
|
|
(let* ((null-section (make-null-section))
|
|
(objects (cons null-section objects))
|
|
|
|
(shoff (gensym "*section-table*"))
|
|
(header (make-header (count-segments objects) (length objects) shoff))
|
|
(objects (cons header objects))
|
|
|
|
(footer (make-footer objects shoff))
|
|
(objects (cons footer objects)))
|
|
|
|
;; The header includes the segment table, which needs offsets and
|
|
;; sizes of the segments. Normally we would use relocs to rewrite
|
|
;; these values, but there is no reloc type that would allow us to
|
|
;; compute size. Such a reloc would need to take the difference
|
|
;; between two symbols, and it's probably a bad idea architecturally
|
|
;; to create one.
|
|
;;
|
|
;; So instead we return a closure to patch up the segment table.
|
|
;; Normally we'd shy away from such destructive interfaces, but it's
|
|
;; OK as we create the header section ourselves.
|
|
;;
|
|
(define (write-segment-header! segment)
|
|
(let ((bv (linker-object-bv header))
|
|
(offset (+ phoff (* (elf-segment-index segment) phentsize))))
|
|
(write-elf-program-header bv offset endianness word-size segment)))
|
|
|
|
(values write-segment-header! objects)))
|
|
|
|
(define (record-special-segments write-segment-header! phidx all-objects)
|
|
(let lp ((phidx phidx) (objects all-objects))
|
|
(match objects
|
|
(() #t)
|
|
((object . objects)
|
|
(let ((section (linker-object-section object)))
|
|
(cond
|
|
((eqv? (elf-section-type section) SHT_DYNAMIC)
|
|
(let ((addr (elf-section-offset section))
|
|
(size (elf-section-size section))
|
|
(align (elf-section-addralign section))
|
|
(flags (cdr (segment-kind section))))
|
|
(write-segment-header!
|
|
(make-elf-segment #:index phidx #:type PT_DYNAMIC
|
|
#:offset addr #:vaddr addr #:paddr addr
|
|
#:filesz size #:memsz size
|
|
#:flags flags #:align align))
|
|
(lp (1+ phidx) objects)))
|
|
(else
|
|
(lp phidx objects))))))))
|
|
|
|
(define (allocate-elf objects page-aligned? endianness word-size
|
|
abi type machine-type)
|
|
"Lay out @var{objects} into an ELF image, computing the size of the
|
|
file, the positions of the objects, and the global symbol table.
|
|
|
|
If @var{page-aligned?} is true, read-only and writable data are
|
|
separated so that only those writable parts of the image need be mapped
|
|
with writable permissions. This makes the resulting image larger. It
|
|
is more suitable to situations where you would write a file out to disk
|
|
and read it in with mmap. Otherwise if @var{page-aligned?} is false,
|
|
sections default to 8-byte alignment.
|
|
|
|
Returns three values: the total image size, a list of objects with
|
|
relocated headers, and the global symbol table."
|
|
(receive (write-segment-header! objects)
|
|
(add-elf-objects objects endianness word-size abi type machine-type)
|
|
(let lp ((seglists (collate-objects-into-segments objects))
|
|
(objects '())
|
|
(phidx 0)
|
|
(addr 0)
|
|
(symtab vlist-null)
|
|
(prev-flags 0))
|
|
(match seglists
|
|
((((type . flags) objs-in ...) seglists ...)
|
|
(receive (addr objs-out symtab)
|
|
(allocate-segment
|
|
write-segment-header!
|
|
phidx type flags objs-in addr symtab
|
|
(if (and page-aligned?
|
|
(not (= flags prev-flags))
|
|
;; Allow sections that are not in
|
|
;; loadable segments to share pages
|
|
;; with PF_R segments.
|
|
(not (and (not type) (= PF_R prev-flags))))
|
|
*page-size*
|
|
8))
|
|
(lp seglists
|
|
(fold-values cons objs-out objects)
|
|
(if type (1+ phidx) phidx)
|
|
addr
|
|
symtab
|
|
flags)))
|
|
(()
|
|
(record-special-segments write-segment-header! phidx objects)
|
|
(values addr
|
|
(reverse objects)
|
|
symtab))))))
|
|
|
|
(define (check-section-numbers objects)
|
|
"Verify that taken as a whole, that all objects have distinct,
|
|
contiguous section numbers, starting from 1. (Section 0 is the null
|
|
section.)"
|
|
(let* ((nsections (1+ (length objects))) ; 1+ for initial NULL section.
|
|
(sections (make-vector nsections #f)))
|
|
(for-each (lambda (object)
|
|
(let ((n (elf-section-index (linker-object-section object))))
|
|
(cond
|
|
((< n 1)
|
|
(error "Invalid section number" object))
|
|
((>= n nsections)
|
|
(error "Invalid section number" object))
|
|
((vector-ref sections n)
|
|
(error "Duplicate section" (vector-ref sections n) object))
|
|
(else
|
|
(vector-set! sections n object)))))
|
|
objects)))
|
|
|
|
;; Given a list of linker objects, collate the objects into segments,
|
|
;; allocate the segments, allocate the ELF bytevector, and write the
|
|
;; segments into the bytevector, relocating as we go.
|
|
;;
|
|
(define* (link-elf objects #:key
|
|
(page-aligned? #t)
|
|
(endianness (target-endianness))
|
|
(word-size (target-word-size))
|
|
(abi ELFOSABI_STANDALONE)
|
|
(type ET_DYN)
|
|
(machine-type EM_NONE))
|
|
"Create an ELF image from the linker objects, @var{objects}.
|
|
|
|
If @var{page-aligned?} is true, read-only and writable data are
|
|
separated so that only those writable parts of the image need be mapped
|
|
with writable permissions. This is suitable for situations where you
|
|
would write a file out to disk and read it in with @code{mmap}.
|
|
Otherwise if @var{page-aligned?} is false, sections default to 8-byte
|
|
alignment.
|
|
|
|
Returns a bytevector."
|
|
(check-section-numbers objects)
|
|
(receive (size objects symtab)
|
|
(allocate-elf objects page-aligned? endianness word-size
|
|
abi type machine-type)
|
|
(let ((bv (make-bytevector size 0)))
|
|
(for-each
|
|
(lambda (object)
|
|
(write-linker-object bv object symtab endianness))
|
|
objects)
|
|
bv)))
|