X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=f71c8cab9ab193458074e5688f0f6ab34fafa726;hb=40bea2551744d3cdc05a79a923fbff79a5755845;hp=1c47cab6b10ec71dd230180010b25bfdeebf74f2;hpb=c2c405712ae18e70a96c4a8cf584dde329f3d5f7;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 1c47cab..f71c8ca 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 @@ -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))))) @@ -796,9 +795,7 @@ ;;; Make a disassembler-state object. (defun make-dstate (&optional (fun-hooks *default-dstate-hooks*)) - (let ((sap - (sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8))))) - (alignment *disassem-inst-alignment-bytes*) + (let ((alignment *disassem-inst-alignment-bytes*) (arg-column (+ (or *disassem-opcode-column-width* 0) *disassem-location-column-width* @@ -808,8 +805,7 @@ (when (> alignment 1) (push #'alignment-hook fun-hooks)) - (%make-dstate :segment-sap sap - :fun-hooks fun-hooks + (%make-dstate :fun-hooks fun-hooks :argument-column arg-column :alignment alignment :byte-order sb!c:*backend-byte-order*))) @@ -828,8 +824,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) @@ -947,12 +943,15 @@ (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 @@ -967,15 +966,15 @@ 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))) @@ -985,10 +984,11 @@ (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 @@ -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 @@ -1494,9 +1494,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) @@ -1504,13 +1511,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))))) @@ -1525,11 +1532,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