summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/frames.c8
-rw-r--r--module/system/vm/debug.scm93
-rw-r--r--module/system/vm/frame.scm6
-rw-r--r--module/system/vm/program.scm13
4 files changed, 70 insertions, 50 deletions
diff --git a/libguile/frames.c b/libguile/frames.c
index 8ce5aa0b0..448a0cbbe 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -110,7 +110,7 @@ SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
proc = scm_frame_procedure (frame);
- if (SCM_PROGRAM_P (proc))
+ if (SCM_PROGRAM_P (proc) || SCM_RTL_PROGRAM_P (proc))
return scm_program_source (scm_frame_procedure (frame),
scm_frame_instruction_pointer (frame),
SCM_UNDEFINED);
@@ -260,6 +260,10 @@ SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
SCM_VALIDATE_VM_FRAME (1, frame);
program = scm_frame_procedure (frame);
+ if (SCM_RTL_PROGRAM_P (program))
+ return scm_from_ptrdiff_t (SCM_VM_FRAME_IP (frame) -
+ (scm_t_uint8 *) SCM_RTL_PROGRAM_CODE (program));
+
if (!SCM_PROGRAM_P (program))
return SCM_INUM0;
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 6142f3d1b..f7adb20a3 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -155,8 +155,11 @@ offset from the beginning of the ELF image in 32-bit units."
(define (find-debug-context addr)
"Find and return the debugging context corresponding to the ELF image
-containing the address @var{addr}. @var{addr} is an integer."
- (debug-context-from-image (find-mapped-elf-image addr)))
+containing the address @var{addr}. @var{addr} is an integer. If no ELF
+image is found, return @code{#f}. It's possible for an RTL program not
+to have an ELF image if the program was defined in as a stub in C."
+ (and=> (find-mapped-elf-image addr)
+ debug-context-from-image))
(define (find-elf-symbol elf text-offset)
"Search the symbol table of @var{elf} for the ELF symbol containing
@@ -189,10 +192,11 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
"Find and return the @code{<program-debug-info>} containing
@var{addr}, or @code{#f}."
(cond
- ((find-elf-symbol (debug-context-elf context)
- (- addr
- (debug-context-base context)
- (debug-context-text-base context)))
+ ((and context
+ (find-elf-symbol (debug-context-elf context)
+ (- addr
+ (debug-context-base context)
+ (debug-context-text-base context))))
=> (lambda (sym)
(make-program-debug-info context
(and=> (elf-symbol-name sym)
@@ -343,7 +347,8 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(define* (find-program-arities addr #:optional
(context (find-debug-context addr)))
(and=>
- (elf-section-by-name (debug-context-elf context) ".guile.arities")
+ (and context
+ (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)))
@@ -357,7 +362,8 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(define* (program-minimum-arity addr #:optional
(context (find-debug-context addr)))
(and=>
- (elf-section-by-name (debug-context-elf context) ".guile.arities")
+ (and context
+ (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)))
@@ -370,7 +376,8 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(define* (find-program-docstring addr #:optional
(context (find-debug-context addr)))
(and=>
- (elf-section-by-name (debug-context-elf context) ".guile.docstrs")
+ (and context
+ (elf-section-by-name (debug-context-elf context) ".guile.docstrs"))
(lambda (sec)
;; struct docstr {
;; uint32_t pc;
@@ -409,7 +416,8 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(maybe-acons 'documentation docstring props))))
(add-name-and-docstring
(cond
- ((elf-section-by-name (debug-context-elf context) ".guile.procprops")
+ ((and context
+ (elf-section-by-name (debug-context-elf context) ".guile.procprops"))
=> (lambda (sec)
;; struct procprop {
;; uint32_t pc;
@@ -466,12 +474,13 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(define* (find-source-for-addr addr #:optional
(context (find-debug-context addr))
#:key exact?)
- (let* ((base (debug-context-base context))
- (pc (- addr base)))
- (and=>
- (false-if-exception
- (elf->dwarf-context (debug-context-elf context)))
- (lambda (dwarf-ctx)
+ (and=>
+ (and context
+ (false-if-exception
+ (elf->dwarf-context (debug-context-elf context))))
+ (lambda (dwarf-ctx)
+ (let* ((base (debug-context-base context))
+ (pc (- addr base)))
(or-map (lambda (die)
(and=>
(die-line-prog die)
@@ -486,34 +495,36 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(define* (find-program-die addr #:optional
(context (find-debug-context addr)))
- (and=> (false-if-exception
- (elf->dwarf-context (debug-context-elf context)))
+ (and=> (and context
+ (false-if-exception
+ (elf->dwarf-context (debug-context-elf context))))
(lambda (dwarf-ctx)
(find-die-by-pc (read-die-roots dwarf-ctx)
(- addr (debug-context-base context))))))
(define* (find-program-sources addr #:optional
(context (find-debug-context addr)))
- (and=>
- (find-program-die addr context)
- (lambda (die)
- (let* ((base (debug-context-base context))
- (low-pc (die-ref die 'low-pc))
- (high-pc (die-high-pc die))
- (prog (let line-prog ((die die))
- (and die
- (or (die-line-prog die)
- (line-prog (ctx-die (die-ctx die))))))))
- (cond
- ((and low-pc high-pc prog)
- (let lp ((sources '()))
- (call-with-values (lambda ()
- (if (null? sources)
- (line-prog-scan-to-pc prog low-pc)
- (line-prog-advance prog)))
- (lambda (pc file line col)
- (if (and pc (< pc high-pc))
- (lp (cons (make-source/dwarf (+ pc base) file line col)
- sources))
- (reverse sources))))))
- (else '()))))))
+ (cond
+ ((find-program-die addr context)
+ => (lambda (die)
+ (let* ((base (debug-context-base context))
+ (low-pc (die-ref die 'low-pc))
+ (high-pc (die-high-pc die))
+ (prog (let line-prog ((die die))
+ (and die
+ (or (die-line-prog die)
+ (line-prog (ctx-die (die-ctx die))))))))
+ (cond
+ ((and low-pc high-pc prog)
+ (let lp ((sources '()))
+ (call-with-values (lambda ()
+ (if (null? sources)
+ (line-prog-scan-to-pc prog low-pc)
+ (line-prog-advance prog)))
+ (lambda (pc file line col)
+ (if (and pc (< pc high-pc))
+ (lp (cons (make-source/dwarf (+ pc base) file line col)
+ sources))
+ (reverse sources))))))
+ (else '())))))
+ (else '())))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index b8077dba0..ea2faafd7 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,6 +1,6 @@
;;; Guile VM frame functions
-;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -73,7 +73,7 @@
(define (frame-next-source frame)
(let ((proc (frame-procedure frame)))
- (if (program? proc)
+ (if (or (program? proc) (rtl-program? proc))
(program-source proc
(frame-instruction-pointer frame)
(program-sources-pre-retire proc))
@@ -100,7 +100,7 @@
(cons
(or (false-if-exception (procedure-name p)) p)
(cond
- ((and (program? p)
+ ((and (or (program? p) (rtl-program? p))
(program-arguments-alist p (frame-instruction-pointer frame)))
;; case 1
=> (lambda (arguments)
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index fb87d970a..86db41180 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -291,9 +291,14 @@
;; the name "program-arguments" is taken by features.c...
(define* (program-arguments-alist prog #:optional ip)
"Returns the signature of the given procedure in the form of an association list."
- (let ((arity (program-arity prog ip)))
- (and arity
- (arity->arguments-alist prog arity))))
+ (if (rtl-program? prog)
+ (or-map (lambda (arity)
+ (and #t
+ (arity-arguments-alist arity)))
+ (or (find-program-arities (rtl-program-code prog)) '()))
+ (let ((arity (program-arity prog ip)))
+ (and arity
+ (arity->arguments-alist prog arity)))))
(define* (program-lambda-list prog #:optional ip)
"Returns the signature of the given procedure in the form of an argument list."
@@ -322,7 +327,7 @@
(cond
((rtl-program? prog)
(map arity-arguments-alist
- (find-program-arities (rtl-program-code prog))))
+ (or (find-program-arities (rtl-program-code prog)) '())))
((program? prog)
(map (lambda (arity) (arity->arguments-alist prog arity))
(or (program-arities prog) '())))