(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))
(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
(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))
(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)
(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))
(unless (null stream)
(unless prefix-p
+ (setf prefix-len 0)
(print-notes-and-newline stream dstate))
(setf (dstate-output-state dstate) nil)))))
\f
;;; 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
(sfcache-form-number-mapping-table cache) mapping-table))
(cond ((null toplevel-form)
nil)
- ((> form-number (length mapping-table))
+ ((>= form-number (length mapping-table))
(warn "bogus form-number in form! The source file has probably ~@
been changed too much to cope with.")
(when cache
(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)
(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
projects / sbcl.git / blobdiff