[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/12: assembler: Separate 'process-relocs' from 'patch-
From: |
Ludovic Courtès |
Subject: |
[Guile-commits] 02/12: assembler: Separate 'process-relocs' from 'patch-relocs!'. |
Date: |
Tue, 17 Jan 2023 11:49:49 -0500 (EST) |
civodul pushed a commit to branch main
in repository guile.
commit 15c4c4ceb312f7a49273823478904581c0c86c6b
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Jan 6 10:56:00 2023 +0100
assembler: Separate 'process-relocs' from 'patch-relocs!'.
* module/system/vm/assembler.scm (process-relocs): Remove 'buf'
parameter and turn into a pure function.
(patch-relocs!): New procedure. Perform the side effects previously
done in 'process-relocs'.
(link-text-object): Adjust accordingly.
---
module/system/vm/assembler.scm | 86 +++++++++++++++++++++++++-----------------
1 file changed, 51 insertions(+), 35 deletions(-)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 77ffb5aa1..188f6f236 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1,6 +1,6 @@
;;; Guile bytecode assembler
-;;; Copyright (C) 2001, 2009-2021 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009-2023 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
@@ -2159,40 +2159,55 @@ these may be @code{#f}."
;;; Linking program text.
;;;
-(define (process-relocs buf relocs labels)
+(define (process-relocs relocs labels)
+ "Return a list of linker relocations for references to symbols defined
+outside the text section."
+ (fold (lambda (reloc tail)
+ (match reloc
+ ((type label base offset)
+ (let ((abs (hashq-ref labels label))
+ (dst (+ base offset)))
+ (case type
+ ((s32)
+ (if abs
+ tail
+ (cons (make-linker-reloc 'rel32/4 dst offset label)
+ tail)))
+ ((x8-s24)
+ (unless abs
+ (error "unbound near relocation" reloc))
+ tail)
+ (else (error "bad relocation kind" reloc)))))))
+ '()
+ relocs))
+
+(define (patch-relocs! buf relocs labels)
"Patch up internal x8-s24 relocations, and any s32 relocations that
-reference symbols in the text section. Return a list of linker
-relocations for references to symbols defined outside the text section."
- (fold
- (lambda (reloc tail)
- (match reloc
- ((type label base offset)
- (let ((abs (hashq-ref labels label))
- (dst (+ base offset)))
- (case type
- ((s32)
- (if abs
- (let ((rel (- abs base)))
- (unless (zero? (logand rel #x3))
- (error "reloc not in 32-bit units!"))
- (bytevector-s32-native-set! buf dst (ash rel -2))
- tail)
- (cons (make-linker-reloc 'rel32/4 dst offset label)
- tail)))
- ((x8-s24)
- (unless abs
- (error "unbound near relocation" reloc))
- (let ((rel (- abs base))
- (u32 (bytevector-u32-native-ref buf dst)))
- (unless (zero? (logand rel #x3))
- (error "reloc not in 32-bit units!"))
- (bytevector-u32-native-set! buf dst
- (pack-u8-s24 (logand u32 #xff)
- (ash rel -2)))
- tail))
- (else (error "bad relocation kind" reloc)))))))
- '()
- relocs))
+reference symbols in the text section."
+ (for-each (lambda (reloc)
+ (match reloc
+ ((type label base offset)
+ (let ((abs (hashq-ref labels label))
+ (dst (+ base offset)))
+ (case type
+ ((s32)
+ (when abs
+ (let ((rel (- abs base)))
+ (unless (zero? (logand rel #x3))
+ (error "reloc not in 32-bit units!"))
+ (bytevector-s32-native-set! buf dst (ash rel -2)))))
+ ((x8-s24)
+ (unless abs
+ (error "unbound near relocation" reloc))
+ (let ((rel (- abs base))
+ (u32 (bytevector-u32-native-ref buf dst)))
+ (unless (zero? (logand rel #x3))
+ (error "reloc not in 32-bit units!"))
+ (bytevector-u32-native-set! buf dst
+ (pack-u8-s24 (logand u32
#xff)
+ (ash rel
-2)))))
+ (else (error "bad relocation kind" reloc)))))))
+ relocs))
(define (process-labels labels)
"Define linker symbols for the label-offset map in @var{labels}.
@@ -2208,9 +2223,10 @@ needed."
(bytevector-copy! (asm-buf asm) 0 buf 0 (bytevector-length buf))
(unless (eq? (asm-endianness asm) (native-endianness))
(byte-swap/4! buf))
+ (patch-relocs! buf (asm-relocs asm) (asm-labels asm))
(make-object asm '.rtl-text
buf
- (process-relocs buf (asm-relocs asm)
+ (process-relocs (asm-relocs asm)
(asm-labels asm))
(process-labels (asm-labels asm)))))
- [Guile-commits] branch main updated (e903b7679 -> 9a004606e), Ludovic Courtès, 2023/01/17
- [Guile-commits] 07/12: assembler: Separate effectful part of 'link-docstrs'., Ludovic Courtès, 2023/01/17
- [Guile-commits] 10/12: linker: Linker object writer takes a single argument., Ludovic Courtès, 2023/01/17
- [Guile-commits] 04/12: assembler: Separate effectful part of 'link-dynamic-section'., Ludovic Courtès, 2023/01/17
- [Guile-commits] 05/12: assembler: Separate effectful part of 'link-procprops'., Ludovic Courtès, 2023/01/17
- [Guile-commits] 08/12: linker: Separate effectful part of 'add-elf-objects'., Ludovic Courtès, 2023/01/17
- [Guile-commits] 09/12: linker, assembler: Avoid intermediate bytevectors., Ludovic Courtès, 2023/01/17
- [Guile-commits] 06/12: assembler: Separate effectful part of 'link-frame-maps'., Ludovic Courtès, 2023/01/17
- [Guile-commits] 03/12: assembler: Separate effectful part of 'link-symtab'., Ludovic Courtès, 2023/01/17
- [Guile-commits] 01/12: Add test for 'string-ref' with a negative index at -O2., Ludovic Courtès, 2023/01/17
- [Guile-commits] 02/12: assembler: Separate 'process-relocs' from 'patch-relocs!'.,
Ludovic Courtès <=
- [Guile-commits] 12/12: Update NEWS., Ludovic Courtès, 2023/01/17
- [Guile-commits] 11/12: linker: Do not store entire ELF in memory when writing to a file., Ludovic Courtès, 2023/01/17