mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-30 06:50:31 +02:00
Write all local variable names into the arities section
* module/system/vm/assembler.scm (put-uleb128, put-sleb128) (port-position): Lift out these helpers. (arity-header-len, write-arities, link-arities): Add "nlocals" to the arity headers. Write names of all locals into the arities section, not just the arguments. Write them as uleb128's instead of uint32's, to save space. * module/system/vm/debug.scm (arity-header-len, arity-nlocals*) (arity-nlocals, arity-locals, arity-arguments-alist): Adapt to new encoding for arities.
This commit is contained in:
Andy Wingo
parent
cade4c8fe1
commit
c3651bd55b
2 changed files with 192 additions and 163 deletions
|
|
@ -1399,6 +1399,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
|
||||||
;;; uint32_t flags;
|
;;; uint32_t flags;
|
||||||
;;; uint32_t nreq;
|
;;; uint32_t nreq;
|
||||||
;;; uint32_t nopt;
|
;;; uint32_t nopt;
|
||||||
|
;;; uint32_t nlocals;
|
||||||
;;; }
|
;;; }
|
||||||
;;;
|
;;;
|
||||||
;;; All of the offsets and addresses are 32 bits. We can expand in the
|
;;; All of the offsets and addresses are 32 bits. We can expand in the
|
||||||
|
|
@ -1423,11 +1424,11 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
|
||||||
;;;
|
;;;
|
||||||
;;; If the arity has keyword arguments -- if has-keyword-args? is set in
|
;;; If the arity has keyword arguments -- if has-keyword-args? is set in
|
||||||
;;; the flags -- the first uint32 pointed to by offset encodes a link to
|
;;; the flags -- the first uint32 pointed to by offset encodes a link to
|
||||||
;;; the "keyword indices" literal, in the data section. Then follow
|
;;; the "keyword indices" literal, in the data section. Then follow the
|
||||||
;;; links for required arguments are first, in order, as uint32 values.
|
;;; names for all locals, in order, as uleb128 values. The required
|
||||||
;;; Next follow the optionals, then the rest link if has-rest? is set.
|
;;; arguments will be the first locals, followed by the optionals,
|
||||||
;;; Unlike the other links, the kw-indices link points into the data
|
;;; followed by the rest argument if if has-rest? is set. The names
|
||||||
;;; section, and is relative to the ELF image as a whole.
|
;;; point into the associated string table section.
|
||||||
;;;
|
;;;
|
||||||
;;; Functions with no arities have no arities information present in the
|
;;; Functions with no arities have no arities information present in the
|
||||||
;;; .guile.arities section.
|
;;; .guile.arities section.
|
||||||
|
|
@ -1444,10 +1445,28 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
|
||||||
(define arities-prefix-len 4)
|
(define arities-prefix-len 4)
|
||||||
|
|
||||||
;; Length of an arity header, in bytes.
|
;; Length of an arity header, in bytes.
|
||||||
(define arity-header-len (* 6 4))
|
(define arity-header-len (* 7 4))
|
||||||
|
|
||||||
;; The offset of "offset" within arity header, in bytes.
|
;; Some helpers.
|
||||||
(define arity-header-offset-offset (* 2 4))
|
(define (put-uleb128 port val)
|
||||||
|
(let lp ((val val))
|
||||||
|
(let ((next (ash val -7)))
|
||||||
|
(if (zero? next)
|
||||||
|
(put-u8 port val)
|
||||||
|
(begin
|
||||||
|
(put-u8 port (logior #x80 (logand val #x7f)))
|
||||||
|
(lp next))))))
|
||||||
|
|
||||||
|
(define (put-sleb128 port val)
|
||||||
|
(let lp ((val val))
|
||||||
|
(if (<= 0 (+ val 64) 127)
|
||||||
|
(put-u8 port (logand val #x7f))
|
||||||
|
(begin
|
||||||
|
(put-u8 port (logior #x80 (logand val #x7f)))
|
||||||
|
(lp (ash val -7))))))
|
||||||
|
|
||||||
|
(define (port-position port)
|
||||||
|
(seek port 0 SEEK_CUR))
|
||||||
|
|
||||||
(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
|
(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
|
||||||
has-keyword-args? is-case-lambda?
|
has-keyword-args? is-case-lambda?
|
||||||
|
|
@ -1458,131 +1477,114 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
|
||||||
(if is-case-lambda? (ash 1 3) 0)
|
(if is-case-lambda? (ash 1 3) 0)
|
||||||
(if is-in-case-lambda? (ash 1 4) 0)))
|
(if is-in-case-lambda? (ash 1 4) 0)))
|
||||||
|
|
||||||
(define (meta-arities-size meta)
|
(define (write-arities asm metas headers names-port strtab)
|
||||||
(define (lambda-size arity)
|
(define (write-header pos low-pc high-pc offset flags nreq nopt nlocals)
|
||||||
(+ arity-header-len
|
(bytevector-u32-set! headers pos (* low-pc 4) (asm-endianness asm))
|
||||||
(* 4 ;; name pointers
|
(bytevector-u32-set! headers (+ pos 4) (* high-pc 4) (asm-endianness asm))
|
||||||
(+ (if (pair? (arity-kw-indices arity)) 1 0)
|
(bytevector-u32-set! headers (+ pos 8) offset (asm-endianness asm))
|
||||||
(length (arity-req arity))
|
(bytevector-u32-set! headers (+ pos 12) flags (asm-endianness asm))
|
||||||
(length (arity-opt arity))
|
(bytevector-u32-set! headers (+ pos 16) nreq (asm-endianness asm))
|
||||||
(if (arity-rest arity) 1 0)))))
|
(bytevector-u32-set! headers (+ pos 20) nopt (asm-endianness asm))
|
||||||
(define (case-lambda-size arities)
|
(bytevector-u32-set! headers (+ pos 24) nlocals (asm-endianness asm)))
|
||||||
(fold +
|
(define (write-kw-indices kw-indices relocs)
|
||||||
arity-header-len ;; case-lambda header
|
;; FIXME: Assert that kw-indices is already interned.
|
||||||
(map lambda-size arities))) ;; the cases
|
(if (pair? kw-indices)
|
||||||
(match (meta-arities meta)
|
(let ((pos (+ (bytevector-length headers)
|
||||||
(() 0)
|
(port-position names-port)))
|
||||||
((arity) (lambda-size arity))
|
(label (intern-constant asm kw-indices)))
|
||||||
(arities (case-lambda-size arities))))
|
(put-bytevector names-port #vu8(0 0 0 0))
|
||||||
|
(cons (make-linker-reloc 'abs32/1 pos 0 label) relocs))
|
||||||
(define (write-arity-headers metas bv endianness)
|
relocs))
|
||||||
(define (write-arity-header* pos low-pc high-pc flags nreq nopt)
|
(define (write-arity pos arity in-case-lambda? relocs)
|
||||||
(bytevector-u32-set! bv pos (* low-pc 4) endianness)
|
(write-header pos (arity-low-pc arity)
|
||||||
(bytevector-u32-set! bv (+ pos 4) (* high-pc 4) endianness)
|
(arity-high-pc arity)
|
||||||
(bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset
|
;; FIXME: Seems silly to add on bytevector-length of
|
||||||
(bytevector-u32-set! bv (+ pos 12) flags endianness)
|
;; headers, given the arities-prefix.
|
||||||
(bytevector-u32-set! bv (+ pos 16) nreq endianness)
|
(+ (bytevector-length headers) (port-position names-port))
|
||||||
(bytevector-u32-set! bv (+ pos 20) nopt endianness))
|
(pack-arity-flags (arity-rest arity)
|
||||||
(define (write-arity-header pos arity in-case-lambda?)
|
(arity-allow-other-keys? arity)
|
||||||
(write-arity-header* pos (arity-low-pc arity)
|
(pair? (arity-kw-indices arity))
|
||||||
(arity-high-pc arity)
|
#f
|
||||||
(pack-arity-flags (arity-rest arity)
|
in-case-lambda?)
|
||||||
(arity-allow-other-keys? arity)
|
(length (arity-req arity))
|
||||||
(pair? (arity-kw-indices arity))
|
(length (arity-opt arity))
|
||||||
#f
|
(length (arity-definitions arity)))
|
||||||
in-case-lambda?)
|
(let ((relocs (write-kw-indices (arity-kw-indices arity) relocs)))
|
||||||
(length (arity-req arity))
|
(let lp ((definitions (arity-definitions arity)))
|
||||||
(length (arity-opt arity))))
|
(match definitions
|
||||||
(let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
|
(() relocs)
|
||||||
|
((#(name slot def) . definitions)
|
||||||
|
(let ((sym (if (symbol? name)
|
||||||
|
(string-table-intern! strtab (symbol->string name))
|
||||||
|
0)))
|
||||||
|
(put-uleb128 names-port sym)
|
||||||
|
(lp definitions)))))))
|
||||||
|
(let lp ((metas metas) (pos arities-prefix-len) (relocs '()))
|
||||||
(match metas
|
(match metas
|
||||||
(()
|
(()
|
||||||
;; Fill in the prefix.
|
(unless (= pos (bytevector-length headers))
|
||||||
(bytevector-u32-set! bv 0 pos endianness)
|
(error "expected to fully fill the bytevector"
|
||||||
(values pos (reverse offsets)))
|
pos (bytevector-length headers)))
|
||||||
|
relocs)
|
||||||
((meta . metas)
|
((meta . metas)
|
||||||
(match (meta-arities meta)
|
(match (meta-arities meta)
|
||||||
(() (lp metas pos offsets))
|
(() (lp metas pos relocs))
|
||||||
((arity)
|
((arity)
|
||||||
(write-arity-header pos arity #f)
|
|
||||||
(lp metas
|
(lp metas
|
||||||
(+ pos arity-header-len)
|
(+ pos arity-header-len)
|
||||||
(acons arity (+ pos arity-header-offset-offset) offsets)))
|
(write-arity pos arity #f relocs)))
|
||||||
(arities
|
(arities
|
||||||
;; Write a case-lambda header, then individual arities.
|
;; Write a case-lambda header, then individual arities.
|
||||||
;; The case-lambda header's offset link is 0.
|
;; The case-lambda header's offset link is 0.
|
||||||
(write-arity-header* pos (meta-low-pc meta) (meta-high-pc meta)
|
(write-header pos (meta-low-pc meta) (meta-high-pc meta) 0
|
||||||
(pack-arity-flags #f #f #f #t #f) 0 0)
|
(pack-arity-flags #f #f #f #t #f) 0 0 0)
|
||||||
(let lp* ((arities arities) (pos (+ pos arity-header-len))
|
(let lp* ((arities arities) (pos (+ pos arity-header-len))
|
||||||
(offsets offsets))
|
(relocs relocs))
|
||||||
(match arities
|
(match arities
|
||||||
(() (lp metas pos offsets))
|
(() (lp metas pos relocs))
|
||||||
((arity . arities)
|
((arity . arities)
|
||||||
(write-arity-header pos arity #t)
|
|
||||||
(lp* arities
|
(lp* arities
|
||||||
(+ pos arity-header-len)
|
(+ pos arity-header-len)
|
||||||
(acons arity
|
(write-arity pos arity #t relocs)))))))))))
|
||||||
(+ pos arity-header-offset-offset)
|
|
||||||
offsets)))))))))))
|
|
||||||
|
|
||||||
(define (write-arity-links asm bv pos arity-offset-pairs strtab)
|
|
||||||
(define (write-symbol sym pos)
|
|
||||||
(bytevector-u32-set! bv pos
|
|
||||||
(string-table-intern! strtab (symbol->string sym))
|
|
||||||
(asm-endianness asm))
|
|
||||||
(+ pos 4))
|
|
||||||
(define (write-kw-indices pos kw-indices)
|
|
||||||
;; FIXME: Assert that kw-indices is already interned.
|
|
||||||
(make-linker-reloc 'abs32/1 pos 0
|
|
||||||
(intern-constant asm kw-indices)))
|
|
||||||
(let lp ((pos pos) (pairs arity-offset-pairs) (relocs '()))
|
|
||||||
(match pairs
|
|
||||||
(()
|
|
||||||
(unless (= pos (bytevector-length bv))
|
|
||||||
(error "expected to fully fill the bytevector"
|
|
||||||
pos (bytevector-length bv)))
|
|
||||||
relocs)
|
|
||||||
(((arity . offset) . pairs)
|
|
||||||
(bytevector-u32-set! bv offset pos (asm-endianness asm))
|
|
||||||
(call-with-values
|
|
||||||
(lambda ()
|
|
||||||
(match (arity-kw-indices arity)
|
|
||||||
(() (values pos relocs))
|
|
||||||
(kw-indices
|
|
||||||
(values (+ pos 4)
|
|
||||||
(cons (write-kw-indices pos kw-indices) relocs)))))
|
|
||||||
(lambda (pos relocs)
|
|
||||||
(lp (fold write-symbol
|
|
||||||
pos
|
|
||||||
(append (arity-req arity)
|
|
||||||
(arity-opt arity)
|
|
||||||
(cond
|
|
||||||
((arity-rest arity) => list)
|
|
||||||
(else '()))))
|
|
||||||
pairs
|
|
||||||
relocs)))))))
|
|
||||||
|
|
||||||
(define (link-arities asm)
|
(define (link-arities asm)
|
||||||
|
(define (meta-arities-header-size meta)
|
||||||
|
(define (lambda-size arity)
|
||||||
|
arity-header-len)
|
||||||
|
(define (case-lambda-size arities)
|
||||||
|
(fold +
|
||||||
|
arity-header-len ;; case-lambda header
|
||||||
|
(map lambda-size arities))) ;; the cases
|
||||||
|
(match (meta-arities meta)
|
||||||
|
(() 0)
|
||||||
|
((arity) (lambda-size arity))
|
||||||
|
(arities (case-lambda-size arities))))
|
||||||
|
|
||||||
|
(define (bytevector-append a b)
|
||||||
|
(let ((out (make-bytevector (+ (bytevector-length a)
|
||||||
|
(bytevector-length b)))))
|
||||||
|
(bytevector-copy! a 0 out 0 (bytevector-length a))
|
||||||
|
(bytevector-copy! b 0 out (bytevector-length a) (bytevector-length b))
|
||||||
|
out))
|
||||||
|
|
||||||
(let* ((endianness (asm-endianness asm))
|
(let* ((endianness (asm-endianness asm))
|
||||||
(metas (reverse (asm-meta asm)))
|
(metas (reverse (asm-meta asm)))
|
||||||
(size (fold (lambda (meta size)
|
(header-size (fold (lambda (meta size)
|
||||||
(+ size (meta-arities-size meta)))
|
(+ size (meta-arities-header-size meta)))
|
||||||
arities-prefix-len
|
arities-prefix-len
|
||||||
metas))
|
metas))
|
||||||
(strtab (make-string-table))
|
(strtab (make-string-table))
|
||||||
(bv (make-bytevector size 0)))
|
(headers (make-bytevector header-size 0)))
|
||||||
(let ((kw-indices-relocs
|
(bytevector-u32-set! headers 0 (bytevector-length headers) endianness)
|
||||||
(call-with-values
|
(let-values (((names-port get-name-bv) (open-bytevector-output-port)))
|
||||||
(lambda ()
|
(let* ((relocs (write-arities asm metas headers names-port strtab))
|
||||||
(write-arity-headers metas bv endianness))
|
(strtab (make-object asm '.guile.arities.strtab
|
||||||
(lambda (pos arity-offset-pairs)
|
(link-string-table! strtab)
|
||||||
(write-arity-links asm bv pos arity-offset-pairs strtab)))))
|
'() '()
|
||||||
(let ((strtab (make-object asm '.guile.arities.strtab
|
#:type SHT_STRTAB #:flags 0)))
|
||||||
(link-string-table! strtab)
|
|
||||||
'() '()
|
|
||||||
#:type SHT_STRTAB #:flags 0)))
|
|
||||||
(values (make-object asm '.guile.arities
|
(values (make-object asm '.guile.arities
|
||||||
bv
|
(bytevector-append headers (get-name-bv))
|
||||||
kw-indices-relocs '()
|
relocs '()
|
||||||
#:type SHT_PROGBITS #:flags 0
|
#:type SHT_PROGBITS #:flags 0
|
||||||
#:link (elf-section-index
|
#:link (elf-section-index
|
||||||
(linker-object-section strtab)))
|
(linker-object-section strtab)))
|
||||||
|
|
@ -1729,26 +1731,6 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
|
||||||
(bytevector-u64-set! bv 0 val (asm-endianness asm))
|
(bytevector-u64-set! bv 0 val (asm-endianness asm))
|
||||||
(put-bytevector port bv)))
|
(put-bytevector port bv)))
|
||||||
|
|
||||||
(define (put-uleb128 port val)
|
|
||||||
(let lp ((val val))
|
|
||||||
(let ((next (ash val -7)))
|
|
||||||
(if (zero? next)
|
|
||||||
(put-u8 port val)
|
|
||||||
(begin
|
|
||||||
(put-u8 port (logior #x80 (logand val #x7f)))
|
|
||||||
(lp next))))))
|
|
||||||
|
|
||||||
(define (put-sleb128 port val)
|
|
||||||
(let lp ((val val))
|
|
||||||
(if (<= 0 (+ val 64) 127)
|
|
||||||
(put-u8 port (logand val #x7f))
|
|
||||||
(begin
|
|
||||||
(put-u8 port (logior #x80 (logand val #x7f)))
|
|
||||||
(lp (ash val -7))))))
|
|
||||||
|
|
||||||
(define (port-position port)
|
|
||||||
(seek port 0 SEEK_CUR))
|
|
||||||
|
|
||||||
(define (meta->subprogram-die meta)
|
(define (meta->subprogram-die meta)
|
||||||
`(subprogram
|
`(subprogram
|
||||||
(@ ,@(cond
|
(@ ,@(cond
|
||||||
|
|
|
||||||
|
|
@ -31,7 +31,7 @@
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module ((srfi srfi-1) #:select (fold))
|
#:use-module ((srfi srfi-1) #:select (fold split-at))
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:export (debug-context-image
|
#:export (debug-context-image
|
||||||
debug-context-base
|
debug-context-base
|
||||||
|
|
@ -52,6 +52,7 @@
|
||||||
arity-high-pc
|
arity-high-pc
|
||||||
arity-nreq
|
arity-nreq
|
||||||
arity-nopt
|
arity-nopt
|
||||||
|
arity-nlocals
|
||||||
arity-has-rest?
|
arity-has-rest?
|
||||||
arity-allow-other-keys?
|
arity-allow-other-keys?
|
||||||
arity-has-keyword-args?
|
arity-has-keyword-args?
|
||||||
|
|
@ -246,7 +247,7 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
|
||||||
(header-offset arity-header-offset))
|
(header-offset arity-header-offset))
|
||||||
|
|
||||||
(define arities-prefix-len 4)
|
(define arities-prefix-len 4)
|
||||||
(define arity-header-len (* 6 4))
|
(define arity-header-len (* 7 4))
|
||||||
|
|
||||||
;;; struct arity_header {
|
;;; struct arity_header {
|
||||||
;;; uint32_t low_pc;
|
;;; uint32_t low_pc;
|
||||||
|
|
@ -255,6 +256,7 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
|
||||||
;;; uint32_t flags;
|
;;; uint32_t flags;
|
||||||
;;; uint32_t nreq;
|
;;; uint32_t nreq;
|
||||||
;;; uint32_t nopt;
|
;;; uint32_t nopt;
|
||||||
|
;;; uint32_t nlocals;
|
||||||
;;; }
|
;;; }
|
||||||
|
|
||||||
(define (arity-low-pc* bv header-pos)
|
(define (arity-low-pc* bv header-pos)
|
||||||
|
|
@ -269,6 +271,8 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
|
||||||
(bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
|
(bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
|
||||||
(define (arity-nopt* bv header-pos)
|
(define (arity-nopt* bv header-pos)
|
||||||
(bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
|
(bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
|
||||||
|
(define (arity-nlocals* bv header-pos)
|
||||||
|
(bytevector-u32-native-ref bv (+ header-pos (* 6 4))))
|
||||||
|
|
||||||
;;; #x1: has-rest?
|
;;; #x1: has-rest?
|
||||||
;;; #x2: allow-other-keys?
|
;;; #x2: allow-other-keys?
|
||||||
|
|
@ -304,6 +308,10 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
|
||||||
(arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
|
(arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
|
||||||
(arity-header-offset arity)))
|
(arity-header-offset arity)))
|
||||||
|
|
||||||
|
(define (arity-nlocals arity)
|
||||||
|
(arity-nlocals* (elf-bytes (debug-context-elf (arity-context arity)))
|
||||||
|
(arity-header-offset arity)))
|
||||||
|
|
||||||
(define (arity-flags arity)
|
(define (arity-flags arity)
|
||||||
(arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
|
(arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
|
||||||
(arity-header-offset arity)))
|
(arity-header-offset arity)))
|
||||||
|
|
@ -314,6 +322,18 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
|
||||||
(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
|
(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
|
||||||
(define (arity-is-in-case-lambda? arity) (is-in-case-lambda? (arity-flags arity)))
|
(define (arity-is-in-case-lambda? arity) (is-in-case-lambda? (arity-flags arity)))
|
||||||
|
|
||||||
|
(define (arity-keyword-args arity)
|
||||||
|
(define (unpack-scm n)
|
||||||
|
(pointer->scm (make-pointer n)))
|
||||||
|
(if (arity-has-keyword-args? arity)
|
||||||
|
(let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
|
||||||
|
(header (arity-header-offset arity))
|
||||||
|
(link-offset (arity-offset* bv header))
|
||||||
|
(link (+ (arity-base arity) link-offset))
|
||||||
|
(offset (bytevector-u32-native-ref bv link)))
|
||||||
|
(unpack-scm (+ (debug-context-base (arity-context arity)) offset)))
|
||||||
|
'()))
|
||||||
|
|
||||||
(define (arity-load-symbol arity)
|
(define (arity-load-symbol arity)
|
||||||
(let ((elf (debug-context-elf (arity-context arity))))
|
(let ((elf (debug-context-elf (arity-context arity))))
|
||||||
(cond
|
(cond
|
||||||
|
|
@ -327,43 +347,70 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
|
||||||
(string->symbol (string-table-ref bv (+ strtab-offset n)))))))
|
(string->symbol (string-table-ref bv (+ strtab-offset n)))))))
|
||||||
(else (error "couldn't find arities section")))))
|
(else (error "couldn't find arities section")))))
|
||||||
|
|
||||||
(define (arity-keyword-args arity)
|
(define* (arity-locals arity #:optional nlocals)
|
||||||
(define (unpack-scm n)
|
|
||||||
(pointer->scm (make-pointer n)))
|
|
||||||
(if (arity-has-keyword-args? arity)
|
|
||||||
(let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
|
|
||||||
(header (arity-header-offset arity))
|
|
||||||
(link-offset (arity-offset* bv header))
|
|
||||||
(link (+ (arity-base arity) link-offset))
|
|
||||||
(offset (bytevector-u32-native-ref bv link)))
|
|
||||||
(unpack-scm (+ (debug-context-base (arity-context arity)) offset)))
|
|
||||||
'()))
|
|
||||||
|
|
||||||
(define (arity-arguments-alist arity)
|
|
||||||
(let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
|
(let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
|
||||||
(%load-symbol (arity-load-symbol arity))
|
(load-symbol (arity-load-symbol arity))
|
||||||
(header (arity-header-offset arity))
|
(header (arity-header-offset arity))
|
||||||
|
(nlocals (if nlocals
|
||||||
|
(if (<= 0 nlocals (arity-nlocals* bv header))
|
||||||
|
nlocals
|
||||||
|
(error "request for too many locals"))
|
||||||
|
(arity-nlocals* bv header)))
|
||||||
(flags (arity-flags* bv header))
|
(flags (arity-flags* bv header))
|
||||||
(nreq (arity-nreq* bv header))
|
|
||||||
(nopt (arity-nopt* bv header))
|
|
||||||
(link-offset (arity-offset* bv header))
|
(link-offset (arity-offset* bv header))
|
||||||
(link (+ (arity-base arity)
|
(link (+ (arity-base arity)
|
||||||
link-offset
|
link-offset
|
||||||
(if (has-keyword-args? flags) 4 0))))
|
(if (has-keyword-args? flags) 4 0))))
|
||||||
(define (load-symbol idx)
|
(define (read-uleb128 bv pos)
|
||||||
(%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
|
;; Unrolled by one.
|
||||||
(define (load-symbols skip n)
|
(let ((b (bytevector-u8-ref bv pos)))
|
||||||
(let lp ((n n) (out '()))
|
(if (zero? (logand b #x80))
|
||||||
|
(values b
|
||||||
|
(1+ pos))
|
||||||
|
(let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7))
|
||||||
|
(let ((b (bytevector-u8-ref bv pos)))
|
||||||
|
(if (zero? (logand b #x80))
|
||||||
|
(values (logior (ash b shift) n)
|
||||||
|
(1+ pos))
|
||||||
|
(lp (logior (ash (logxor #x80 b) shift) n)
|
||||||
|
(1+ pos)
|
||||||
|
(+ shift 7))))))))
|
||||||
|
(define (load-symbols pos n)
|
||||||
|
(let lp ((pos pos) (n n) (out '()))
|
||||||
(if (zero? n)
|
(if (zero? n)
|
||||||
out
|
(reverse out)
|
||||||
(lp (1- n)
|
(call-with-values (lambda () (read-uleb128 bv pos))
|
||||||
(cons (load-symbol (+ skip (1- n))) out)))))
|
(lambda (strtab-offset pos)
|
||||||
(and (not (is-case-lambda? flags))
|
strtab-offset
|
||||||
`((required . ,(load-symbols 0 nreq))
|
(lp pos
|
||||||
(optional . ,(load-symbols nreq nopt))
|
(1- n)
|
||||||
(keyword . ,(arity-keyword-args arity))
|
(cons (if (zero? strtab-offset)
|
||||||
(allow-other-keys? . ,(allow-other-keys? flags))
|
#f
|
||||||
(rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))))))
|
(load-symbol strtab-offset))
|
||||||
|
out)))))))
|
||||||
|
(when (is-case-lambda? flags)
|
||||||
|
(error "invalid request for locals of case-lambda wrapper arity"))
|
||||||
|
(load-symbols link nlocals)))
|
||||||
|
|
||||||
|
(define (arity-arguments-alist arity)
|
||||||
|
(let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
|
||||||
|
(header (arity-header-offset arity))
|
||||||
|
(flags (arity-flags* bv header))
|
||||||
|
(nreq (arity-nreq* bv header))
|
||||||
|
(nopt (arity-nopt* bv header))
|
||||||
|
(nargs (+ nreq nopt (if (has-rest? flags) 1 0))))
|
||||||
|
(when (is-case-lambda? flags)
|
||||||
|
(error "invalid request for locals of case-lambda wrapper arity"))
|
||||||
|
(let ((args (arity-locals arity nargs)))
|
||||||
|
(call-with-values (lambda () (split-at args nreq))
|
||||||
|
(lambda (req args)
|
||||||
|
(call-with-values (lambda () (split-at args nopt))
|
||||||
|
(lambda (opt args)
|
||||||
|
`((required . ,req)
|
||||||
|
(optional . ,opt)
|
||||||
|
(keyword . ,(arity-keyword-args arity))
|
||||||
|
(allow-other-keys? . ,(allow-other-keys? flags))
|
||||||
|
(rest . ,(and (has-rest? flags) (car args)))))))))))
|
||||||
|
|
||||||
(define (find-first-arity context base addr)
|
(define (find-first-arity context base addr)
|
||||||
(let* ((bv (elf-bytes (debug-context-elf context)))
|
(let* ((bv (elf-bytes (debug-context-elf context)))
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue