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

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
;;; 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)))))