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

86
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,40 +2159,55 @@ these may be @code{#f}."
;;; Linking program text. ;;; 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 "Patch up internal x8-s24 relocations, and any s32 relocations that
reference symbols in the text section. Return a list of linker reference symbols in the text section."
relocations for references to symbols defined outside the text section." (for-each (lambda (reloc)
(fold (match reloc
(lambda (reloc tail) ((type label base offset)
(match reloc (let ((abs (hashq-ref labels label))
((type label base offset) (dst (+ base offset)))
(let ((abs (hashq-ref labels label)) (case type
(dst (+ base offset))) ((s32)
(case type (when abs
((s32) (let ((rel (- abs base)))
(if abs (unless (zero? (logand rel #x3))
(let ((rel (- abs base))) (error "reloc not in 32-bit units!"))
(unless (zero? (logand rel #x3)) (bytevector-s32-native-set! buf dst (ash rel -2)))))
(error "reloc not in 32-bit units!")) ((x8-s24)
(bytevector-s32-native-set! buf dst (ash rel -2)) (unless abs
tail) (error "unbound near relocation" reloc))
(cons (make-linker-reloc 'rel32/4 dst offset label) (let ((rel (- abs base))
tail))) (u32 (bytevector-u32-native-ref buf dst)))
((x8-s24) (unless (zero? (logand rel #x3))
(unless abs (error "reloc not in 32-bit units!"))
(error "unbound near relocation" reloc)) (bytevector-u32-native-set! buf dst
(let ((rel (- abs base)) (pack-u8-s24 (logand u32 #xff)
(u32 (bytevector-u32-native-ref buf dst))) (ash rel -2)))))
(unless (zero? (logand rel #x3)) (else (error "bad relocation kind" reloc)))))))
(error "reloc not in 32-bit units!")) relocs))
(bytevector-u32-native-set! buf dst
(pack-u8-s24 (logand u32 #xff)
(ash rel -2)))
tail))
(else (error "bad relocation kind" reloc)))))))
'()
relocs))
(define (process-labels labels) (define (process-labels labels)
"Define linker symbols for the label-offset map in @var{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)) (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)))))