better RTL debugging

* libguile/frames.c (scm_frame_source, scm_frame_instruction_pointer):
  Fix to work with RTL programs.

* module/system/vm/debug.scm (find-debug-context): Allow for the
  possibility of there being no ELF image.
  (find-program-debug-info, find-program-arities)
  (program-minimum-arity, find-program-docstring)
  (find-program-properties, find-source-for-addr)
  (find-program-die, find-program-sources): Don't bail if we couldn't
  get the debug context.

* module/system/vm/frame.scm (frame-next-source)
  (frame-call-representation): Allow RTL programs.

* module/system/vm/program.scm (program-arguments-alist): Placeholder
  implementation for RTL programs.
  (program-arguments-alists): Don't bail if we couldn't get the
  arities.

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;
 

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."
+containing the address @var{addr}.  @var{addr} is an integer.  If no ELF
-  (debug-context-from-image (find-mapped-elf-image addr)))
+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)
+   ((and context
+         (find-elf-symbol (debug-context-elf context)
                           (- addr
                              (debug-context-base context)
-                        (debug-context-text-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?)
+  (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)))
-    (and=>
-     (false-if-exception
-      (elf->dwarf-context (debug-context-elf context)))
-     (lambda (dwarf-ctx)
        (or-map (lambda (die)
                  (and=>
                   (die-line-prog die)
@@ -486,17 +495,18 @@ 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
+  (and=> (and context
-          (elf->dwarf-context (debug-context-elf 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=>
+  (cond
-   (find-program-die addr context)
+   ((find-program-die addr context)
-   (lambda (die)
+    => (lambda (die)
          (let* ((base (debug-context-base context))
                 (low-pc (die-ref die 'low-pc))
                 (high-pc (die-high-pc die))
@@ -516,4 +526,5 @@ section of the ELF image.  Returns an ELF symbol, or @code{#f}."
                        (lp (cons (make-source/dwarf (+ pc base) file line col)
                                  sources))
                        (reverse sources))))))
-        (else '()))))))
+            (else '())))))
+   (else '())))

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)

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."
+  (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))))
+             (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) '())))