diff options
-rw-r--r-- | libguile/frames.c | 8 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 93 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 6 | ||||
-rw-r--r-- | module/system/vm/program.scm | 13 |
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) '()))) |