mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

Add arity-code

Browse source 
* module/system/vm/debug.scm (arity-code): New interface.
This commit is contained in:
Andy Wingo 2014-04-16 12:58:35 +02:00
parent 20d7d68284
commit bc5bcf6637
1 changed files with 12 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

12
module/system/vm/debug.scm
View file

@ -59,6 +59,7 @@
arity-keyword-args arity-keyword-args
arity-is-case-lambda? arity-is-case-lambda?
arity-definitions arity-definitions
arity-code
debug-context-from-image debug-context-from-image
fold-all-debug-contexts fold-all-debug-contexts
@ -400,6 +401,17 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(error "invalid request for definitions of case-lambda wrapper arity")) (error "invalid request for definitions of case-lambda wrapper arity"))
(load-symbols link))) (load-symbols link)))
(define (arity-code arity)
(let* ((ctx (arity-context arity))
(bv (elf-bytes (debug-context-elf ctx)))
(header (arity-header-offset arity))
(base-addr (+ (debug-context-base ctx) (debug-context-text-base ctx)))
(low-pc (+ base-addr (arity-low-pc* bv header)))
(high-pc (+ base-addr (arity-high-pc* bv header))))
;; FIXME: We should be able to use a sub-bytevector operation here;
;; it would be safer.
(pointer->bytevector (make-pointer low-pc) (- high-pc low-pc))))
(define* (arity-locals arity #:optional nlocals) (define* (arity-locals arity #:optional nlocals)
(let* ((bv (elf-bytes (debug-context-elf (arity-context arity)))) (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
(load-symbol (arity-load-symbol arity)) (load-symbol (arity-load-symbol arity))