From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 31 Oct 2008 16:57:36 +0000 (+0000)
Subject: 1.0.22.5: teach DISASSEMBLE about %METHOD-FUNCTIONs
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5045e828e995391a9bbcfe737eb09e42861bab82;p=sbcl.git

1.0.22.5: teach DISASSEMBLE about %METHOD-FUNCTIONs

 * Disassemble both the %METHOD-FUNCTION object itself, and the
   associated fast-function.

 * Clarify the disassembler output slightly by prepending it with
   ; disassembly for <function name>.
---

diff --git a/NEWS b/NEWS
index d700a99..e3ab52d 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,7 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-1.0.23 relative to 1.0.22:
+  * enhancement: when disassembling method functions, disassembly
+    for the associated fast function is also produced.
   * optimization: printing with *PRINT-PRETTY* true is now more
     efficient as long as the object being printed doesn't require
     special handling by the pretty printer.
diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp
index 1c3d4b2..636e446 100644
--- a/src/compiler/target-disassem.lisp
+++ b/src/compiler/target-disassem.lisp
@@ -1498,12 +1498,16 @@
       (error "can't compile a lexical closure"))
     (compile nil lambda)))
 
-(defun valid-extended-function-designator-for-disassemble-p (thing)
+(defun valid-extended-function-designators-for-disassemble-p (thing)
   (cond ((legal-fun-name-p thing)
-         (compiled-fun-or-lose (fdefinition thing) thing))
+         (compiled-funs-or-lose (fdefinition thing) thing))
         #!+sb-eval
         ((sb!eval:interpreted-function-p thing)
          (compile nil thing))
+        ((typep thing 'sb!pcl::%method-function)
+         ;; in a %METHOD-FUNCTION, the user code is in the fast function, so
+         ;; we to disassemble both.
+         (list thing (sb!pcl::%method-function-fast-function thing)))
         ((functionp thing)
          thing)
         ((and (listp thing)
@@ -1511,13 +1515,13 @@
          (compile nil thing))
         (t nil)))
 
-(defun compiled-fun-or-lose (thing &optional (name thing))
-  (let ((fun (valid-extended-function-designator-for-disassemble-p thing)))
-    (if fun
-        fun
+(defun compiled-funs-or-lose (thing &optional (name thing))
+  (let ((funs (valid-extended-function-designators-for-disassemble-p thing)))
+    (if funs
+        funs
         (error 'simple-type-error
                :datum thing
-               :expected-type '(satisfies valid-extended-function-designator-for-disassemble-p)
+               :expected-type '(satisfies valid-extended-function-designators-for-disassemble-p)
                :format-control "can't make a compiled function from ~S"
                :format-arguments (list name)))))
 
@@ -1532,11 +1536,16 @@
   (declare (type (or function symbol cons) object)
            (type (or (member t) stream) stream)
            (type (member t nil) use-labels))
-  (pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
-    (disassemble-fun (compiled-fun-or-lose object)
-                     :stream stream
-                     :use-labels use-labels)
-    nil))
+  (flet ((disassemble1 (fun)
+           (format stream "~&; disassembly for ~S" (sb!kernel:%fun-name fun))
+           (disassemble-fun fun
+                            :stream stream
+                            :use-labels use-labels)))
+    (let ((funs (compiled-funs-or-lose object)))
+      (if (listp funs)
+          (dolist (fun funs) (disassemble1 fun))
+          (disassemble1 funs))))
+  nil)
 
 ;;; Disassembles the given area of memory starting at ADDRESS and
 ;;; LENGTH long. Note that if CODE-COMPONENT is NIL and this memory
diff --git a/version.lisp-expr b/version.lisp-expr
index 4bd98f4..712c766 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.22.4"
+"1.0.22.5"