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.

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
+;;; 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
 ;;; .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.
+;; 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?
                                       has-keyword-args? is-case-lambda?
@@ -1458,14 +1477,80 @@ 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 (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))
+    (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))
-             (if (arity-rest arity) 1 0)))))
+                  (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
+      (()
+       (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 relocs))
+         ((arity)
+          (lp metas
+              (+ pos arity-header-len)
+              (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-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))
+                    (relocs relocs))
+            (match arities
+              (() (lp metas pos relocs))
+              ((arity . arities)
+               (lp* arities
+                    (+ pos arity-header-len)
+                    (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
@@ -1475,114 +1560,31 @@ procedure with label @var{rw-init}.  @var{rw-init} may be false.  If
       ((arity) (lambda-size arity))
       (arities (case-lambda-size arities))))
 
-(define (write-arity-headers metas bv endianness)
+  (define (bytevector-append a b)
-  (define (write-arity-header* pos low-pc high-pc flags nreq nopt)
+    (let ((out (make-bytevector (+ (bytevector-length a)
-    (bytevector-u32-set! bv pos (* low-pc 4) endianness)
+                                   (bytevector-length b)))))
-    (bytevector-u32-set! bv (+ pos 4) (* high-pc 4) endianness)
+      (bytevector-copy! a 0 out 0 (bytevector-length a))
-    (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset
+      (bytevector-copy! b 0 out (bytevector-length a) (bytevector-length b))
-    (bytevector-u32-set! bv (+ pos 12) flags endianness)
+      out))
-    (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 '()))
-    (match metas
-      (()
-       ;; Fill in the prefix.
-       (bytevector-u32-set! bv 0 pos endianness)
-       (values pos (reverse offsets)))
-      ((meta . metas)
-       (match (meta-arities meta)
-         (() (lp metas pos offsets))
-         ((arity)
-          (write-arity-header pos arity #f)
-          (lp metas
-              (+ pos arity-header-len)
-              (acons arity (+ pos arity-header-offset-offset) offsets)))
-         (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)
-          (let lp* ((arities arities) (pos (+ pos arity-header-len))
-                    (offsets offsets))
-            (match arities
-              (() (lp metas pos offsets))
-              ((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)))))))
-
-(define (link-arities asm)
   (let* ((endianness (asm-endianness 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
                             metas))
          (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)
-               (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)))
         (values (make-object asm '.guile.arities
-                             bv
+                             (bytevector-append headers (get-name-bv))
-                             kw-indices-relocs '()
+                             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

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* (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))))
+         (load-symbol (arity-load-symbol arity))
          (header (arity-header-offset arity))
-             (link-offset (arity-offset* bv header))
+         (nlocals (if nlocals
-             (link (+ (arity-base arity) link-offset))
+                      (if (<= 0 nlocals (arity-nlocals* bv header))
-             (offset (bytevector-u32-native-ref bv link)))
+                          nlocals
-        (unpack-scm (+ (debug-context-base (arity-context arity)) offset)))
+                          (error "request for too many locals"))
-      '()))
+                      (arity-nlocals* bv header)))
-
-(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))
          (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)
+    (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)
-            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)
+                    (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) (load-symbol (+ nreq nopt))))))))
+                (rest . ,(and (has-rest? flags) (car args)))))))))))
 
 (define (find-first-arity context base addr)
   (let* ((bv (elf-bytes (debug-context-elf context)))