diff options
author | Andy Wingo <wingo@pobox.com> | 2013-05-16 23:38:29 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-06-09 23:59:01 +0200 |
commit | bf8328ec16cbe76b7af9703bb41e964865034561 (patch) | |
tree | 53957dcaa2955689353c2cab6c8435b190fb1978 /module/system/vm/debug.scm | |
parent | 9128b1a19fe89de1aacafe5ccffd06e193f531bc (diff) | |
download | guile-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.scm | 34 |
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)))))))))) |