mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

linker: Linker object writer takes a single argument.

Browse source 
* module/system/vm/linker.scm (write-linker-object): Pass the
'linker-object-writer' a single argument.
(string-table-writer, add-elf-objects): Adjust writers accordingly.
(string-table-writer):
(add-elf-objects):
* module/system/vm/assembler.scm (link-data, link-text-object)
(link-frame-maps, link-dynamic-section)
(link-symtab, link-arities, link-docstrs)
(link-procprops, link-debug): Likewise.
* test-suite/tests/linker.test (link-elf-with-one-main-section):
Likewise.
This commit is contained in:
Ludovic Courtès 2023-01-08 16:28:55 +01:00
parent 041f11b353
commit 4ab71e1f0d
3 changed files with 35 additions and 46 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -2113,8 +2113,8 @@ should be .data or .rodata), and return the resulting linker object.
(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 byte-len (make-object asm name byte-len
(lambda (bv offset) (lambda (bv)
(let loop ((i 0) (pos offset)) (let loop ((i 0) (pos 0))
(when (< i (vlist-length data)) (when (< i (vlist-length data))
(match (vlist-ref data i) (match (vlist-ref data i)
((obj . obj-label) ((obj . obj-label)
@ -2231,12 +2231,11 @@ The offsets are expected to be expressed in words."
needed." needed."
(let ((size (asm-pos asm))) (let ((size (asm-pos asm)))
(make-object asm '.rtl-text size (make-object asm '.rtl-text size
(lambda (bv offset) (lambda (buf)
(let ((buf (bytevector-slice bv offset size))) (bytevector-copy! (asm-buf asm) 0 buf 0 size)
(bytevector-copy! (asm-buf asm) 0 buf 0 size) (unless (eq? (asm-endianness asm) (native-endianness))
(unless (eq? (asm-endianness asm) (native-endianness)) (byte-swap/4! buf))
(byte-swap/4! buf)) (patch-relocs! buf (asm-relocs asm) (asm-labels asm)))
(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)))))
@ -2292,9 +2291,7 @@ needed."
(write-bytes (1+ map-pos) (ash map -8) (write-bytes (1+ map-pos) (ash map -8)
(1- byte-length))))))))) (1- byte-length)))))))))
(make-object asm '.guile.frame-maps size (make-object asm '.guile.frame-maps size write!
(lambda (bv offset)
(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)
@ -2374,9 +2371,7 @@ 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))
(make-object asm '.dynamic size (make-object asm '.dynamic size write!
(lambda (bv offset)
(write! (bytevector-slice bv offset)))
relocs '() relocs '()
#:type SHT_DYNAMIC #:flags SHF_ALLOC))) #:type SHT_DYNAMIC #:flags SHF_ALLOC)))
(case (asm-word-size asm) (case (asm-word-size asm)
@ -2406,9 +2401,9 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(map (lambda (meta n) (map (lambda (meta n)
(intern-string! (meta-name meta))) (intern-string! (meta-name meta)))
meta (iota n))) meta (iota n)))
(define (write-symbols! bv offset) (define (write-symbols! bv)
(for-each (lambda (name meta n) (for-each (lambda (name meta n)
(write-elf-symbol bv (+ offset (* n size)) (write-elf-symbol bv (* n size)
endianness word-size endianness word-size
(make-elf-symbol (make-elf-symbol
#:name name #:name name
@ -2658,14 +2653,11 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
#:type SHT_STRTAB #:flags 0))) #:type SHT_STRTAB #:flags 0)))
(values (make-object asm '.guile.arities (values (make-object asm '.guile.arities
(+ header-size (bytevector-length name-bv)) (+ header-size (bytevector-length name-bv))
(lambda (bv offset) (lambda (bv)
;; FIXME: Avoid extra allocation + copy. ;; FIXME: Avoid extra allocation + copy.
(bytevector-copy! headers 0 (bytevector-copy! headers 0 bv 0
bv offset
header-size) header-size)
(bytevector-copy! name-bv 0 (bytevector-copy! name-bv 0 bv header-size
bv
(+ offset header-size)
(bytevector-length name-bv))) (bytevector-length name-bv)))
relocs '() relocs '()
#:type SHT_PROGBITS #:flags 0 #:type SHT_PROGBITS #:flags 0
@ -2703,7 +2695,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
((pc . str) ((pc . str)
(cons pc (string-table-intern! strtab str)))) (cons pc (string-table-intern! strtab str))))
(find-docstrings)))) (find-docstrings))))
(define (write-docstrings! bv offset) (define (write-docstrings! bv)
(fold (lambda (pair pos) (fold (lambda (pair pos)
(match pair (match pair
((pc . string-pos) ((pc . string-pos)
@ -2712,7 +2704,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
string-pos string-pos
endianness) endianness)
(+ pos docstr-size)))) (+ pos docstr-size))))
offset 0
docstrings)) docstrings))
(let ((strtab (make-object asm '.guile.docstrs.strtab (let ((strtab (make-object asm '.guile.docstrs.strtab
@ -2772,8 +2764,8 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(let* ((endianness (asm-endianness asm)) (let* ((endianness (asm-endianness asm))
(procprops (find-procprops)) (procprops (find-procprops))
(size (* (length procprops) procprops-size))) (size (* (length procprops) procprops-size)))
(define (write-procprops! bv offset) (define (write-procprops! bv)
(let lp ((procprops procprops) (pos offset)) (let lp ((procprops procprops) (pos 0))
(match procprops (match procprops
(() (()
#t) #t)
@ -3114,8 +3106,8 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(put-uleb128 die-port 0)))))) (put-uleb128 die-port 0))))))
(define (copy-writer source) (define (copy-writer source)
(lambda (bv offset) (lambda (bv)
(bytevector-copy! source 0 bv offset (bytevector-copy! source 0 bv 0
(bytevector-length source)))) (bytevector-length source))))
;; Compilation unit header. ;; Compilation unit header.
@ -3151,7 +3143,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
'() '() '() '()
#:type SHT_PROGBITS #:flags 0) #:type SHT_PROGBITS #:flags 0)
(make-object asm '.debug_loc (make-object asm '.debug_loc
0 (lambda (bv offset) #t) 0 (lambda (bv) #t)
'() '() '() '()
#:type SHT_PROGBITS #:flags 0) #:type SHT_PROGBITS #:flags 0)
(let ((bv (get-line-bv))) (let ((bv (get-line-bv)))

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

@ -205,12 +205,12 @@ Returns the byte index of the string in that table."
"Return a <linker-object> \"writer\" procedure that links the string "Return a <linker-object> \"writer\" procedure that links the string
table @var{table} into a sequence of bytes, suitable for use as the table @var{table} into a sequence of bytes, suitable for use as the
contents of an ELF string table section." contents of an ELF string table section."
(lambda (bv offset) (lambda (bv)
(match table (match table
(($ <string-table> strings #f) (($ <string-table> strings #f)
(for-each (match-lambda (for-each (match-lambda
((_ pos bytes) ((_ pos bytes)
(bytevector-copy! bytes 0 bv (+ pos offset) (bytevector-copy! bytes 0 bv pos
(bytevector-length bytes)))) (bytevector-length bytes))))
strings) strings)
(set-string-table-linked?! table #t))))) (set-string-table-linked?! table #t)))))
@ -478,7 +478,7 @@ locations, as given in @var{symtab}."
(begin (begin
(unless (= len (linker-object-size o)) (unless (= len (linker-object-size o))
(error "unexpected length" section o)) (error "unexpected length" section o))
((linker-object-writer o) bv offset) ((linker-object-writer o) (bytevector-slice bv offset len))
(for-each (lambda (reloc) (for-each (lambda (reloc)
(process-reloc reloc bv offset symtab endianness)) (process-reloc reloc bv offset symtab endianness))
relocs))))) relocs)))))
@ -524,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)
0 (lambda (bv offset) #t) '() '())) 0 (lambda (bv) #t) '() '()))
;; The ELF header and the segment table. ;; The ELF header and the segment table.
;; ;;
@ -545,8 +545,8 @@ list of objects, augmented with objects for the special ELF sections."
(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)
size size
(lambda (bv offset) (lambda (bv)
(write-elf-header (bytevector-slice bv offset) header)) (write-elf-header bv header))
(list shoff-reloc) (list shoff-reloc)
'()))) '())))
@ -580,10 +580,9 @@ list of objects, augmented with objects for the special ELF sections."
section-label) section-label)
relocs)))))) relocs))))))
(define (write-object-elf-header! bv offset object) (define (write-object-elf-header! bv object)
(let ((section (linker-object-section object))) (let ((section (linker-object-section object)))
(let ((offset (+ offset (let ((offset (* 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))))
(let ((relocs (fold-values (let ((relocs (fold-values
@ -596,10 +595,9 @@ list of objects, augmented with objects for the special ELF sections."
objects objects
(compute-reloc shoff-label section-table '())))) (compute-reloc shoff-label section-table '()))))
(%make-linker-object #f section-table size (%make-linker-object #f section-table size
(lambda (bv offset) (lambda (bv)
(for-each (lambda (object) (for-each (lambda (object)
(write-object-elf-header! bv (write-object-elf-header! bv
offset
object)) object))
objects)) objects))
relocs relocs
@ -630,17 +628,16 @@ list of objects, augmented with objects for the special ELF sections."
(define write-header! (define write-header!
(linker-object-writer header)) (linker-object-writer header))
(define (write-header+segments! bv offset) (define (write-header+segments! bv)
(for-each (lambda (segment) (for-each (lambda (segment)
(let ((offset (+ offset (let ((offset (+ phoff
phoff
(* (elf-segment-index segment) phentsize)))) (* (elf-segment-index segment) phentsize))))
(write-elf-program-header bv offset (write-elf-program-header bv offset
endianness endianness
word-size word-size
segment))) segment)))
segments) segments)
(write-header! bv offset)) (write-header! bv))
(set-linker-object-writer! header write-header+segments!) (set-linker-object-writer! header write-header+segments!)
(values add-header-segment! objects))) (values add-header-segment! objects)))

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

@ -46,8 +46,8 @@
(endianness (target-endianness)) (endianness (target-endianness))
(sec (make-object 1 name (sec (make-object 1 name
(bytevector-length bytes) (bytevector-length bytes)
(lambda (bv offset) (lambda (bv)
(bytevector-copy! bytes 0 bv offset (bytevector-copy! bytes 0 bv 0
(bytevector-length (bytevector-length
bytes))) bytes)))
'())) '()))