summaryrefslogtreecommitdiff
path: root/module/system/vm/debug.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2014-04-15 22:24:48 +0200
committerAndy Wingo <wingo@pobox.com>2014-04-15 22:24:48 +0200
commitf9425c8000076e3d3d69f70b8a57e03eb9251f23 (patch)
tree9f628d0be6e5f188f4b93f119a75048f4fb75e72 /module/system/vm/debug.scm
parent4cbe4d72aab9723d57b9cd779fc99e76b545802e (diff)
downloadguile-f9425c8000076e3d3d69f70b8a57e03eb9251f23.tar.gz
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.
Diffstat (limited to 'module/system/vm/debug.scm')
-rw-r--r--module/system/vm/debug.scm53
1 files changed, 53 insertions, 0 deletions
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index ac2041c0d..ccd0a8d7a 100644
--- a/module/system/vm/debug.scm
+++ b/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))