From f9425c8000076e3d3d69f70b8a57e03eb9251f23 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 15 Apr 2014 22:24:48 +0200 Subject: [PATCH] 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 | 53 ++++++++++++++++++++++++++ module/system/vm/program.scm | 73 ++++++++---------------------------- 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))