Tweak arities debugging representation

* module/system/vm/assembler.scm (meta-arities-size, write-arity-links):
* module/system/vm/debug.scm (arity-keyword-args)
  (arity-arguments-alist): Rewrite to put they keyword literals link
  first.  Unfortunately requires a recompile :/

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index ad7eb23..79a2551 100644 (file)
--- 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 6f2edc3..2259954 100644 (file)
--- 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))))))))