summaryrefslogtreecommitdiff
path: root/module/system/vm/debug.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-05-16 18:56:22 +0200
committerAndy Wingo <wingo@pobox.com>2013-06-09 23:43:18 +0200
commitf88e574d58aa3e64b6f1ed0bc6ea918d20a67d88 (patch)
treeceb4dd84ac1a7441f5b7f7c82390bb18438327a7 /module/system/vm/debug.scm
parentb2006c19aff23f73aea0aa9fa5e211c7fa4f4df3 (diff)
downloadguile-f88e574d58aa3e64b6f1ed0bc6ea918d20a67d88.tar.gz
(system vm debug) can read arity information
* module/system/vm/debug.scm (<arity>): New object, for reading arities. Unlike <arity> in the assembler, this one only holds on to a couple of pointers, and doesn't even load in argument names. Unlike the arity lists in (system vm program), it can load in names. Very early days but it does seem to work. (find-program-arities, arity-arguments-alist): New higher-level interfaces.
Diffstat (limited to 'module/system/vm/debug.scm')
-rw-r--r--module/system/vm/debug.scm174
1 files changed, 173 insertions, 1 deletions
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 9522d622f..6f241087d 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -42,8 +42,20 @@
program-debug-info-u32-offset
program-debug-info-u32-offset-end
+ arity?
+ arity-low-pc
+ arity-high-pc
+ arity-nreq
+ arity-nopt
+ arity-has-rest?
+ arity-allow-other-keys?
+ arity-has-keyword-args?
+ arity-is-case-lambda?
+
find-debug-context
- find-program-debug-info))
+ find-program-debug-info
+ arity-arguments-alist
+ find-program-arities))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.
@@ -159,3 +171,163 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(elf-symbol-value sym)
(elf-symbol-size sym))))
(else #f)))
+
+(define-record-type <arity>
+ (make-arity context base header-offset)
+ arity?
+ (context arity-context)
+ (base arity-base)
+ (header-offset arity-header-offset))
+
+(define arities-prefix-len 4)
+(define arity-header-len (* 6 4))
+
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; }
+
+(define (arity-low-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 0 4))))
+(define (arity-high-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 1 4))))
+(define (arity-offset* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 2 4))))
+(define (arity-flags* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 3 4))))
+(define (arity-nreq* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
+(define (arity-nopt* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
+
+;;; #x1: has-rest?
+;;; #x2: allow-other-keys?
+;;; #x4: has-keyword-args?
+;;; #x8: is-case-lambda?
+
+(define (has-rest? flags) (not (zero? (logand flags (ash 1 0)))))
+(define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1)))))
+(define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
+(define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3)))))
+
+(define (arity-nreq arity)
+ (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-nopt arity)
+ (arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-flags arity)
+ (arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-has-rest? arity) (has-rest? (arity-flags arity)))
+(define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags arity)))
+(define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags arity)))
+(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
+
+(define (arity-load-symbol arity)
+ (let ((elf (debug-context-elf (arity-context arity))))
+ (cond
+ ((elf-section-by-name elf ".guile.arities")
+ =>
+ (lambda (sec)
+ (let* ((strtab (elf-section elf (elf-section-link sec)))
+ (bv (elf-bytes elf))
+ (strtab-offset (elf-section-offset strtab)))
+ (lambda (n)
+ (string->symbol (string-table-ref bv (+ strtab-offset n)))))))
+ (else (error "couldn't find arities section")))))
+
+(define (arity-arguments-alist arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (%load-symbol (arity-load-symbol arity))
+ (header (arity-header-offset arity))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity) link-offset))
+ (flags (arity-flags* bv header))
+ (nreq (arity-nreq* bv header))
+ (nopt (arity-nopt* bv header)))
+ (define (load-symbol idx)
+ (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+ (define (load-symbols skip n)
+ (let lp ((n n) (out '()))
+ (if (zero? n)
+ out
+ (lp (1- n)
+ (cons (load-symbol (+ skip (1- n))) out)))))
+ (define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+ (define (load-non-immediate idx)
+ (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+ (unpack-scm (+ (debug-context-base (arity-context arity)) offset))))
+ (and (not (is-case-lambda? flags))
+ `((required . ,(load-symbols 0 nreq))
+ (optional . ,(load-symbols nreq nopt))
+ (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))
+ (keyword . ,(if (has-keyword-args? flags)
+ (load-non-immediate
+ (+ nreq nopt (if (has-rest? flags) 1 0)))
+ '()))
+ (allow-other-keys? . ,(allow-other-keys? flags))))))
+
+(define (find-first-arity context base addr)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context)))
+ (headers-start (+ base arities-prefix-len))
+ (headers-end (+ base (bytevector-u32-native-ref bv base))))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos headers-start))
+ (cond
+ ((>= pos headers-end) #f)
+ ((< text-offset (arity-low-pc* bv pos))
+ (lp (+ pos arity-header-len)))
+ ((< (arity-high-pc* bv pos) text-offset)
+ #f)
+ (else
+ (make-arity context base pos))))))
+
+(define (read-sub-arities context base outer-header-offset)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (headers-end (+ base (bytevector-u32-native-ref bv base)))
+ (low-pc (arity-low-pc* bv outer-header-offset))
+ (high-pc (arity-high-pc* bv outer-header-offset)))
+ (let lp ((pos (+ outer-header-offset arity-header-len)) (out '()))
+ (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc))
+ (lp (+ pos arity-header-len)
+ (cons (make-arity context base pos) out))
+ (reverse out)))))
+
+(define* (find-program-arities addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.arities")
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ ;; FIXME: Handle case-lambda arities.
+ (cond
+ ((not first) '())
+ ((arity-is-case-lambda? first)
+ (read-sub-arities context base (arity-header-offset first)))
+ (else (list first)))))))
+
+(define* (program-minimum-arity addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.arities")
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ (if (arity-is-case-lambda? first)
+ (list 0 0 #t) ;; FIXME: be more precise.
+ (list (arity-nreq first)
+ (arity-nopt first)
+ (arity-has-rest? first)))))))