[Guile-commits] GNU Guile branch, master, updated. v2.1.0-217-ge9588e7

[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=e9588e7032ced422014fb29bfaa6dbb7c2582b12

The branch, master has been updated
       via  e9588e7032ced422014fb29bfaa6dbb7c2582b12 (commit)
       via  e0230913e9bb1e54576ef7b9347c786ede99f733 (commit)
      from  7ea00e230aa05bc143c12d20dbc1d865129875a9 (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 e9588e7032ced422014fb29bfaa6dbb7c2582b12
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 4 15:28:40 2013 +0200

    Disassembling RTL prints source information.
    
    * module/system/vm/disassembler.scm (disassemble-buffer): Print source
      information.

commit e0230913e9bb1e54576ef7b9347c786ede99f733
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 4 15:09:31 2013 +0200

    add contification test
    
    * test-suite/tests/rtl-compilation.test ("contification"): Add
      contification test where non-recursive call is not in tail position
      relative to the letrec.

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

Summary of changes:
 module/system/vm/disassembler.scm     |   22 ++++++++++++++++++++--
 test-suite/tests/rtl-compilation.test |   11 ++++++++++-
 2 files changed, 30 insertions(+), 3 deletions(-)

diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index ad7bb2b..4917743 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -311,15 +311,33 @@ address of that offset."
           addr info extra src))
 
 (define (disassemble-buffer port bv start end context)
-  (let ((labels (compute-labels bv start end)))
+  (let ((labels (compute-labels bv start end))
+        (sources (find-program-sources (u32-offset->addr start context)
+                                       context)))
+    (define (lookup-source addr)
+      (let lp ((sources sources))
+        (match sources
+          (() #f)
+          ((source . sources)
+           (let ((pc (source-pre-pc source)))
+             (cond
+              ((< pc addr) (lp sources))
+              ((= pc addr)
+               (format #f "~a:~a:~a"
+                       (source-file source)
+                       (source-line-for-user source)
+                       (source-column source)))
+              (else #f)))))))
     (let lp ((offset start))
       (when (< offset end)
         (call-with-values (lambda () (disassemble-one bv offset))
           (lambda (len elt)
             (let ((pos (- offset start))
+                  (addr (u32-offset->addr offset context))
                   (annotation (code-annotation elt len offset start labels
                                                context)))
-              (print-info port pos (vector-ref labels pos) elt annotation #f)
+              (print-info port pos (vector-ref labels pos) elt annotation
+                          (lookup-source addr))
               (lp (+ offset len)))))))))
 
 (define* (disassemble-program program #:optional (port (current-output-port)))
diff --git a/test-suite/tests/rtl-compilation.test 
b/test-suite/tests/rtl-compilation.test
index cf00a4f..ef4ab8d 100644
--- a/test-suite/tests/rtl-compilation.test
+++ b/test-suite/tests/rtl-compilation.test
@@ -158,7 +158,16 @@
                              (define (odd? x)
                                (if (null? x) #f (even? (cdr x))))
                              (even? x)))
-                 '(1 2 3)))))
+                 '(1 2 3))))
+
+  (pass-if-equal '(#t)
+      ((run-rtl '(lambda (x)
+                   (define (even? x)
+                     (if (null? x) #t (odd? (cdr x))))
+                   (define (odd? x)
+                     (if (null? x) #f (even? (cdr x))))
+                   (list (even? x))))
+       '(1 2 3 4))))
 
 (with-test-prefix "case-lambda"
   (pass-if-equal "simple"


hooks/post-receive
-- 
GNU Guile