;;; Make a disassembler-state object.
(defun make-dstate (&optional (fun-hooks *default-dstate-hooks*))
(let ((sap
+ ;; FIXME: What is this for? This cannot be safe!
(sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8)))))
(alignment *disassem-inst-alignment-bytes*)
(arg-column
\f
;;; A SAP-MAKER is a no-argument function that returns a SAP.
+;; FIXME: Are the objects we are taking saps for always pinned?
#!-sb-fluid (declaim (inline sap-maker))
-
(defun sap-maker (function input offset)
(declare (optimize (speed 3))
(type (function (t) sb!sys:system-area-pointer) function)
(last-location-retrieved nil :type (or null sb!di:code-location))
(last-form-retrieved -1 :type fixnum))
+;;; OAOO note: this shares a lot of implementation with
+;;; SB-DEBUG::GET-FILE-TOPLEVEL-FORM. Perhaps these should be merged
+;;; somehow.
(defun get-toplevel-form (debug-source tlf-index)
- (let ((name (sb!di:debug-source-name debug-source)))
- (ecase (sb!di:debug-source-from debug-source)
- (:file
- (cond ((not (probe-file name))
- (warn "The source file ~S no longer seems to exist." name)
+ (cond
+ ((sb!di:debug-source-namestring debug-source)
+ (let ((namestring (sb!di:debug-source-namestring debug-source)))
+ (cond ((not (probe-file namestring))
+ (warn "The source file ~S no longer seems to exist." namestring)
nil)
(t
(let ((start-positions
debug-source)))
(char-offset
(aref start-positions local-tlf-index)))
- (with-open-file (f name)
+ (with-open-file (f namestring)
(cond ((= (sb!di:debug-source-created debug-source)
- (file-write-date name))
+ (file-write-date namestring))
(file-position f char-offset))
(t
(warn "Source file ~S has been modified; ~@
using form offset instead of ~
file index."
- name)
+ namestring)
(let ((*read-suppress* t))
(dotimes (i local-tlf-index) (read f)))))
(let ((*readtable* (copy-readtable)))
(declare (ignore rest sub-char))
(let ((token (read stream t nil t)))
(format nil "#.~S" token))))
- (read f))
- ))))))))
- (:lisp
- (aref name tlf-index)))))
+ (read f)))))))))))
+ ((sb!di:debug-source-form debug-source)
+ (sb!di:debug-source-form debug-source))
+ (t (bug "Don't know how to use a DEBUG-SOURCE without ~
+ a namestring or a form."))))
(defun cache-valid (loc cache)
(and cache
(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)
(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)))))
(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