[Sbcl-commits] master: Allow disassembling code component that has no debug-info

[Douglas K. <sn...@us...>]

The branch "master" has been updated in SBCL:
       via  0d5644b2a766bc15fd143f59bad09ceda8705a22 (commit)
      from  b2936b759580b9f3ceb5ff3501d8e70c98e7eb13 (commit)

- Log -----------------------------------------------------------------
commit 0d5644b2a766bc15fd143f59bad09ceda8705a22
Author: Douglas Katzman <do...@go...>
Date:   Sat Jan 3 22:15:11 2015 -0500

    Allow disassembling code component that has no debug-info
    
    Also reduce output from some unrelated disassembler tests.
---
 src/compiler/target-disassem.lisp |    4 ++--
 tests/interface.pure.lisp         |   26 +++++++++++++++++++++-----
 2 files changed, 23 insertions(+), 7 deletions(-)

diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp
index 9d2fb6e..4e62cc1 100644
--- a/src/compiler/target-disassem.lisp
+++ b/src/compiler/target-disassem.lisp
@@ -1353,7 +1353,7 @@
            (type offset start-offset)
            (type disassem-length length))
   (let ((segments nil))
-    (when code
+    (when (sb!kernel:%code-debug-info code)
       (let ((fun-map (code-fun-map code))
             (sfcache (make-source-form-cache)))
         (let ((last-offset 0)
@@ -1389,7 +1389,7 @@
                        (- (code-inst-area-length code) last-offset)
                        last-debug-fun))))))
     (if (null segments)
-        (make-code-segment code start-offset length)
+        (list (make-code-segment code start-offset length))
         (nreverse segments))))
 
 ;;; Compute labels for all the memory segments in SEGLIST and adds
diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp
index 76fe1b5..44e7830 100644
--- a/tests/interface.pure.lisp
+++ b/tests/interface.pure.lisp
@@ -155,8 +155,8 @@
 (encode-universal-time 0 0 23 31 12 1899 1)
 
 ;;; DISASSEMBLE shouldn't fail on purified functions
-(disassemble 'cl:+)
-(disassemble 'sb-ext:run-program)
+(disassemble 'cl:+ :stream (make-broadcast-stream))
+(disassemble 'sb-ext:run-program :stream (make-broadcast-stream))
 
 ;;; minimal test of GC: see stress-gc.{sh,lisp} for a more
 ;;; comprehensive test.
@@ -170,10 +170,12 @@
 (with-test (:name :bug-814702)
   (disassemble (lambda (x)
                  (= #C(2.0f0 3.0f0)
-                    (the (complex single-float) x))))
+                    (the (complex single-float) x)))
+               :stream (make-broadcast-stream))
   (disassemble (lambda (x y)
                  (= (the (complex single-float) x)
-                    (the (complex single-float) y)))))
+                    (the (complex single-float) y)))
+               :stream (make-broadcast-stream)))
 
 #+x86-64
 ;; The labeler for LEA would choke on an illegal encoding
@@ -181,7 +183,8 @@
 (with-test (:name :x86-lea-disassemble-illegal-op)
   (let ((a (coerce '(#x48 #x8D #xC4) '(array (unsigned-byte 8) (3)))))
     (sb-sys:with-pinned-objects (a)
-      (sb-disassem::disassemble-memory (sb-sys:sap-int (sb-sys:vector-sap a)) 3))))
+      (sb-disassem::disassemble-memory (sb-sys:sap-int (sb-sys:vector-sap a)) 3
+                                       :stream (make-broadcast-stream)))))
 
 ;; Assert that disassemblies of identically-acting functions are identical
 ;; if address printing is turned off. Should work on any backend, I think.
@@ -201,6 +204,19 @@
         (string2 (disassembly-text '(lambda (y) (car y)))))
     (assert (string= string1 string2)))))
 
+(with-test (:name :disassemble-assembly-routine)
+  (let ((code
+         (block nil
+           (sb-vm::map-allocated-objects
+            (lambda (obj type size)
+              (declare (ignore size))
+              (when (= type sb-vm:code-header-widetag)
+                (return obj)))
+            :read-only))))
+    (assert code) ; found something to disassemble
+    (sb-disassem:disassemble-code-component code
+     :stream (make-broadcast-stream))))
+
 ;;; Check that SLEEP called with ratios (with no common factors with
 ;;; 1000000000, and smaller than 1/1000000000) works more or less as
 ;;; expected.

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


hooks/post-receive
-- 
SBCL