diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 79a255160..5677b312a 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1399,6 +1399,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If ;;; uint32_t flags; ;;; uint32_t nreq; ;;; uint32_t nopt; +;;; uint32_t nlocals; ;;; } ;;; ;;; 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 ;;; the flags -- the first uint32 pointed to by offset encodes a link to -;;; the "keyword indices" literal, in the data section. Then follow -;;; links for required arguments are first, in order, as uint32 values. -;;; Next follow the optionals, then the rest link if has-rest? is set. -;;; Unlike the other links, the kw-indices link points into the data -;;; section, and is relative to the ELF image as a whole. +;;; the "keyword indices" literal, in the data section. Then follow the +;;; names for all locals, in order, as uleb128 values. The required +;;; arguments will be the first locals, followed by the optionals, +;;; followed by the rest argument if if has-rest? is set. The names +;;; point into the associated string table section. ;;; ;;; Functions with no arities have no arities information present in the ;;; .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) ;; 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. -(define arity-header-offset-offset (* 2 4)) +;; Some helpers. +(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? 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-in-case-lambda? (ash 1 4) 0))) -(define (meta-arities-size meta) - (define (lambda-size arity) - (+ arity-header-len - (* 4 ;; name pointers - (+ (if (pair? (arity-kw-indices arity)) 1 0) - (length (arity-req arity)) - (length (arity-opt arity)) - (if (arity-rest arity) 1 0))))) - (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 (write-arity-headers metas bv endianness) - (define (write-arity-header* pos low-pc high-pc flags nreq nopt) - (bytevector-u32-set! bv pos (* low-pc 4) endianness) - (bytevector-u32-set! bv (+ pos 4) (* high-pc 4) endianness) - (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset - (bytevector-u32-set! bv (+ pos 12) flags endianness) - (bytevector-u32-set! bv (+ pos 16) nreq endianness) - (bytevector-u32-set! bv (+ pos 20) nopt endianness)) - (define (write-arity-header pos arity in-case-lambda?) - (write-arity-header* pos (arity-low-pc arity) - (arity-high-pc arity) - (pack-arity-flags (arity-rest arity) - (arity-allow-other-keys? arity) - (pair? (arity-kw-indices arity)) - #f - in-case-lambda?) - (length (arity-req arity)) - (length (arity-opt arity)))) - (let lp ((metas metas) (pos arities-prefix-len) (offsets '())) +(define (write-arities asm metas headers names-port strtab) + (define (write-header pos low-pc high-pc offset flags nreq nopt nlocals) + (bytevector-u32-set! headers pos (* low-pc 4) (asm-endianness asm)) + (bytevector-u32-set! headers (+ pos 4) (* high-pc 4) (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 16) nreq (asm-endianness asm)) + (bytevector-u32-set! headers (+ pos 20) nopt (asm-endianness asm)) + (bytevector-u32-set! headers (+ pos 24) nlocals (asm-endianness asm))) + (define (write-kw-indices kw-indices relocs) + ;; FIXME: Assert that kw-indices is already interned. + (if (pair? kw-indices) + (let ((pos (+ (bytevector-length headers) + (port-position names-port))) + (label (intern-constant asm kw-indices))) + (put-bytevector names-port #vu8(0 0 0 0)) + (cons (make-linker-reloc 'abs32/1 pos 0 label) relocs)) + relocs)) + (define (write-arity pos arity in-case-lambda? relocs) + (write-header pos (arity-low-pc arity) + (arity-high-pc arity) + ;; FIXME: Seems silly to add on bytevector-length of + ;; headers, given the arities-prefix. + (+ (bytevector-length headers) (port-position names-port)) + (pack-arity-flags (arity-rest arity) + (arity-allow-other-keys? arity) + (pair? (arity-kw-indices arity)) + #f + in-case-lambda?) + (length (arity-req arity)) + (length (arity-opt arity)) + (length (arity-definitions arity))) + (let ((relocs (write-kw-indices (arity-kw-indices arity) relocs))) + (let lp ((definitions (arity-definitions arity))) + (match definitions + (() 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 (() - ;; Fill in the prefix. - (bytevector-u32-set! bv 0 pos endianness) - (values pos (reverse offsets))) + (unless (= pos (bytevector-length headers)) + (error "expected to fully fill the bytevector" + pos (bytevector-length headers))) + relocs) ((meta . metas) (match (meta-arities meta) - (() (lp metas pos offsets)) + (() (lp metas pos relocs)) ((arity) - (write-arity-header pos arity #f) (lp metas (+ pos arity-header-len) - (acons arity (+ pos arity-header-offset-offset) offsets))) + (write-arity pos arity #f relocs))) (arities ;; Write a case-lambda header, then individual arities. ;; The case-lambda header's offset link is 0. - (write-arity-header* pos (meta-low-pc meta) (meta-high-pc meta) - (pack-arity-flags #f #f #f #t #f) 0 0) + (write-header pos (meta-low-pc meta) (meta-high-pc meta) 0 + (pack-arity-flags #f #f #f #t #f) 0 0 0) (let lp* ((arities arities) (pos (+ pos arity-header-len)) - (offsets offsets)) + (relocs relocs)) (match arities - (() (lp metas pos offsets)) + (() (lp metas pos relocs)) ((arity . arities) - (write-arity-header pos arity #t) (lp* arities (+ pos arity-header-len) - (acons arity - (+ 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))))))) + (write-arity pos arity #t relocs))))))))))) (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)) (metas (reverse (asm-meta asm))) - (size (fold (lambda (meta size) - (+ size (meta-arities-size meta))) - arities-prefix-len - metas)) + (header-size (fold (lambda (meta size) + (+ size (meta-arities-header-size meta))) + arities-prefix-len + metas)) (strtab (make-string-table)) - (bv (make-bytevector size 0))) - (let ((kw-indices-relocs - (call-with-values - (lambda () - (write-arity-headers metas bv endianness)) - (lambda (pos arity-offset-pairs) - (write-arity-links asm bv pos arity-offset-pairs strtab))))) - (let ((strtab (make-object asm '.guile.arities.strtab - (link-string-table! strtab) - '() '() - #:type SHT_STRTAB #:flags 0))) + (headers (make-bytevector header-size 0))) + (bytevector-u32-set! headers 0 (bytevector-length headers) endianness) + (let-values (((names-port get-name-bv) (open-bytevector-output-port))) + (let* ((relocs (write-arities asm metas headers names-port strtab)) + (strtab (make-object asm '.guile.arities.strtab + (link-string-table! strtab) + '() '() + #:type SHT_STRTAB #:flags 0))) (values (make-object asm '.guile.arities - bv - kw-indices-relocs '() + (bytevector-append headers (get-name-bv)) + relocs '() #:type SHT_PROGBITS #:flags 0 #:link (elf-section-index (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)) (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) `(subprogram (@ ,@(cond diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 2259954e8..ac2041c0d 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -31,7 +31,7 @@ #:use-module (system foreign) #:use-module (rnrs bytevectors) #: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) #:export (debug-context-image debug-context-base @@ -52,6 +52,7 @@ arity-high-pc arity-nreq arity-nopt + arity-nlocals arity-has-rest? arity-allow-other-keys? 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)) (define arities-prefix-len 4) -(define arity-header-len (* 6 4)) +(define arity-header-len (* 7 4)) ;;; struct arity_header { ;;; 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 nreq; ;;; uint32_t nopt; +;;; uint32_t nlocals; ;;; } (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)))) (define (arity-nopt* bv header-pos) (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? ;;; #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-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) (arity-flags* (elf-bytes (debug-context-elf (arity-context 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-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) (let ((elf (debug-context-elf (arity-context arity)))) (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))))))) (else (error "couldn't find arities section"))))) -(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-arguments-alist arity) +(define* (arity-locals arity #:optional nlocals) (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)) + (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)) - (nreq (arity-nreq* bv header)) - (nopt (arity-nopt* bv header)) (link-offset (arity-offset* bv header)) (link (+ (arity-base arity) link-offset (if (has-keyword-args? flags) 4 0)))) - (define (load-symbol idx) - (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4))))) - (define (load-symbols skip n) - (let lp ((n n) (out '())) + (define (read-uleb128 bv pos) + ;; Unrolled by one. + (let ((b (bytevector-u8-ref bv pos))) + (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) - out - (lp (1- n) - (cons (load-symbol (+ skip (1- n))) out))))) - (and (not (is-case-lambda? flags)) - `((required . ,(load-symbols 0 nreq)) - (optional . ,(load-symbols nreq nopt)) - (keyword . ,(arity-keyword-args arity)) - (allow-other-keys? . ,(allow-other-keys? flags)) - (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt)))))))) + (reverse out) + (call-with-values (lambda () (read-uleb128 bv pos)) + (lambda (strtab-offset pos) + strtab-offset + (lp pos + (1- n) + (cons (if (zero? strtab-offset) + #f + (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) (let* ((bv (elf-bytes (debug-context-elf context)))