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

Assembler works on byte offsets, not u32 offsets

Browse source 
* module/system/vm/assembler.scm (u32-ref, u32-set!, s32-ref, s32-set!):
  Remove these helpers.
* module/system/vm/assembler.scm (<asm>): Track offsets in bytes, not
  u32 units.
  (emit, assembler, process-relocs, process-labels, link-text-object)
  (link-frame-maps, link-symtab, write-arities, link-docstrs)
  (link-procprops, link-debug): Adapt.

* module/system/vm/linker.scm (process-reloc): Add addend before
  dividing by 4 for rel32/4 symbols.
This commit is contained in:
Andy Wingo 2015-12-03 22:10:31 +01:00
parent 3c271457f1
commit 9e1c07bda6
2 changed files with 48 additions and 56 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -291,20 +291,6 @@
((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0) ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
(if f2 (ash 1 1) 0)))))) (if f2 (ash 1 1) 0))))))
;;; Helpers to read and write 32-bit units in a buffer.
(define-inline (u32-ref buf n)
(bytevector-u32-native-ref buf (* n 4)))
(define-inline (u32-set! buf n val)
(bytevector-u32-native-set! buf (* n 4) val))
(define-inline (s32-ref buf n)
(bytevector-s32-native-ref buf (* n 4)))
(define-inline (s32-set! buf n val)
(bytevector-s32-native-set! buf (* n 4) val))
@ -366,20 +352,19 @@
slot-maps) slot-maps)
asm? asm?
;; We write bytecode into what is logically a growable vector, ;; We write bytecode into a bytevector, growing the bytevector as
;; implemented as a list of blocks. asm-cur is the current block, and ;; needed. asm-cur is that bytevector, and asm-pos is the byte offset
;; asm-pos is the current index into that block, in 32-bit units. ;; into the vector at which the next word should be written.
;; ;;
(buf asm-buf set-asm-buf!) (buf asm-buf set-asm-buf!)
(pos asm-pos set-asm-pos!) (pos asm-pos set-asm-pos!)
;; asm-start is an absolute position, indicating the offset of the ;; asm-start is an absolute position, indicating the byte offset of
;; beginning of an instruction (in u32 units). It is updated after ;; the beginning of an instruction. It is updated after writing all
;; writing all the words for one primitive instruction. It models the ;; the words for one primitive instruction. It models the position of
;; position of the instruction pointer during execution, given that ;; the instruction pointer during execution, given that the VM updates
;; the VM updates the IP only at the end of executing the instruction, ;; the IP only at the end of executing the instruction, and is thus
;; and is thus useful for computing offsets between two points in a ;; useful for computing offsets between two points in a program.
;; program.
;; ;;
(start asm-start set-asm-start!) (start asm-start set-asm-start!)
@ -466,8 +451,8 @@ target."
(define-inline (emit asm u32) (define-inline (emit asm u32)
"Emit one 32-bit word into the instruction stream. Assumes that there "Emit one 32-bit word into the instruction stream. Assumes that there
is space for the word." is space for the word."
(u32-set! (asm-buf asm) (asm-pos asm) u32) (bytevector-u32-native-set! (asm-buf asm) (asm-pos asm) u32)
(set-asm-pos! asm (1+ (asm-pos asm)))) (set-asm-pos! asm (+ (asm-pos asm) 4)))
(define-inline (make-reloc type label base word) (define-inline (make-reloc type label base word)
"Make an internal relocation of type @var{type} referencing symbol "Make an internal relocation of type @var{type} referencing symbol
@ -596,7 +581,7 @@ later by the linker."
(emit asm 0)) (emit asm 0))
((LO32 label offset) ((LO32 label offset)
(record-far-label-reference asm label (record-far-label-reference asm label
(* offset (/ (asm-word-size asm) 4))) (* offset (asm-word-size asm)))
(emit asm 0)) (emit asm 0))
((C8_C24 a b) ((C8_C24 a b)
(emit asm (pack-u8-u24 a b))) (emit asm (pack-u8-u24 a b)))
@ -638,7 +623,7 @@ later by the linker."
#'(lambda (asm formal0 ... formal* ... ...) #'(lambda (asm formal0 ... formal* ... ...)
(let lp () (let lp ()
(let ((words (length '(word0 word* ...)))) (let ((words (length '(word0 word* ...))))
(unless (<= (* 4 (+ (asm-pos asm) words)) (unless (<= (+ (asm-pos asm) (* 4 words))
(bytevector-length (asm-buf asm))) (bytevector-length (asm-buf asm)))
(grow-buffer! asm) (grow-buffer! asm)
(lp)))) (lp))))
@ -1201,7 +1186,7 @@ returned instead."
(define-macro-assembler (definition asm name slot representation) (define-macro-assembler (definition asm name slot representation)
(let* ((arity (car (meta-arities (car (asm-meta asm))))) (let* ((arity (car (meta-arities (car (asm-meta asm)))))
(def (vector name slot representation (def (vector name slot representation
(* (- (asm-start asm) (arity-low-pc arity)) 4)))) (- (asm-start asm) (arity-low-pc arity)))))
(set-arity-definitions! arity (cons def (arity-definitions arity))))) (set-arity-definitions! arity (cons def (arity-definitions arity)))))
(define-macro-assembler (cache-current-module! asm module scope) (define-macro-assembler (cache-current-module! asm module scope)
@ -1550,23 +1535,29 @@ relocations for references to symbols defined outside the text section."
(fold (fold
(lambda (reloc tail) (lambda (reloc tail)
(match reloc (match reloc
((type label base word) ((type label base offset)
(let ((abs (hashq-ref labels label)) (let ((abs (hashq-ref labels label))
(dst (+ base word))) (dst (+ base offset)))
(case type (case type
((s32) ((s32)
(if abs (if abs
(let ((rel (- abs base))) (let ((rel (- abs base)))
(s32-set! buf dst rel) (unless (zero? (logand rel #x3))
(error "reloc not in 32-bit units!"))
(bytevector-s32-native-set! buf dst (ash rel -2))
tail) tail)
(cons (make-linker-reloc 'rel32/4 (* dst 4) word label) (cons (make-linker-reloc 'rel32/4 dst offset label)
tail))) tail)))
((x8-s24) ((x8-s24)
(unless abs (unless abs
(error "unbound near relocation" reloc)) (error "unbound near relocation" reloc))
(let ((rel (- abs base)) (let ((rel (- abs base))
(u32 (u32-ref buf dst))) (u32 (bytevector-u32-native-ref buf dst)))
(u32-set! buf dst (pack-u8-s24 (logand u32 #xff) rel)) (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)) tail))
(else (error "bad relocation kind" reloc))))))) (else (error "bad relocation kind" reloc)))))))
'() '()
@ -1576,7 +1567,7 @@ relocations for references to symbols defined outside the text section."
"Define linker symbols for the label-offset map in @var{labels}. "Define linker symbols for the label-offset map in @var{labels}.
The offsets are expected to be expressed in words." The offsets are expected to be expressed in words."
(hash-map->list (lambda (label loc) (hash-map->list (lambda (label loc)
(make-linker-symbol label (* loc 4))) (make-linker-symbol label loc))
labels)) labels))
(define (swap-bytes! buf) (define (swap-bytes! buf)
@ -1596,7 +1587,7 @@ The offsets are expected to be expressed in words."
(define (link-text-object asm) (define (link-text-object asm)
"Link the .rtl-text section, swapping the endianness of the bytes if "Link the .rtl-text section, swapping the endianness of the bytes if
needed." needed."
(let ((buf (make-u32vector (asm-pos asm)))) (let ((buf (make-bytevector (asm-pos asm))))
(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))
(swap-bytes! buf)) (swap-bytes! buf))
@ -1646,7 +1637,7 @@ needed."
(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))
(((pos proc-slot . map) . maps) (((pos proc-slot . map) . maps)
(bytevector-u32-set! bv header-pos (* pos 4) endianness) (bytevector-u32-set! bv header-pos pos endianness)
(bytevector-u32-set! bv (+ header-pos 4) map-pos endianness) (bytevector-u32-set! bv (+ header-pos 4) map-pos endianness)
(let write-bytes ((map-pos map-pos) (let write-bytes ((map-pos map-pos)
(map map) (map map)
@ -1753,9 +1744,9 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
#:name name #:name name
;; Symbol value and size are measured in ;; Symbol value and size are measured in
;; bytes, not u32s. ;; bytes, not u32s.
#:value (* 4 (meta-low-pc meta)) #:value (meta-low-pc meta)
#:size (* 4 (- (meta-high-pc meta) #:size (- (meta-high-pc meta)
(meta-low-pc meta))) (meta-low-pc meta))
#:type STT_FUNC #:type STT_FUNC
#:visibility STV_HIDDEN #:visibility STV_HIDDEN
#:shndx (elf-section-index text-section))))) #:shndx (elf-section-index text-section)))))
@ -1870,8 +1861,8 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(define (write-header pos low-pc high-pc offset flags nreq nopt nlocals) (define (write-header pos low-pc high-pc offset flags nreq nopt nlocals)
(unless (<= (+ nreq nopt) nlocals) (unless (<= (+ nreq nopt) nlocals)
(error "forgot to emit definition instructions?")) (error "forgot to emit definition instructions?"))
(bytevector-u32-set! headers pos (* low-pc 4) (asm-endianness asm)) (bytevector-u32-set! headers pos low-pc (asm-endianness asm))
(bytevector-u32-set! headers (+ pos 4) (* high-pc 4) (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 4) high-pc (asm-endianness asm))
(bytevector-u32-set! headers (+ pos 8) offset (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 8) offset (asm-endianness asm))
(bytevector-u32-set! headers (+ pos 12) flags (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 12) flags (asm-endianness asm))
(bytevector-u32-set! headers (+ pos 16) nreq (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 16) nreq (asm-endianness asm))
@ -2018,7 +2009,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(and tail (and tail
(not (find-tail is-documentation? (cdr tail))) (not (find-tail is-documentation? (cdr tail)))
(string? (cdar tail)) (string? (cdar tail))
(cons (* 4 (meta-low-pc meta)) (cdar tail))))) (cons (meta-low-pc meta) (cdar tail)))))
(reverse (asm-meta asm)))) (reverse (asm-meta asm))))
(let* ((endianness (asm-endianness asm)) (let* ((endianness (asm-endianness asm))
(docstrings (find-docstrings)) (docstrings (find-docstrings))
@ -2084,7 +2075,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(filter-map (lambda (meta) (filter-map (lambda (meta)
(let ((props (props-without-name-or-docstring meta))) (let ((props (props-without-name-or-docstring meta)))
(and (pair? props) (and (pair? props)
(cons (* 4 (meta-low-pc meta)) props)))) (cons (meta-low-pc meta) props))))
(reverse (asm-meta asm)))) (reverse (asm-meta asm))))
(let* ((endianness (asm-endianness asm)) (let* ((endianness (asm-endianness asm))
(procprops (find-procprops)) (procprops (find-procprops))
@ -2145,14 +2136,14 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(else (else
'())) '()))
(low-pc ,(meta-label meta)) (low-pc ,(meta-label meta))
(high-pc ,(* 4 (- (meta-high-pc meta) (meta-low-pc meta))))))) (high-pc ,(- (meta-high-pc meta) (meta-low-pc meta))))))
(define (make-compile-unit-die asm) (define (make-compile-unit-die asm)
`(compile-unit `(compile-unit
(@ (producer ,(string-append "Guile " (version))) (@ (producer ,(string-append "Guile " (version)))
(language ,(asm-language asm)) (language ,(asm-language asm))
(low-pc .rtl-text) (low-pc .rtl-text)
(high-pc ,(* 4 (asm-pos asm))) (high-pc ,(asm-pos asm))
(stmt-list 0)) (stmt-list 0))
,@(map meta->subprogram-die (reverse (asm-meta asm))))) ,@(map meta->subprogram-die (reverse (asm-meta asm)))))
@ -2200,6 +2191,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
;; from 10 to 255, so 246 values. ;; from 10 to 255, so 246 values.
(define base -4) (define base -4)
(define range 15) (define range 15)
(define min-inc 4) ; Minimum PC increment.
(let lp ((sources (asm-sources asm)) (out '())) (let lp ((sources (asm-sources asm)) (out '()))
(match sources (match sources
@ -2225,7 +2217,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(put-u32 line-port 0) ; Length; will patch later. (put-u32 line-port 0) ; Length; will patch later.
(put-u16 line-port 2) ; DWARF 2 format. (put-u16 line-port 2) ; DWARF 2 format.
(put-u32 line-port 0) ; Prologue length; will patch later. (put-u32 line-port 0) ; Prologue length; will patch later.
(put-u8 line-port 4) ; Minimum instruction length: 4 bytes. (put-u8 line-port min-inc) ; Minimum instruction length: 4 bytes.
(put-u8 line-port 1) ; Default is-stmt: true. (put-u8 line-port 1) ; Default is-stmt: true.
(put-s8 line-port base) ; Line base. See the DWARF standard. (put-s8 line-port base) ; Line base. See the DWARF standard.
@ -2297,12 +2289,14 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(add-reloc! 'abs64/1) (add-reloc! 'abs64/1)
(put-u64 line-port 0)))) (put-u64 line-port 0))))
(define (end-sequence pc) (define (end-sequence pc)
(let ((pc-inc (- (asm-pos asm) pc))) (let ((pc-inc (/ (- (asm-pos asm) pc) min-inc)))
(put-u8 line-port 2) ; advance-pc (put-u8 line-port 2) ; advance-pc
(put-uleb128 line-port pc-inc)) (put-uleb128 line-port pc-inc))
(extended-op 1 0)) (extended-op 1 0))
(define (advance-pc pc-inc line-inc) (define (advance-pc pc-inc line-inc)
(let ((spec (+ (- line-inc base) (* pc-inc range) 10))) (let ((spec (+ (- line-inc base)
(* (/ pc-inc min-inc) range)
10)))
(cond (cond
((or (< line-inc base) (>= line-inc (+ base range))) ((or (< line-inc base) (>= line-inc (+ base range)))
(advance-line line-inc) (advance-line line-inc)
@ -2311,11 +2305,11 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(put-u8 line-port spec)) (put-u8 line-port spec))
((< spec 500) ((< spec 500)
(put-u8 line-port 8) ; const-advance-pc (put-u8 line-port 8) ; const-advance-pc
(advance-pc (- pc-inc (floor/ (- 255 10) range)) (advance-pc (- pc-inc (* (floor/ (- 255 10) range) min-inc))
line-inc)) line-inc))
(else (else
(put-u8 line-port 2) ; advance-pc (put-u8 line-port 2) ; advance-pc
(put-uleb128 line-port pc-inc) (put-uleb128 line-port (/ pc-inc min-inc))
(advance-pc 0 line-inc))))) (advance-pc 0 line-inc)))))
(define (advance-line inc) (define (advance-line inc)
(put-u8 line-port 3) (put-u8 line-port 3)

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

@ -394,12 +394,10 @@ symbol, as present in @var{symtab}."
(target (linker-symbol-address symbol))) (target (linker-symbol-address symbol)))
(case (linker-reloc-type reloc) (case (linker-reloc-type reloc)
((rel32/4) ((rel32/4)
(let ((diff (- target offset))) (let ((diff (+ (- target offset) (linker-reloc-addend reloc))))
(unless (zero? (modulo diff 4)) (unless (zero? (modulo diff 4))
(error "Bad offset" reloc symbol offset)) (error "Bad offset" reloc symbol offset))
(bytevector-s32-set! bv offset (bytevector-s32-set! bv offset (/ diff 4) endianness)))
(+ (/ diff 4) (linker-reloc-addend reloc))
endianness)))
((rel32/1) ((rel32/1)
(let ((diff (- target offset))) (let ((diff (- target offset)))
(bytevector-s32-set! bv offset (bytevector-s32-set! bv offset