(system vm debug) can read arity information

* module/system/vm/assembler.scm (write-arity-headers): Fill in the
  prefix.

* module/system/vm/debug.scm (<arity>): New object, for reading
  arities.  Unlike <arity> in the assembler, this one only holds on to a
  couple of pointers, and doesn't even load in argument names.  Unlike
  the arity lists in (system vm program), it can load in names.  Very
  early days but it does seem to work.
  (find-program-arities, arity-arguments-alist): New higher-level
  interfaces.

2 files changed, 149 insertions, 2 deletions

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 5ba9c58d4..f39491d97 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1073,7 +1073,10 @@
                          (length (arity-opt arity))))
   (let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
     (match metas
-      (() (values pos (reverse offsets)))
+      (()
+       ;; 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))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 58cb9775e..85f1d297d 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -39,8 +39,19 @@
             program-debug-info-addr
             program-debug-info-u32-offset
             program-debug-info-u32-offset-end
+            find-program-debug-info
 
-            find-program-debug-info))
+            arity?
+            arity-low-pc
+            arity-high-pc
+            arity-nreq
+            arity-nopt
+            arity-has-rest?
+            arity-allow-other-keys?
+            arity-has-keyword-args?
+            arity-is-case-lambda?
+            arity-arguments-alist
+            find-program-arities))
 
 (define-record-type <debug-context>
   (make-debug-context elf base text-base)
@@ -137,3 +148,136 @@
                                   (elf-symbol-value sym)
                                   (elf-symbol-size sym))))
    (else #f)))
+
+(define-record-type <arity>
+  (make-arity context base header-offset)
+  arity?
+  (context arity-context)
+  (base arity-base)
+  (header-offset arity-header-offset))
+
+(define arities-prefix-len 4)
+(define arity-header-len (* 6 4))
+
+;;;   struct arity_header {
+;;;     uint32_t low_pc;
+;;;     uint32_t high_pc;
+;;;     uint32_t offset;
+;;;     uint32_t flags;
+;;;     uint32_t nreq;
+;;;     uint32_t nopt;
+;;;   }
+
+(define (arity-low-pc* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 0 4))))
+(define (arity-high-pc* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 1 4))))
+(define (arity-offset* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 2 4))))
+(define (arity-flags* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 3 4))))
+(define (arity-nreq* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
+(define (arity-nopt* bv header-pos)
+  (bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
+
+;;;    #x1: has-rest?
+;;;    #x2: allow-other-keys?
+;;;    #x4: has-keyword-args?
+;;;    #x8: is-case-lambda?
+
+(define (has-rest? flags)         (not (zero? (logand flags (ash 1 0)))))
+(define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1)))))
+(define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
+(define (is-case-lambda? flags)   (not (zero? (logand flags (ash 1 3)))))
+
+(define (arity-nreq arity)
+  (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
+               (arity-header-offset arity)))
+
+(define (arity-nopt arity)
+  (arity-nopt* (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)))
+
+(define (arity-has-rest? arity) (has-rest? (arity-flags arity)))
+(define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags arity)))
+(define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags arity)))
+(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
+
+(define (arity-load-symbol arity)
+  (let ((elf (debug-context-elf (arity-context arity))))
+    (cond
+     ((elf-section-by-name elf ".guile.arities")
+      =>
+      (lambda (sec)
+        (let* ((strtab (elf-section elf (elf-section-link sec)))
+               (bv (elf-bytes elf))
+               (strtab-offset (elf-section-offset strtab)))
+          (lambda (n)
+            (string->symbol (string-table-ref bv (+ strtab-offset n)))))))
+     (else (error "couldn't find arities section")))))
+
+(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)))
+    (define (load-symbol idx)
+      (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+    (define (load-symbols skip n)
+      (let lp ((n n) (out '()))
+        (if (zero? n)
+            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))
+           (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))
+           (keyword . ,(if (has-keyword-args? flags)
+                           (load-non-immediate
+                            (+ nreq nopt (if (has-rest? flags) 1 0)))
+                           '()))
+           (allow-other-keys? . ,(allow-other-keys? flags))))))
+
+(define (find-first-arity context base addr)
+  (let* ((bv (elf-bytes (debug-context-elf context)))
+         (text-offset (- addr
+                         (debug-context-text-base context)
+                         (debug-context-base context)))
+         (headers-start (+ base arities-prefix-len))
+         (headers-end (+ base (bytevector-u32-native-ref bv base))))
+    ;; FIXME: This is linear search.  Change to binary search.
+    (let lp ((pos headers-start))
+      (cond
+       ((>= pos headers-end) #f)
+       ((< text-offset (arity-low-pc* bv pos))
+        (lp (+ pos arity-header-len)))
+       ((< (arity-high-pc* bv pos) text-offset)
+        #f)
+       (else
+        (make-arity context base pos))))))
+
+(define* (find-program-arities #:key program
+                               (addr (rtl-program-code program))
+                               (context (find-debug-context #:addr addr)))
+  (and=>
+   (elf-section-by-name (debug-context-elf context) ".guile.arities")
+   (lambda (sec)
+     (let* ((base (elf-section-offset sec))
+            (first (find-first-arity context base addr)))
+       ;; FIXME: Handle case-lambda arities.
+       (if first (list first) '())))))