X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=ae62e1a3061c06781d612fcba729f7c596d3420e;hb=66cff1e1319861c080d563359afea284614b3a7f;hp=24ad01898fdd738c29531c4728bfe76afcb63a66;hpb=be2e8599a25b1a21fac40d963ec71820b74cf3f3;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 24ad018..ae62e1a 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))))) @@ -797,6 +796,7 @@ ;;; 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 @@ -828,8 +828,8 @@ ;;; 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) @@ -1017,7 +1017,7 @@ (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 @@ -1190,10 +1190,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) @@ -1498,6 +1497,9 @@ (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) @@ -1958,9 +1960,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