Add ability to query local definitions for a procedure

* module/system/vm/debug.scm (arity-definitions): New interface.

* module/system/vm/program.scm (make-binding, binding:boxed?)
  (binding:index, binding:start, binding:end): Remove.
  (binding:definition-offset, binding:slot): Add.
  (program-arity-bindings-for-ip): Rename from program-bindings-for-ip,
  as it gives all definitions in an arity.  The user will have to do
  data-flow analysis to recover the set of variables that are actually
  available at any given point.
  (arity->arguments-alist): Remove crufty code.

module/system/vm/debug.scm

@@ -58,6 +58,7 @@
             arity-has-keyword-args?
             arity-keyword-args
             arity-is-case-lambda?
+            arity-definitions
 
             debug-context-from-image
             fold-all-debug-contexts
@@ -347,6 +348,58 @@ 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-definitions arity)
+  (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+         (load-symbol (arity-load-symbol arity))
+         (header (arity-header-offset arity))
+         (nlocals (arity-nlocals* bv header))
+         (flags (arity-flags* bv header))
+         (link-offset (arity-offset* bv header))
+         (link (+ (arity-base arity)
+                  link-offset
+                  (if (has-keyword-args? flags) 4 0))))
+    (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-definitions pos names)
+      (let lp ((pos pos) (names names))
+        (match names
+          (() '())
+          ((name . names)
+           (call-with-values (lambda () (read-uleb128 bv pos))
+             (lambda (def-offset pos)
+               (call-with-values (lambda () (read-uleb128 bv pos))
+                 (lambda (slot pos)
+                   (cons (vector name def-offset slot)
+                         (lp pos names))))))))))
+    (define (load-symbols pos)
+      (let lp ((pos pos) (n nlocals) (out '()))
+        (if (zero? n)
+            (load-definitions pos (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 definitions of case-lambda wrapper arity"))
+    (load-symbols link)))
+
 (define* (arity-locals arity #:optional nlocals)
   (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
          (load-symbol (arity-load-symbol arity))

module/system/vm/program.scm

@@ -24,15 +24,13 @@
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
-  #:export (make-binding binding:name binding:boxed? binding:index
-            binding:start binding:end
+  #:export (binding:name binding:definition-offset binding:slot
+            program-arity-bindings-for-ip
 
             source:addr source:line source:column source:file
             source:line-for-user
             program-sources program-sources-pre-retire program-source
 
-            program-bindings-for-ip
-
             program-arities program-arity arity:start arity:end
 
             arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
@@ -61,13 +59,11 @@
 (define (program-properties program)
   (find-program-properties (program-code program)))
 
-(define (make-binding name boxed? index start end)
-  (list name boxed? index start end))
-(define (binding:name b) (list-ref b 0))
-(define (binding:boxed? b) (list-ref b 1))
-(define (binding:index b) (list-ref b 2))
-(define (binding:start b) (list-ref b 3))
-(define (binding:end b) (list-ref b 4))
+(define (make-binding name def-offset slot)
+  (vector name def-offset slot))
+(define (binding:name b) (vector-ref b 0))
+(define (binding:definition-offset b) (vector-ref b 1))
+(define (binding:slot b) (vector-ref b 2))
 
 (define (source:addr source)
   (car source))
@@ -128,39 +124,12 @@
                 (source-column source)))
        (find-program-sources (program-code proc))))
 
-(define (collapse-locals locs)
-  (let lp ((ret '()) (locs locs))
-    (if (null? locs)
-        (map cdr (sort! ret 
-                        (lambda (x y) (< (car x) (car y)))))
-        (let ((b (car locs)))
-          (cond
-           ((assv-ref ret (binding:index b))
-            => (lambda (bindings)
-                 (append! bindings (list b))
-                 (lp ret (cdr locs))))
-           (else
-            (lp (acons (binding:index b) (list b) ret)
-                (cdr locs))))))))
-
-;; returns list of list of bindings
-;; (list-ref ret N) == bindings bound to the Nth local slot
-(define (program-bindings-by-index prog)
-  ;; FIXME!
-  '())
-
-(define (program-bindings-for-ip prog ip)
-  (let lp ((in (program-bindings-by-index prog)) (out '()))
-    (if (null? in)
-        (reverse out)
-        (lp (cdr in)
-            (let inner ((binds (car in)))
-              (cond ((null? binds) out)
-                    ((<= (binding:start (car binds))
-                         ip
-                         (binding:end (car binds)))
-                     (cons (car binds) out))
-                    (else (inner (cdr binds)))))))))
+(define (program-arity-bindings-for-ip prog ip)
+  (or-map (lambda (arity)
+            (and (<= (arity-low-pc arity) ip)
+                 (< ip (arity-high-pc arity))
+                 (arity-definitions arity)))
+          (or (find-program-arities (program-code prog)) '())))
 
 (define (arity:start a)
   (match a ((start end . _) start) (_ (error "bad arity" a))))
@@ -203,31 +172,21 @@
                                  #:optional
                                  (make-placeholder
                                   (lambda (i) (string->symbol "_"))))
-  (define var-by-index
-    (let ((rbinds (map (lambda (x)
-                         (cons (binding:index x) (binding:name x)))
-                       (program-bindings-for-ip prog
-                                                (arity:start arity)))))
-      (lambda (i)
-        (or (assv-ref rbinds i)
-            ;; if we don't know the name, return a placeholder
-            (make-placeholder i)))))
-
   (let lp ((nreq (arity:nreq arity)) (req '())
            (nopt (arity:nopt arity)) (opt '())
            (rest? (arity:rest? arity)) (rest #f)
            (n 0))
     (cond
      ((< 0 nreq)
-      (lp (1- nreq) (cons (var-by-index n) req)
+      (lp (1- nreq) (cons (make-placeholder n) req)
           nopt opt rest? rest (1+ n)))
      ((< 0 nopt)
       (lp nreq req
-          (1- nopt) (cons (var-by-index n) opt)
+          (1- nopt) (cons (make-placeholder n) opt)
           rest? rest (1+ n)))
      (rest?
       (lp nreq req nopt opt
-          #f (var-by-index (+ n (length (arity:kw arity))))
+          #f (make-placeholder (+ n (length (arity:kw arity))))
           (1+ n)))
      (else
       `((required . ,(reverse req))