summaryrefslogtreecommitdiff
path: root/module
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
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')
-rw-r--r--module/system/vm/debug.scm53
-rw-r--r--module/system/vm/program.scm73
2 files changed, 69 insertions, 57 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))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index b065110c3..3ac73c43c 100644
--- a/module/system/vm/program.scm
+++ b/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))