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

assembler: Separate 'process-relocs' from 'patch-relocs!'.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2023-01-06 10:56:00 +01:00
parent cd9fc16ba0
commit 15c4c4ceb3
1 changed files with 51 additions and 35 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;; Guile bytecode assembler ;;; 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 ;;; 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
@ -2159,12 +2159,10 @@ these may be @code{#f}."
;;; Linking program text. ;;; Linking program text.
;;; ;;;
(define (process-relocs buf relocs labels) (define (process-relocs relocs labels)
"Patch up internal x8-s24 relocations, and any s32 relocations that "Return a list of linker relocations for references to symbols defined
reference symbols in the text section. Return a list of linker outside the text section."
relocations for references to symbols defined outside the text section." (fold (lambda (reloc tail)
(fold
(lambda (reloc tail)
(match reloc (match reloc
((type label base offset) ((type label base offset)
(let ((abs (hashq-ref labels label)) (let ((abs (hashq-ref labels label))
@ -2172,13 +2170,32 @@ relocations for references to symbols defined outside the text section."
(case type (case type
((s32) ((s32)
(if abs (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."
(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))) (let ((rel (- abs base)))
(unless (zero? (logand rel #x3)) (unless (zero? (logand rel #x3))
(error "reloc not in 32-bit units!")) (error "reloc not in 32-bit units!"))
(bytevector-s32-native-set! buf dst (ash rel -2)) (bytevector-s32-native-set! buf dst (ash rel -2)))))
tail)
(cons (make-linker-reloc 'rel32/4 dst offset label)
tail)))
((x8-s24) ((x8-s24)
(unless abs (unless abs
(error "unbound near relocation" reloc)) (error "unbound near relocation" reloc))
@ -2188,10 +2205,8 @@ relocations for references to symbols defined outside the text section."
(error "reloc not in 32-bit units!")) (error "reloc not in 32-bit units!"))
(bytevector-u32-native-set! buf dst (bytevector-u32-native-set! buf dst
(pack-u8-s24 (logand u32 #xff) (pack-u8-s24 (logand u32 #xff)
(ash rel -2))) (ash rel -2)))))
tail))
(else (error "bad relocation kind" reloc))))))) (else (error "bad relocation kind" reloc)))))))
'()
relocs)) relocs))
(define (process-labels labels) (define (process-labels labels)
@ -2208,9 +2223,10 @@ needed."
(bytevector-copy! (asm-buf asm) 0 buf 0 (bytevector-length buf)) (bytevector-copy! (asm-buf asm) 0 buf 0 (bytevector-length buf))
(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))
(make-object asm '.rtl-text (make-object asm '.rtl-text
buf buf
(process-relocs buf (asm-relocs asm) (process-relocs (asm-relocs asm)
(asm-labels asm)) (asm-labels asm))
(process-labels (asm-labels asm))))) (process-labels (asm-labels asm)))))