[Guile-commits] GNU Guile branch, master, updated. v2.1.0-918-g560bfa9

[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=560bfa924152db0ab4d117e37f7886a88830bb81

The branch, master has been updated
       via  560bfa924152db0ab4d117e37f7886a88830bb81 (commit)
      from  c4aa51bae8ac6139798e043fc86eaa696b06010c (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 560bfa924152db0ab4d117e37f7886a88830bb81
Author: Andy Wingo <address@hidden>
Date:   Sun Apr 13 14:40:22 2014 +0200

    Improve disassembly for optimized closures
    
    * module/system/vm/disassembler.scm (code-annotation): Add call-label
      and tail-call-label cases.
      (disassemble-addr): With call-label we can see sets of mutually
      recursive functions, so keep a global "visited?" set.

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

Summary of changes:
 module/system/vm/disassembler.scm |   23 +++++++++++++++++++----
 1 files changed, 19 insertions(+), 4 deletions(-)

diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index 6eb14c5..4e9bd52 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -1,6 +1,6 @@
 ;;; Guile bytecode disassembler
 
-;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014 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
@@ -249,6 +249,20 @@ address of that offset."
                       "anonymous procedure")))
        (push-addr! addr name)
        (list "~A at #x~X (~A free var~:p)" name addr nfree)))
+    (('call-label closure nlocals target)
+     (let* ((addr (u32-offset->addr (+ offset target) context))
+            (pdi (find-program-debug-info addr context))
+            (name (or (and pdi (program-debug-info-name pdi))
+                      "anonymous procedure")))
+       (push-addr! addr name)
+       (list "~A at #x~X" name addr)))
+    (('tail-call-label nlocals target)
+     (let* ((addr (u32-offset->addr (+ offset target) context))
+            (pdi (find-program-debug-info addr context))
+            (name (or (and pdi (program-debug-info-name pdi))
+                      "anonymous procedure")))
+       (push-addr! addr name)
+       (list "~A at #x~X" name addr)))
     (('make-non-immediate dst target)
      (let ((val (reference-scm target)))
        (when (program? val)
@@ -351,14 +365,15 @@ address of that offset."
                           (lookup-source addr))
               (lp (+ offset len)))))))))
 
-(define (disassemble-addr addr label port)
+(define* (disassemble-addr addr label port #:optional (seen (make-hash-table)))
   (format port "Disassembly of ~A at #x~X:\n\n" label addr)
   (cond
    ((find-program-debug-info addr)
     => (lambda (pdi)
          (let ((worklist '()))
            (define (push-addr! addr label)
-             (unless (assv addr worklist)
+             (unless (hashv-ref seen addr)
+               (hashv-set! seen addr #t)
                (set! worklist (acons addr label worklist))))
            (disassemble-buffer port
                                (program-debug-info-image pdi)
@@ -370,7 +385,7 @@ address of that offset."
                       ((addr . label)
                        (display "\n----------------------------------------\n"
                                 port)
-                       (disassemble-addr addr label port)))
+                       (disassemble-addr addr label port seen)))
                      worklist))))
    (else
     (format port "Debugging information unavailable.~%")))


hooks/post-receive
-- 
GNU Guile