[Guile-commits] GNU Guile branch, master, updated. v2.1.0-213-gb43e81d

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b43e81dc6085f250a3520b69b6445dbc0896850c

The branch, master has been updated
       via  b43e81dc6085f250a3520b69b6445dbc0896850c (commit)
       via  7c54029740a147a623c1f0564708d5471addf232 (commit)
      from  d7928d7c61f297dca574e20bb5815253e90b3a36 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit b43e81dc6085f250a3520b69b6445dbc0896850c
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 3 22:48:17 2013 +0200

    anonymous RTl functions print with source info
    
    * module/system/vm/debug.scm (find-program-sources): If there is no
      source location before the low-pc of the procedure we're grovelling
      for, we were skipping the source loc info.  Fix that.
    
    * module/system/vm/program.scm (write-program): Get source info for
      anonymous RTL functions.
      (program-sources, program-sources-pre-retire): Provide program
      counters relative to the beginning of the procedure.

commit 7c54029740a147a623c1f0564708d5471addf232
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 3 22:31:37 2013 +0200

    program-source / program-sources works with RTL programs
    
    * libguile/programs.c (scm_program_sources): Define as %program-sources,
      and let Scheme export the program-sources proper.
      (scm_program_source): Call out to Scheme.
    
    * module/system/vm/program.scm: Convert to use match instead of pmatch.
      Adapt existing callers.
      (program-sources, program-source): New Scheme implementations of these
      functions.
      (program-sources-pre-retire): Add RTL program case.

-----------------------------------------------------------------------

Summary of changes:
 libguile/programs.c          |   36 ++++++----------
 module/system/vm/debug.scm   |    6 ++-
 module/system/vm/program.scm |   92 ++++++++++++++++++++++++++++--------------
 3 files changed, 79 insertions(+), 55 deletions(-)

diff --git a/libguile/programs.c b/libguile/programs.c
index 37130d0..5039d2a 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -297,7 +297,7 @@ SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 
0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
+SCM_DEFINE (scm_program_sources, "%program-sources", 1, 0, 0,
            (SCM program),
            "")
 #define FUNC_NAME s_scm_program_sources
@@ -365,32 +365,24 @@ scm_i_program_properties (SCM program)
 }
 #undef FUNC_NAME
 
-static SCM
-program_source (SCM program, size_t ip, SCM sources)
+SCM
+scm_program_source (SCM program, SCM ip, SCM sources)
 {
-  SCM source = SCM_BOOL_F;
+  static SCM program_source = SCM_BOOL_F;
 
-  while (!scm_is_null (sources)
-         && scm_to_size_t (scm_caar (sources)) <= ip)
-    {
-      source = scm_car (sources);
-      sources = scm_cdr (sources);
-    }
-  
-  return source; /* (addr . (filename . (line . column))) */
-}
+  if (scm_is_false (program_source)) {
+    if (!scm_module_system_booted_p)
+      return SCM_BOOL_F;
+
+    program_source =
+      scm_c_private_variable ("system vm program", "program-source");
+  }
 
-SCM_DEFINE (scm_program_source, "program-source", 2, 1, 0,
-           (SCM program, SCM ip, SCM sources),
-           "")
-#define FUNC_NAME s_scm_program_source
-{
-  SCM_VALIDATE_PROGRAM (1, program);
   if (SCM_UNBNDP (sources))
-    sources = scm_program_sources (program);
-  return program_source (program, scm_to_size_t (ip), sources);
+    return scm_call_2 (scm_variable_ref (program_source), program, ip);
+  else
+    return scm_call_3 (scm_variable_ref (program_source), program, ip, 
sources);
 }
-#undef FUNC_NAME
     
 SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 
0, 0,
            (SCM program),
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 0531188..6142f3d 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -506,9 +506,11 @@ section of the ELF image.  Returns an ELF symbol, or 
@code{#f}."
                              (line-prog (ctx-die (die-ctx die))))))))
        (cond
         ((and low-pc high-pc prog)
-         (line-prog-scan-to-pc prog (1- low-pc))
          (let lp ((sources '()))
-           (call-with-values (lambda () (line-prog-advance prog))
+           (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)
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 267e373..fb87d97 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -19,7 +19,7 @@
 ;;; Code:
 
 (define-module (system vm program)
-  #:use-module (system base pmatch)
+  #:use-module (ice-9 match)
   #:use-module (system vm instruction)
   #:use-module (system vm objcode)
   #:use-module (system vm debug)
@@ -119,6 +119,27 @@
           ;; fixed length
           (instruction-length inst))))))
 
+(define (program-sources proc)
+  (cond
+   ((rtl-program? proc)
+    (map (lambda (source)
+           (cons* (- (source-post-pc source) (rtl-program-code proc))
+                  (source-file source)
+                  (source-line source)
+                  (source-column source)))
+         (find-program-sources (rtl-program-code proc))))
+   (else
+    (%program-sources proc))))
+
+(define* (program-source proc ip #:optional (sources (program-sources proc)))
+  (let lp ((source #f) (sources sources))
+    (match sources
+      (() source)
+      (((and s (pc . _)) . sources)
+       (if (<= pc ip)
+           (lp s sources)
+           source)))))
+
 ;; Source information could in theory be correlated with the ip of the
 ;; instruction, or the ip just after the instruction is retired. Guile
 ;; does the latter, to make backtraces easy -- an error produced while
@@ -130,25 +151,34 @@
 ;; pre-retire addresses.
 ;;
 (define (program-sources-pre-retire proc)
-  (let ((bv (objcode->bytecode (program-objcode proc))))
-    (let lp ((in (program-sources proc))
-             (out '())
-             (ip 0))
-      (cond
-       ((null? in)
-        (reverse out))
-       (else
-        (pmatch (car in)
-          ((,post-ip . ,source)
-           (let lp2 ((ip ip)
-                     (next ip))
-             (if (< next post-ip)
-                 (lp2 next (+ next (bytecode-instruction-length bv next)))
-                 (lp (cdr in)
-                     (acons ip source out)
-                     next))))
-          (else
-           (error "unexpected"))))))))
+  (cond
+   ((rtl-program? proc)
+    (map (lambda (source)
+           (cons* (- (source-pre-pc source) (rtl-program-code proc))
+                  (source-file source)
+                  (source-line source)
+                  (source-column source)))
+         (find-program-sources (rtl-program-code proc))))
+   (else
+    (let ((bv (objcode->bytecode (program-objcode proc))))
+      (let lp ((in (program-sources proc))
+               (out '())
+               (ip 0))
+        (cond
+         ((null? in)
+          (reverse out))
+         (else
+          (match (car in)
+            ((post-ip . source)
+             (let lp2 ((ip ip)
+                       (next ip))
+               (if (< next post-ip)
+                   (lp2 next (+ next (bytecode-instruction-length bv next)))
+                   (lp (cdr in)
+                       (acons ip source out)
+                       next))))
+            (_
+             (error "unexpected"))))))))))
 
 (define (collapse-locals locs)
   (let lp ((ret '()) (locs locs))
@@ -185,19 +215,19 @@
                     (else (inner (cdr binds)))))))))
 
 (define (arity:start a)
-  (pmatch a ((,start ,end . _) start) (else (error "bad arity" a))))
+  (match a ((start end . _) start) (_ (error "bad arity" a))))
 (define (arity:end a)
-  (pmatch a ((,start ,end . _) end) (else (error "bad arity" a))))
+  (match a ((start end . _) end) (_ (error "bad arity" a))))
 (define (arity:nreq a)
-  (pmatch a ((_ _ ,nreq . _) nreq) (else 0)))
+  (match a ((_ _ nreq . _) nreq) (_ 0)))
 (define (arity:nopt a)
-  (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0)))
+  (match a ((_ _ nreq nopt . _) nopt) (_ 0)))
 (define (arity:rest? a)
-  (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
+  (match a ((_ _ nreq nopt rest? . _) rest?) (_ #f)))
 (define (arity:kw a)
-  (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
+  (match a ((_ _ nreq nopt rest? (_ . kw)) kw) (_ '())))
 (define (arity:allow-other-keys? a)
-  (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
+  (match a ((_ _ nreq nopt rest? (aok . kw)) aok) (_ #f)))
 
 (define (program-arity prog ip)
   (let ((arities (program-arities prog)))
@@ -211,15 +241,15 @@
                  (else (lp (cdr arities))))))))
 
 (define (arglist->arguments-alist arglist)
-  (pmatch arglist
-    ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
+  (match arglist
+    ((req opt keyword allow-other-keys? rest . extents)
      `((required . ,req)
        (optional . ,opt)
        (keyword . ,keyword)
        (allow-other-keys? . ,allow-other-keys?)
        (rest . ,rest)
        (extents . ,extents)))
-    (else #f)))
+    (_ #f)))
 
 (define* (arity->arguments-alist prog arity
                                  #:optional
@@ -301,7 +331,7 @@
 (define (write-program prog port)
   (define (program-identity-string)
     (or (procedure-name prog)
-        (and=> (and (program? prog) (program-source prog 0))
+        (and=> (program-source prog 0)
                (lambda (s)
                  (format #f "~a at ~a:~a:~a"
                          (number->string (object-address prog) 16)


hooks/post-receive
-- 
GNU Guile