X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=b34a6a1fedb8494400c67fc3f8a4f801d4ed15b6;hb=7a5d64bca426192e259825e1cad3f47cd4f32247;hp=9bcfd33f8e438ea59c0a183fe400ec7b9d2e274e;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git

diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp
index 9bcfd33..b34a6a1 100644
--- a/src/compiler/target-disassem.lisp
+++ b/src/compiler/target-disassem.lisp
@@ -280,7 +280,7 @@
 
 (defun fun-self (fun)
   (declare (type compiled-function fun))
-  (sb!kernel:%simple-fun-self fun))
+  (sb!kernel:%simple-fun-self (sb!kernel:%fun-fun fun)))
 
 (defun fun-code (fun)
   (declare (type compiled-function fun))
@@ -288,17 +288,11 @@
 
 (defun fun-next (fun)
   (declare (type compiled-function fun))
-  (sb!kernel:%simple-fun-next fun))
+  (sb!kernel:%simple-fun-next (sb!kernel:%fun-fun fun)))
 
 (defun fun-address (fun)
   (declare (type compiled-function fun))
-  (ecase (sb!kernel:widetag-of fun)
-    (#.sb!vm:simple-fun-header-widetag
-     (- (sb!kernel:get-lisp-obj-address fun) sb!vm:fun-pointer-lowtag))
-    (#.sb!vm:closure-header-widetag
-     (fun-address (sb!kernel:%closure-fun fun)))
-    (#.sb!vm:funcallable-instance-header-widetag
-     (fun-address (sb!kernel:funcallable-instance-fun fun)))))
+  (- (sb!kernel:get-lisp-obj-address (sb!kernel:%fun-fun fun)) sb!vm:fun-pointer-lowtag))
 
 ;;; the offset of FUNCTION from the start of its code-component's
 ;;; instruction area
@@ -483,7 +477,7 @@
       (multiple-value-bind (words bytes)
           (truncate alignment sb!vm:n-word-bytes)
         (when (> words 0)
-          (print-words words stream dstate))
+          (print-inst (* words sb!vm:n-word-bytes) stream dstate))
         (when (> bytes 0)
           (print-inst bytes stream dstate)))
       (print-bytes alignment stream dstate))
@@ -498,7 +492,8 @@
            (type (or null stream) stream))
 
   (let ((ispace (get-inst-space))
-        (prefix-p nil)) ; just processed a prefix inst
+        (prefix-p nil) ; just processed a prefix inst
+        (prefix-len 0)) ; length of any prefix instruction(s)
 
     (rewind-current-segment dstate segment)
 
@@ -541,19 +536,22 @@
                             (when prefilter
                               (funcall prefilter chunk dstate))
 
+                            (setf prefix-p (null (inst-printer inst)))
+
                             ;; print any instruction bytes recognized by the prefilter which calls read-suffix
                             ;; and updates next-offs
                             (when stream
                               (let ((suffix-len (- (dstate-next-offs dstate) orig-next)))
                                 (when (plusp suffix-len)
                                   (print-inst suffix-len stream dstate :offset (inst-length inst) :trailing-space nil))
-                              (dotimes (i (- *disassem-inst-column-width* (* 2 (+ (inst-length inst) suffix-len))))
-                                (write-char #\space stream)))
-                              (write-char #\space stream))
+                                (unless prefix-p
+                                  (dotimes (i (- *disassem-inst-column-width* (* 2 (+ (inst-length inst) suffix-len prefix-len))))
+                                    (write-char #\space stream))
+                                  (write-char #\space stream))
 
-                            (funcall function chunk inst)
+                                (setf prefix-len (+ (inst-length inst) suffix-len))))
 
-                            (setf prefix-p (null (inst-printer inst)))
+                            (funcall function chunk inst)
 
                             (when control
                               (funcall control chunk inst stream dstate))
@@ -563,6 +561,7 @@
 
       (unless (null stream)
         (unless prefix-p
+          (setf prefix-len 0)
           (print-notes-and-newline stream dstate))
         (setf (dstate-output-state dstate) nil)))))
 
@@ -1190,10 +1189,9 @@
       (setf (dstate-output-state dstate)
             :block-boundary))))
 
-;;; Add hooks to track to track the source code in SEGMENT during
-;;; disassembly. SFCACHE can be either NIL or it can be a
-;;; SOURCE-FORM-CACHE structure, in which case it is used to cache
-;;; forms from files.
+;;; Add hooks to track the source code in SEGMENT during disassembly.
+;;; SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
+;;; structure, in which case it is used to cache forms from files.
 (defun add-source-tracking-hooks (segment debug-fun &optional sfcache)
   (declare (type segment segment)
            (type (or null sb!di:debug-fun) debug-fun)
@@ -1495,16 +1493,28 @@
       (error "can't compile a lexical closure"))
     (compile nil lambda)))
 
-(defun compiled-fun-or-lose (thing &optional (name thing))
+(defun valid-extended-function-designator-for-disassemble-p (thing)
   (cond ((legal-fun-name-p thing)
          (compiled-fun-or-lose (fdefinition thing) thing))
+        #!+sb-eval
+        ((sb!eval:interpreted-function-p thing)
+         (compile nil thing))
         ((functionp thing)
          thing)
         ((and (listp thing)
               (eq (car thing) 'lambda))
          (compile nil thing))
-        (t
-         (error "can't make a compiled function from ~S" name))))
+        (t nil)))
+
+(defun compiled-fun-or-lose (thing &optional (name thing))
+  (let ((fun (valid-extended-function-designator-for-disassemble-p thing)))
+    (if fun
+        fun
+        (error 'simple-type-error
+               :datum thing
+               :expected-type '(satisfies valid-extended-function-designator-for-disassemble-p)
+               :format-control "can't make a compiled function from ~S"
+               :format-arguments (list name)))))
 
 (defun disassemble (object &key
                            (stream *standard-output*)
@@ -1949,9 +1959,9 @@
   (unless (typep address 'address)
     (return-from maybe-note-assembler-routine nil))
   (let ((name (or
+               (find-assembler-routine address)
                #!+linkage-table
-               (sb!sys:sap-foreign-symbol (sb!sys:int-sap address))
-               (find-assembler-routine address))))
+               (sb!sys:sap-foreign-symbol (sb!sys:int-sap address)))))
     (unless (null name)
       (note (lambda (stream)
               (if note-address-p