diff options
author | Andy Wingo <wingo@pobox.com> | 2014-04-15 22:24:48 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-04-15 22:24:48 +0200 |
commit | f9425c8000076e3d3d69f70b8a57e03eb9251f23 (patch) | |
tree | 9f628d0be6e5f188f4b93f119a75048f4fb75e72 /module/system/vm/debug.scm | |
parent | 4cbe4d72aab9723d57b9cd779fc99e76b545802e (diff) | |
download | guile-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.scm | 53 |
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)) |