summaryrefslogtreecommitdiff
path: root/module/system/vm/debug.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-05-16 23:38:29 +0200
committerAndy Wingo <wingo@pobox.com>2013-06-09 23:59:01 +0200
commitbf8328ec16cbe76b7af9703bb41e964865034561 (patch)
tree53957dcaa2955689353c2cab6c8435b190fb1978 /module/system/vm/debug.scm
parent9128b1a19fe89de1aacafe5ccffd06e193f531bc (diff)
downloadguile-bf8328ec16cbe76b7af9703bb41e964865034561.tar.gz
procedure-documentation works on RTL procedures
* libguile/procprop.h: * libguile/procprop.c (scm_procedure_documentation): Move here from procs.c, and to make the logic more similar to that of procedure-name, which allows RTL programs to dispatch to rtl-program-documentation. * libguile/programs.c (scm_i_rtl_program_documentation): * libguile/programs.h: * module/system/vm/program.scm (rtl-program-documentation): New plumbing. * module/system/vm/debug.scm (find-program-docstring): New interface to grovel ELF for a docstring.
Diffstat (limited to 'module/system/vm/debug.scm')
-rw-r--r--module/system/vm/debug.scm34
1 files changed, 33 insertions, 1 deletions
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 5196ecae1..cee0892c7 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -56,7 +56,9 @@
find-program-debug-info
arity-arguments-alist
find-program-arities
- program-minimum-arity))
+ program-minimum-arity
+
+ find-program-docstring))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.
@@ -332,3 +334,33 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(list (arity-nreq first)
(arity-nopt first)
(arity-has-rest? first)))))))
+
+(define* (find-program-docstring addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (elf-section-by-name (debug-context-elf context) ".guile.docstrs")
+ (lambda (sec)
+ ;; struct docstr {
+ ;; uint32_t pc;
+ ;; uint32_t str;
+ ;; }
+ (define docstr-len 8)
+ (let* ((start (elf-section-offset sec))
+ (end (+ start (elf-section-size sec)))
+ (bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos start))
+ (cond
+ ((>= pos end) #f)
+ ((< text-offset (bytevector-u32-native-ref bv pos))
+ (lp (+ pos docstr-len)))
+ ((> text-offset (bytevector-u32-native-ref bv pos))
+ #f)
+ (else
+ (let ((strtab (elf-section (debug-context-elf context)
+ (elf-section-link sec)))
+ (idx (bytevector-u32-native-ref bv (+ pos 4))))
+ (string-table-ref bv (+ (elf-section-offset strtab) idx))))))))))