diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index ad7eb2376..79a255160 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1419,12 +1419,15 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If ;;; is-case-lambda? flag set. Their "offset" member links to an array ;;; of pointers into the associated .guile.arities.strtab string table, ;;; identifying the argument names. This offset is relative to the -;;; start of the .guile.arities section. Links for required arguments -;;; are first, in order, as uint32 values. Next follow the optionals, -;;; then the rest link if has-rest? is set, then a link to the "keyword -;;; indices" literal if has-keyword-args? 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. +;;; start of the .guile.arities section. +;;; +;;; 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. ;;; ;;; Functions with no arities have no arities information present in the ;;; .guile.arities section. @@ -1459,10 +1462,10 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (define (lambda-size arity) (+ arity-header-len (* 4 ;; name pointers - (+ (length (arity-req arity)) + (+ (if (pair? (arity-kw-indices arity)) 1 0) + (length (arity-req arity)) (length (arity-opt arity)) - (if (arity-rest arity) 1 0) - (if (pair? (arity-kw-indices arity)) 1 0))))) + (if (arity-rest arity) 1 0))))) (define (case-lambda-size arities) (fold + arity-header-len ;; case-lambda header @@ -1540,19 +1543,23 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If relocs) (((arity . offset) . pairs) (bytevector-u32-set! bv offset pos (asm-endianness asm)) - (let ((pos (fold write-symbol - pos - (append (arity-req arity) - (arity-opt arity) - (cond - ((arity-rest arity) => list) - (else '())))))) - (match (arity-kw-indices arity) - (() (lp pos pairs relocs)) - (kw-indices - (lp (+ pos 4) - pairs - (cons (write-kw-indices pos kw-indices) relocs))))))))) + (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) (let* ((endianness (asm-endianness asm)) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 6f2edc3a6..2259954e8 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -328,33 +328,28 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}." (else (error "couldn't find arities section"))))) (define (arity-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)) - (flags (arity-flags* bv header)) - (nreq (arity-nreq* bv header)) - (nopt (arity-nopt* bv header))) - (define (unpack-scm n) - (pointer->scm (make-pointer n))) - (define (load-non-immediate idx) - (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4))))) - (unpack-scm (+ (debug-context-base (arity-context arity)) offset)))) - (if (and (not (is-case-lambda? flags)) - (has-keyword-args? flags)) - (load-non-immediate - (+ nreq nopt (if (has-rest? flags) 1 0))) - '()))) + (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)))) (%load-symbol (arity-load-symbol arity)) (header (arity-header-offset arity)) - (link-offset (arity-offset* bv header)) - (link (+ (arity-base arity) link-offset)) (flags (arity-flags* bv header)) (nreq (arity-nreq* bv header)) - (nopt (arity-nopt* 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) @@ -363,18 +358,10 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}." out (lp (1- n) (cons (load-symbol (+ skip (1- n))) out))))) - (define (unpack-scm n) - (pointer->scm (make-pointer n))) - (define (load-non-immediate idx) - (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4))))) - (unpack-scm (+ (debug-context-base (arity-context arity)) offset)))) (and (not (is-case-lambda? flags)) `((required . ,(load-symbols 0 nreq)) (optional . ,(load-symbols nreq nopt)) - (keyword . ,(if (has-keyword-args? flags) - (load-non-immediate - (+ nreq nopt (if (has-rest? flags) 1 0))) - '())) + (keyword . ,(arity-keyword-args arity)) (allow-other-keys? . ,(allow-other-keys? flags)) (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))))))