summaryrefslogtreecommitdiff
path: root/module/system/vm/debug.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-05-17 22:10:16 +0200
committerAndy Wingo <wingo@pobox.com>2013-06-09 23:59:19 +0200
commitc4c098e355bd2edcd3bc66eb7041c5f9cdeefef0 (patch)
treec1a55d1fc2dbe44b4201e3eaa076561e20d6fa05 /module/system/vm/debug.scm
parentbf8328ec16cbe76b7af9703bb41e964865034561 (diff)
downloadguile-c4c098e355bd2edcd3bc66eb7041c5f9cdeefef0.tar.gz
procedure-properties for RTL functions
* module/system/vm/assembler.scm (link-procprops, link-objects): Arrange to write procedure property links out to a separate section. * libguile/procprop.c (scm_procedure_properties): * libguile/programs.h: * libguile/programs.c (scm_i_rtl_program_properties): * module/system/vm/debug.scm (find-program-properties): Wire up procedure-properties for RTL procedures. Yeah! Fistpumps! :) * module/system/vm/debug.scm (find-program-debug-info): Return #f if the string is "", as it is if we don't have a name. Perhaps elf-symbol-name should return #f in that case... * test-suite/tests/rtl.test: Add some tests.
Diffstat (limited to 'module/system/vm/debug.scm')
-rw-r--r--module/system/vm/debug.scm45
1 files changed, 44 insertions, 1 deletions
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index cee0892c7..c70f7c5b1 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -58,7 +58,9 @@
find-program-arities
program-minimum-arity
- find-program-docstring))
+ find-program-docstring
+
+ find-program-properties))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.
@@ -364,3 +366,44 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(elf-section-link sec)))
(idx (bytevector-u32-native-ref bv (+ pos 4))))
(string-table-ref bv (+ (elf-section-offset strtab) idx))))))))))
+
+(define* (find-program-properties addr #:optional
+ (context (find-debug-context addr)))
+ (define (add-name-and-docstring props)
+ (define (maybe-acons k v tail)
+ (if v (acons k v tail) tail))
+ (let ((name (and=> (find-program-debug-info addr context)
+ program-debug-info-name))
+ (docstring (find-program-docstring addr context)))
+ (maybe-acons 'name name
+ (maybe-acons 'documentation docstring props))))
+ (add-name-and-docstring
+ (cond
+ ((elf-section-by-name (debug-context-elf context) ".guile.procprops")
+ => (lambda (sec)
+ ;; struct procprop {
+ ;; uint32_t pc;
+ ;; uint32_t offset;
+ ;; }
+ (define procprop-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))))
+ (define (unpack-scm addr)
+ (pointer->scm (make-pointer addr)))
+ (define (load-non-immediate offset)
+ (unpack-scm (+ (debug-context-base context) offset)))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos start))
+ (cond
+ ((>= pos end) '())
+ ((< text-offset (bytevector-u32-native-ref bv pos))
+ (lp (+ pos procprop-len)))
+ ((> text-offset (bytevector-u32-native-ref bv pos))
+ '())
+ (else
+ (load-non-immediate
+ (bytevector-u32-native-ref bv (+ pos 4))))))))))))