mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

linker, assembler: Avoid intermediate bytevectors.

Browse source 
This reduces the amount of memory used during linking and reduces the
number of copies to be done between bytevectors.

* module/system/vm/linker.scm (<linker-object>): Remove 'bv' field and
add 'size' and 'writer'.
(make-linker-object): Adjust accordingly.
(string-table-size): New procedure.
(link-string-table!): Remove.
(string-table-writer): New procedure.
(allocate-segment): Adjust 'make-linker-object' call.
(find-shstrndx): Call the 'linker-object-writer' of O.
(add-elf-objects): Adjust 'make-linker-object' call.  Remove
'make-bytevector' allocations and move serialization to lazy 'writer'
procedures.  Define 'segments' and 'add-header-segment!'.  Return the
latter as the first value.
* module/system/vm/assembler.scm (make-object): Remove 'bv' parameter
and add 'size' and 'writer'.
(link-data): Remove 'make-bytevector' call and move serialization to
a lazy 'writer' procedure.
(link-text-object): Likewise.
(link-frame-maps): Likewise.
(link-dynamic-section): Likewise.
(link-shstrtab): Likewise.
(link-symtab): Likewise.
(link-arities): Likewise, and remove 'bytevector-append'.
(link-docstrs): Likewise.
(link-procprops): Likewise.
(link-debug): Likewise, and define 'copy-writer'.
* test-suite/tests/linker.test (link-elf-with-one-main-section): Adjust
accordingly.
This commit is contained in:
Ludovic Courtès 2023-01-07 21:52:06 +01:00
parent d0d9743607
commit 041f11b353
3 changed files with 175 additions and 106 deletions
Download patch file Download diff file Expand all files Collapse all files

143
module/system/vm/assembler.scm
View file

@ -51,6 +51,7 @@
#:use-module (system syntax internal) #:use-module (system syntax internal)
#:use-module (language bytecode) #:use-module (language bytecode)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (rnrs bytevectors gnu)
#:use-module (ice-9 binary-ports) #:use-module (ice-9 binary-ports)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -1762,7 +1763,7 @@ returned instead."
;;; Helper for linking objects. ;;; Helper for linking objects.
;;; ;;;
(define (make-object asm name bv relocs labels . kwargs) (define (make-object asm name size writer relocs labels . kwargs)
"Make a linker object. This helper handles interning the name in the "Make a linker object. This helper handles interning the name in the
shstrtab, assigning the size, allocating a fresh index, and defining a shstrtab, assigning the size, allocating a fresh index, and defining a
corresponding linker symbol for the start of the section." corresponding linker symbol for the start of the section."
@ -1773,9 +1774,9 @@ corresponding linker symbol for the start of the section."
(apply make-elf-section (apply make-elf-section
#:index index #:index index
#:name name-idx #:name name-idx
#:size (bytevector-length bv) #:size size
kwargs) kwargs)
bv relocs size writer relocs
(cons (make-linker-symbol name 0) labels)))) (cons (make-linker-symbol name 0) labels))))
@ -2102,18 +2103,27 @@ should be .data or .rodata), and return the resulting linker object.
(else (else
(let* ((byte-len (vhash-fold (lambda (k v len) (let* ((byte-len (vhash-fold (lambda (k v len)
(+ (byte-length k) (align len 8))) (+ (byte-length k) (align len 8)))
0 data)) 0 data)))
(buf (make-bytevector byte-len 0)))
(let lp ((i 0) (pos 0) (relocs '()) (symbols '())) (let lp ((i 0) (pos 0) (relocs '()) (symbols '()))
(if (< i (vlist-length data)) (if (< i (vlist-length data))
(match (vlist-ref data i) (match (vlist-ref data i)
((obj . obj-label) ((obj . obj-label)
(write buf pos obj)
(lp (1+ i) (lp (1+ i)
(align (+ (byte-length obj) pos) 8) (align (+ (byte-length obj) pos) 8)
(add-relocs obj pos relocs) (add-relocs obj pos relocs)
(cons (make-linker-symbol obj-label pos) symbols)))) (cons (make-linker-symbol obj-label pos) symbols))))
(make-object asm name buf relocs symbols (make-object asm name byte-len
(lambda (bv offset)
(let loop ((i 0) (pos offset))
(when (< i (vlist-length data))
(match (vlist-ref data i)
((obj . obj-label)
(write bv pos obj)
(loop (1+ i)
(align
(+ (byte-length obj) pos)
8)))))))
relocs symbols
#:flags (match name #:flags (match name
('.data (logior SHF_ALLOC SHF_WRITE)) ('.data (logior SHF_ALLOC SHF_WRITE))
('.rodata SHF_ALLOC)))))))))) ('.rodata SHF_ALLOC))))))))))
@ -2219,13 +2229,14 @@ The offsets are expected to be expressed in words."
(define (link-text-object asm) (define (link-text-object asm)
"Link the .rtl-text section, swapping the endianness of the bytes if "Link the .rtl-text section, swapping the endianness of the bytes if
needed." needed."
(let ((buf (make-bytevector (asm-pos asm)))) (let ((size (asm-pos asm)))
(bytevector-copy! (asm-buf asm) 0 buf 0 (bytevector-length buf)) (make-object asm '.rtl-text size
(unless (eq? (asm-endianness asm) (native-endianness)) (lambda (bv offset)
(byte-swap/4! buf)) (let ((buf (bytevector-slice bv offset size)))
(patch-relocs! buf (asm-relocs asm) (asm-labels asm)) (bytevector-copy! (asm-buf asm) 0 buf 0 size)
(make-object asm '.rtl-text (unless (eq? (asm-endianness asm) (native-endianness))
buf (byte-swap/4! buf))
(patch-relocs! buf (asm-relocs asm) (asm-labels asm))))
(process-relocs (asm-relocs asm) (process-relocs (asm-relocs asm)
(asm-labels asm)) (asm-labels asm))
(process-labels (asm-labels asm))))) (process-labels (asm-labels asm)))))
@ -2261,7 +2272,7 @@ needed."
(let* ((endianness (asm-endianness asm)) (let* ((endianness (asm-endianness asm))
(header-pos frame-maps-prefix-len) (header-pos frame-maps-prefix-len)
(map-pos (+ header-pos (* count frame-map-header-len))) (map-pos (+ header-pos (* count frame-map-header-len)))
(bv (make-bytevector (+ map-pos map-len) 0))) (size (+ map-pos map-len)))
(define (write! bv) (define (write! bv)
(bytevector-u32-set! bv 4 map-pos endianness) (bytevector-u32-set! bv 4 map-pos endianness)
(let lp ((maps maps) (header-pos header-pos) (map-pos map-pos)) (let lp ((maps maps) (header-pos header-pos) (map-pos map-pos))
@ -2281,9 +2292,9 @@ needed."
(write-bytes (1+ map-pos) (ash map -8) (write-bytes (1+ map-pos) (ash map -8)
(1- byte-length))))))))) (1- byte-length)))))))))
(write! bv) (make-object asm '.guile.frame-maps size
(make-object asm '.guile.frame-maps (lambda (bv offset)
bv (write! (bytevector-slice bv offset)))
(list (make-linker-reloc 'abs32/1 0 0 '.rtl-text)) (list (make-linker-reloc 'abs32/1 0 0 '.rtl-text))
'() #:type SHT_PROGBITS #:flags SHF_ALLOC))) '() #:type SHT_PROGBITS #:flags SHF_ALLOC)))
(match (asm-slot-maps asm) (match (asm-slot-maps asm)
@ -2319,7 +2330,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(words (if rw (+ words 4) words)) (words (if rw (+ words 4) words))
(words (if rw-init (+ words 2) words)) (words (if rw-init (+ words 2) words))
(words (if frame-maps (+ words 2) words)) (words (if frame-maps (+ words 2) words))
(bv (make-bytevector (* word-size words) 0))) (size (* word-size words)))
(define relocs (define relocs
;; This must match the 'set-label!' calls below. ;; This must match the 'set-label!' calls below.
@ -2353,7 +2364,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(set-uword! 4 DT_GUILE_GC_ROOT) (set-uword! 4 DT_GUILE_GC_ROOT)
(set-label! 5 '.data) (set-label! 5 '.data)
(set-uword! 6 DT_GUILE_GC_ROOT_SZ) (set-uword! 6 DT_GUILE_GC_ROOT_SZ)
(set-uword! 7 (bytevector-length (linker-object-bv rw))) (set-uword! 7 (linker-object-size rw))
(when rw-init (when rw-init
(set-uword! 8 DT_INIT) ; constants (set-uword! 8 DT_INIT) ; constants
(set-label! 9 rw-init))) (set-label! 9 rw-init)))
@ -2363,8 +2374,10 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(set-uword! (- words 2) DT_NULL) (set-uword! (- words 2) DT_NULL)
(set-uword! (- words 1) 0)) (set-uword! (- words 1) 0))
(write! bv) (make-object asm '.dynamic size
(make-object asm '.dynamic bv relocs '() (lambda (bv offset)
(write! (bytevector-slice bv offset)))
relocs '()
#:type SHT_DYNAMIC #:flags SHF_ALLOC))) #:type SHT_DYNAMIC #:flags SHF_ALLOC)))
(case (asm-word-size asm) (case (asm-word-size asm)
((4) (emit-dynamic-section 4 bytevector-u32-set! abs32/1)) ((4) (emit-dynamic-section 4 bytevector-u32-set! abs32/1))
@ -2375,7 +2388,8 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
"Link the string table for the section headers." "Link the string table for the section headers."
(intern-section-name! asm ".shstrtab") (intern-section-name! asm ".shstrtab")
(make-object asm '.shstrtab (make-object asm '.shstrtab
(link-string-table! (asm-shstrtab asm)) (string-table-size (asm-shstrtab asm))
(string-table-writer (asm-shstrtab asm))
'() '() '() '()
#:type SHT_STRTAB #:flags 0)) #:type SHT_STRTAB #:flags 0))
@ -2385,8 +2399,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(size (elf-symbol-len word-size)) (size (elf-symbol-len word-size))
(meta (reverse (asm-meta asm))) (meta (reverse (asm-meta asm)))
(n (length meta)) (n (length meta))
(strtab (make-string-table)) (strtab (make-string-table)))
(bv (make-bytevector (* n size) 0)))
(define (intern-string! name) (define (intern-string! name)
(string-table-intern! strtab (if name (symbol->string name) ""))) (string-table-intern! strtab (if name (symbol->string name) "")))
(define names (define names
@ -2410,13 +2423,13 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
text-section)))) text-section))))
names meta (iota n))) names meta (iota n)))
(write-symbols! bv 0)
(let ((strtab (make-object asm '.strtab (let ((strtab (make-object asm '.strtab
(link-string-table! strtab) (string-table-size strtab)
(string-table-writer strtab)
'() '() '() '()
#:type SHT_STRTAB #:flags 0))) #:type SHT_STRTAB #:flags 0)))
(values (make-object asm '.symtab (values (make-object asm '.symtab
bv (* n size) write-symbols!
'() '() '() '()
#:type SHT_SYMTAB #:flags 0 #:entsize size #:type SHT_SYMTAB #:flags 0 #:entsize size
#:link (elf-section-index #:link (elf-section-index
@ -2626,13 +2639,6 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
((arity) (lambda-size arity)) ((arity) (lambda-size arity))
(arities (case-lambda-size arities)))) (arities (case-lambda-size arities))))
(define (bytevector-append a b)
(let ((out (make-bytevector (+ (bytevector-length a)
(bytevector-length b)))))
(bytevector-copy! a 0 out 0 (bytevector-length a))
(bytevector-copy! b 0 out (bytevector-length a) (bytevector-length b))
out))
(let* ((endianness (asm-endianness asm)) (let* ((endianness (asm-endianness asm))
(metas (reverse (asm-meta asm))) (metas (reverse (asm-meta asm)))
(header-size (fold (lambda (meta size) (header-size (fold (lambda (meta size)
@ -2644,12 +2650,23 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(bytevector-u32-set! headers 0 (bytevector-length headers) endianness) (bytevector-u32-set! headers 0 (bytevector-length headers) endianness)
(let-values (((names-port get-name-bv) (open-bytevector-output-port))) (let-values (((names-port get-name-bv) (open-bytevector-output-port)))
(let* ((relocs (write-arities asm metas headers names-port strtab)) (let* ((relocs (write-arities asm metas headers names-port strtab))
(name-bv (get-name-bv))
(strtab (make-object asm '.guile.arities.strtab (strtab (make-object asm '.guile.arities.strtab
(link-string-table! strtab) (string-table-size strtab)
(string-table-writer strtab)
'() '() '() '()
#:type SHT_STRTAB #:flags 0))) #:type SHT_STRTAB #:flags 0)))
(values (make-object asm '.guile.arities (values (make-object asm '.guile.arities
(bytevector-append headers (get-name-bv)) (+ header-size (bytevector-length name-bv))
(lambda (bv offset)
;; FIXME: Avoid extra allocation + copy.
(bytevector-copy! headers 0
bv offset
header-size)
(bytevector-copy! name-bv 0
bv
(+ offset header-size)
(bytevector-length name-bv)))
relocs '() relocs '()
#:type SHT_PROGBITS #:flags 0 #:type SHT_PROGBITS #:flags 0
#:link (elf-section-index #:link (elf-section-index
@ -2681,28 +2698,31 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(cons (meta-low-pc meta) (cdar tail))))) (cons (meta-low-pc meta) (cdar tail)))))
(reverse (asm-meta asm)))) (reverse (asm-meta asm))))
(let* ((endianness (asm-endianness asm)) (let* ((endianness (asm-endianness asm))
(docstrings (find-docstrings))
(strtab (make-string-table)) (strtab (make-string-table))
(bv (make-bytevector (* (length docstrings) docstr-size) 0))) (docstrings (map (match-lambda
((pc . str)
(cons pc (string-table-intern! strtab str))))
(find-docstrings))))
(define (write-docstrings! bv offset) (define (write-docstrings! bv offset)
(fold (lambda (pair pos) (fold (lambda (pair pos)
(match pair (match pair
((pc . string) ((pc . string-pos)
(bytevector-u32-set! bv pos pc endianness) (bytevector-u32-set! bv pos pc endianness)
(bytevector-u32-set! bv (+ pos 4) (bytevector-u32-set! bv (+ pos 4)
(string-table-intern! strtab string) string-pos
endianness) endianness)
(+ pos docstr-size)))) (+ pos docstr-size))))
offset offset
docstrings)) docstrings))
(write-docstrings! bv 0)
(let ((strtab (make-object asm '.guile.docstrs.strtab (let ((strtab (make-object asm '.guile.docstrs.strtab
(link-string-table! strtab) (string-table-size strtab)
(string-table-writer strtab)
'() '() '() '()
#:type SHT_STRTAB #:flags 0))) #:type SHT_STRTAB #:flags 0)))
(values (make-object asm '.guile.docstrs (values (make-object asm '.guile.docstrs
bv (* (length docstrings) docstr-size)
write-docstrings!
'() '() '() '()
#:type SHT_PROGBITS #:flags 0 #:type SHT_PROGBITS #:flags 0
#:link (elf-section-index #:link (elf-section-index
@ -2751,7 +2771,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(reverse (asm-meta asm)))) (reverse (asm-meta asm))))
(let* ((endianness (asm-endianness asm)) (let* ((endianness (asm-endianness asm))
(procprops (find-procprops)) (procprops (find-procprops))
(bv (make-bytevector (* (length procprops) procprops-size) 0))) (size (* (length procprops) procprops-size)))
(define (write-procprops! bv offset) (define (write-procprops! bv offset)
(let lp ((procprops procprops) (pos offset)) (let lp ((procprops procprops) (pos offset))
(match procprops (match procprops
@ -2773,9 +2793,8 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(intern-constant asm props)) (intern-constant asm props))
relocs)))))) relocs))))))
(write-procprops! bv 0)
(make-object asm '.guile.procprops (make-object asm '.guile.procprops
bv size write-procprops!
relocs '() relocs '()
#:type SHT_PROGBITS #:flags 0))) #:type SHT_PROGBITS #:flags 0)))
@ -3094,6 +3113,11 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(for-each write-die children) (for-each write-die children)
(put-uleb128 die-port 0)))))) (put-uleb128 die-port 0))))))
(define (copy-writer source)
(lambda (bv offset)
(bytevector-copy! source 0 bv offset
(bytevector-length source))))
;; Compilation unit header. ;; Compilation unit header.
(put-u32 die-port 0) ; Length; will patch later. (put-u32 die-port 0) ; Length; will patch later.
(put-u16 die-port 4) ; DWARF 4. (put-u16 die-port 4) ; DWARF 4.
@ -3111,19 +3135,32 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
;; Patch DWARF32 length. ;; Patch DWARF32 length.
(bytevector-u32-set! bv 0 (- (bytevector-length bv) 4) (bytevector-u32-set! bv 0 (- (bytevector-length bv) 4)
(asm-endianness asm)) (asm-endianness asm))
(make-object asm '.debug_info bv die-relocs '() (make-object asm '.debug_info
(bytevector-length bv)
(copy-writer bv)
die-relocs '()
#:type SHT_PROGBITS #:flags 0)) #:type SHT_PROGBITS #:flags 0))
(make-object asm '.debug_abbrev (get-abbrev-bv) '() '() (let ((bv (get-abbrev-bv)))
(make-object asm '.debug_abbrev
(bytevector-length bv) (copy-writer bv)
'() '()
#:type SHT_PROGBITS #:flags 0))
(make-object asm '.debug_str
(string-table-size strtab)
(string-table-writer strtab)
'() '()
#:type SHT_PROGBITS #:flags 0) #:type SHT_PROGBITS #:flags 0)
(make-object asm '.debug_str (link-string-table! strtab) '() '() (make-object asm '.debug_loc
#:type SHT_PROGBITS #:flags 0) 0 (lambda (bv offset) #t)
(make-object asm '.debug_loc #vu8() '() '() '() '()
#:type SHT_PROGBITS #:flags 0) #:type SHT_PROGBITS #:flags 0)
(let ((bv (get-line-bv))) (let ((bv (get-line-bv)))
;; Patch DWARF32 length. ;; Patch DWARF32 length.
(bytevector-u32-set! bv 0 (- (bytevector-length bv) 4) (bytevector-u32-set! bv 0 (- (bytevector-length bv) 4)
(asm-endianness asm)) (asm-endianness asm))
(make-object asm '.debug_line bv line-relocs '() (make-object asm '.debug_line
(bytevector-length bv) (copy-writer bv)
line-relocs '()
#:type SHT_PROGBITS #:flags 0))))) #:type SHT_PROGBITS #:flags 0)))))
(define (link-objects asm) (define (link-objects asm)

117
module/system/vm/linker.scm
View file

@ -66,6 +66,7 @@
(define-module (system vm linker) (define-module (system vm linker)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (rnrs bytevectors gnu)
#: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-1) #:select (append-map))
@ -81,13 +82,15 @@
linker-object? linker-object?
linker-object-name linker-object-name
linker-object-section linker-object-section
linker-object-bv linker-object-size
linker-object-writer
linker-object-relocs linker-object-relocs
(linker-object-symbols* . linker-object-symbols) (linker-object-symbols* . linker-object-symbols)
make-string-table make-string-table
string-table-intern! string-table-intern!
link-string-table! string-table-size
string-table-writer
link-elf)) link-elf))
@ -134,20 +137,22 @@
(address linker-symbol-address)) (address linker-symbol-address))
(define-record-type <linker-object> (define-record-type <linker-object>
(%make-linker-object name section bv relocs symbols) (%make-linker-object name section size writer relocs symbols)
linker-object? linker-object?
(name linker-object-name) (name linker-object-name)
(section linker-object-section) (section linker-object-section)
(bv linker-object-bv) (size linker-object-size)
(writer linker-object-writer set-linker-object-writer!)
(relocs linker-object-relocs) (relocs linker-object-relocs)
(symbols linker-object-symbols)) (symbols linker-object-symbols))
(define (make-linker-object name section bv relocs symbols) (define (make-linker-object name section size writer relocs symbols)
"Create a linker object named @var{name} (a string, or #f for no name), "Create a linker object named @var{name} (a string, or #f for no name),
@code{<elf-section>} header @var{section}, bytevector contents @var{bv}, @code{<elf-section>} header @var{section}, its @var{size} in bytes,
a procedure @code{writer} to write its contents to a bytevector, a
list of linker relocations @var{relocs}, and list of linker symbols list of linker relocations @var{relocs}, and list of linker symbols
@var{symbols}." @var{symbols}."
(%make-linker-object name section bv relocs (%make-linker-object name section size writer relocs
;; Hide a symbol to the beginning of the section ;; Hide a symbol to the beginning of the section
;; in the symbols. ;; in the symbols.
(cons (make-linker-symbol (gensym "*section*") 0) (cons (make-linker-symbol (gensym "*section*") 0)
@ -169,6 +174,10 @@ list of linker relocations @var{relocs}, and list of linker symbols
"Return a string table with one entry: the empty string." "Return a string table with one entry: the empty string."
(%make-string-table '(("" 0 #vu8())) #f)) (%make-string-table '(("" 0 #vu8())) #f))
(define (string-table-size strtab)
"Return the size in bytes of the wire representation of @var{strtab}."
(string-table-length (string-table-strings strtab)))
(define (string-table-length strings) (define (string-table-length strings)
"Return the number of bytes needed for the @var{strings}." "Return the number of bytes needed for the @var{strings}."
(match strings (match strings
@ -192,19 +201,19 @@ Returns the byte index of the string in that table."
strings)) strings))
next)))))) next))))))
(define (link-string-table! table) (define (string-table-writer table)
"Link the functional string table @var{table} into a sequence of "Return a <linker-object> \"writer\" procedure that links the string
bytes, suitable for use as the contents of an ELF string table section." table @var{table} into a sequence of bytes, suitable for use as the
(match table contents of an ELF string table section."
(($ <string-table> strings #f) (lambda (bv offset)
(let ((out (make-bytevector (string-table-length strings) 0))) (match table
(for-each (($ <string-table> strings #f)
(match-lambda (for-each (match-lambda
((_ pos bytes) ((_ pos bytes)
(bytevector-copy! bytes 0 out pos (bytevector-length bytes)))) (bytevector-copy! bytes 0 bv (+ pos offset)
strings) (bytevector-length bytes))))
(set-string-table-linked?! table #t) strings)
out)))) (set-string-table-linked?! table #t)))))
(define (segment-kind section) (define (segment-kind section)
"Return the type of segment needed to store @var{section}, as a pair. "Return the type of segment needed to store @var{section}, as a pair.
@ -401,7 +410,8 @@ the segment table using @code{write-segment-header!}."
(cons (make-linker-object (cons (make-linker-object
(linker-object-name o) (linker-object-name o)
(relocate-section-header section addr) (relocate-section-header section addr)
(linker-object-bv o) (linker-object-size o)
(linker-object-writer o)
(linker-object-relocs o) (linker-object-relocs o)
(linker-object-symbols o)) (linker-object-symbols o))
out) out)
@ -458,7 +468,6 @@ locations, as given in @var{symtab}."
(let* ((section (linker-object-section o)) (let* ((section (linker-object-section o))
(offset (elf-section-offset section)) (offset (elf-section-offset section))
(len (elf-section-size section)) (len (elf-section-size section))
(bytes (linker-object-bv o))
(relocs (linker-object-relocs o))) (relocs (linker-object-relocs o)))
(if (zero? (logand SHF_ALLOC (elf-section-flags section))) (if (zero? (logand SHF_ALLOC (elf-section-flags section)))
(unless (zero? (elf-section-addr section)) (unless (zero? (elf-section-addr section))
@ -467,9 +476,9 @@ locations, as given in @var{symtab}."
(error "loadable section has offset != addr" section))) (error "loadable section has offset != addr" section)))
(if (not (= (elf-section-type section) SHT_NOBITS)) (if (not (= (elf-section-type section) SHT_NOBITS))
(begin (begin
(if (not (= len (bytevector-length bytes))) (unless (= len (linker-object-size o))
(error "unexpected length" section bytes)) (error "unexpected length" section o))
(bytevector-copy! bytes 0 bv offset len) ((linker-object-writer o) bv offset)
(for-each (lambda (reloc) (for-each (lambda (reloc)
(process-reloc reloc bv offset symtab endianness)) (process-reloc reloc bv offset symtab endianness))
relocs))))) relocs)))))
@ -515,7 +524,7 @@ list of objects, augmented with objects for the special ELF sections."
(make-linker-object "" (make-linker-object ""
(make-elf-section #:index 0 #:type SHT_NULL (make-elf-section #:index 0 #:type SHT_NULL
#:flags 0 #:addralign 0) #:flags 0 #:addralign 0)
#vu8() '() '())) 0 (lambda (bv offset) #t) '() '()))
;; The ELF header and the segment table. ;; The ELF header and the segment table.
;; ;;
@ -529,15 +538,15 @@ list of objects, augmented with objects for the special ELF sections."
(elf-header-shoff-offset word-size) (elf-header-shoff-offset word-size)
0 0
shoff-label)) shoff-label))
(size (+ phoff (* phnum phentsize))) (size (+ phoff (* phnum phentsize))))
(bv (make-bytevector size 0)))
(write-elf-header bv header)
;; Leave the segment table uninitialized; it will be filled in ;; Leave the segment table uninitialized; it will be filled in
;; later by calls to the write-segment-header! closure. ;; later by calls to the write-segment-header! closure.
(make-linker-object #f (make-linker-object #f
(make-elf-section #:index index #:type SHT_PROGBITS (make-elf-section #:index index #:type SHT_PROGBITS
#:flags SHF_ALLOC #:size size) #:flags SHF_ALLOC #:size size)
bv size
(lambda (bv offset)
(write-elf-header (bytevector-slice bv offset) header))
(list shoff-reloc) (list shoff-reloc)
'()))) '())))
@ -545,7 +554,6 @@ list of objects, augmented with objects for the special ELF sections."
;; ;;
(define (make-footer objects shoff-label) (define (make-footer objects shoff-label)
(let* ((size (* shentsize shnum)) (let* ((size (* shentsize shnum))
(bv (make-bytevector size 0))
(section-table (make-elf-section #:index (length objects) (section-table (make-elf-section #:index (length objects)
#:type SHT_PROGBITS #:type SHT_PROGBITS
#:flags 0 #:flags 0
@ -578,10 +586,6 @@ list of objects, augmented with objects for the special ELF sections."
(* shentsize (elf-section-index section))))) (* shentsize (elf-section-index section)))))
(write-elf-section-header bv offset endianness word-size section)))) (write-elf-section-header bv offset endianness word-size section))))
(for-each (lambda (object)
(write-object-elf-header! bv 0 object))
objects)
(let ((relocs (fold-values (let ((relocs (fold-values
(lambda (object relocs) (lambda (object relocs)
(compute-reloc (compute-reloc
@ -591,7 +595,14 @@ list of objects, augmented with objects for the special ELF sections."
relocs)) relocs))
objects objects
(compute-reloc shoff-label section-table '())))) (compute-reloc shoff-label section-table '()))))
(%make-linker-object #f section-table bv relocs (%make-linker-object #f section-table size
(lambda (bv offset)
(for-each (lambda (object)
(write-object-elf-header! bv
offset
object))
objects))
relocs
(list (make-linker-symbol shoff-label 0)))))) (list (make-linker-symbol shoff-label 0))))))
(let* ((null-section (make-null-section)) (let* ((null-section (make-null-section))
@ -602,7 +613,8 @@ list of objects, augmented with objects for the special ELF sections."
(objects (cons header objects)) (objects (cons header objects))
(footer (make-footer objects shoff)) (footer (make-footer objects shoff))
(objects (cons footer objects))) (objects (cons footer objects))
(segments '()))
;; The header includes the segment table, which needs offsets and ;; The header includes the segment table, which needs offsets and
;; sizes of the segments. Normally we would use relocs to rewrite ;; sizes of the segments. Normally we would use relocs to rewrite
@ -611,16 +623,27 @@ list of objects, augmented with objects for the special ELF sections."
;; between two symbols, and it's probably a bad idea architecturally ;; between two symbols, and it's probably a bad idea architecturally
;; to create one. ;; to create one.
;; ;;
;; So instead we return a closure to patch up the segment table. ;; So instead change HEADER's writer to patch up the segment table.
;; Normally we'd shy away from such destructive interfaces, but it's (define (add-header-segment! segment)
;; OK as we create the header section ourselves. (set! segments (cons segment segments)))
;;
(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 write-header!
(linker-object-writer header))
(define (write-header+segments! bv offset)
(for-each (lambda (segment)
(let ((offset (+ offset
phoff
(* (elf-segment-index segment) phentsize))))
(write-elf-program-header bv offset
endianness
word-size
segment)))
segments)
(write-header! bv offset))
(set-linker-object-writer! header write-header+segments!)
(values add-header-segment! objects)))
(define (record-special-segments write-segment-header! phidx all-objects) (define (record-special-segments write-segment-header! phidx all-objects)
(let lp ((phidx phidx) (objects all-objects)) (let lp ((phidx phidx) (objects all-objects))
@ -735,7 +758,7 @@ Returns a bytevector."
(receive (size objects symtab) (receive (size objects symtab)
(allocate-elf objects page-aligned? endianness word-size (allocate-elf objects page-aligned? endianness word-size
abi type machine-type) abi type machine-type)
(let ((bv (make-bytevector size 0))) (let ((bv (make-bytevector size 0))) ;TODO: Remove allocation.
(for-each (for-each
(lambda (object) (lambda (object)
(write-linker-object bv object symtab endianness)) (write-linker-object bv object symtab endianness))

21
test-suite/tests/linker.test
View file

@ -1,6 +1,6 @@
;;;; linker.test -*- scheme -*- ;;;; linker.test -*- scheme -*-
;;;; ;;;;
;;;; Copyright 2013, 2019 Free Software Foundation, Inc. ;;;; Copyright 2013, 2019, 2023 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -25,23 +25,32 @@
(define (link-elf-with-one-main-section name bytes) (define (link-elf-with-one-main-section name bytes)
(let ((strtab (make-string-table))) (let ((strtab (make-string-table)))
(define (make-object index name bv relocs . kwargs) (define (make-object index name size writer relocs . kwargs)
(let ((name-idx (string-table-intern! strtab (symbol->string name)))) (let ((name-idx (string-table-intern! strtab (symbol->string name))))
(make-linker-object (symbol->string name) (make-linker-object (symbol->string name)
(apply make-elf-section (apply make-elf-section
#:index index #:index index
#:name name-idx #:name name-idx
#:size (bytevector-length bv) #:size size
kwargs) kwargs)
bv relocs size writer relocs
(list (make-linker-symbol name 0))))) (list (make-linker-symbol name 0)))))
(define (make-shstrtab) (define (make-shstrtab)
(string-table-intern! strtab ".shstrtab") (string-table-intern! strtab ".shstrtab")
(make-object 2 '.shstrtab (link-string-table! strtab) '() (make-object 2 '.shstrtab
(string-table-size strtab)
(string-table-writer strtab)
'()
#: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 1 name bytes '())) (sec (make-object 1 name
(bytevector-length bytes)
(lambda (bv offset)
(bytevector-copy! bytes 0 bv offset
(bytevector-length
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-shstrtab))) (shstrtab (make-shstrtab)))