X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=1914bdc055cced7a43ad0b664f83e2f9e48e2e03;hb=eb53f2bf913aa34aee83b35eb2b709a2e0d40366;hp=ae62e1a3061c06781d612fcba729f7c596d3420e;hpb=ad6345c0021507c8830c7c8541ed651a89792335;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index ae62e1a..1914bdc 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -471,20 +471,41 @@ (unless (= (dstate-next-offs dstate) cur-offs) (return prefix-p)))))) -(defun handle-bogus-instruction (stream dstate) +;;; Print enough spaces to fill the column used for instruction bytes, +;;; assuming that N-BYTES many instruction bytes have already been +;;; printed in it, then print an additional space as separator to the +;;; opcode column. +(defun pad-inst-column (stream n-bytes) + (declare (type stream stream) + (type text-width n-bytes)) + (dotimes (i (- *disassem-inst-column-width* (* 2 n-bytes))) + (write-char #\space stream)) + (write-char #\space stream)) + +(defun handle-bogus-instruction (stream dstate prefix-len) (let ((alignment (dstate-alignment dstate))) (unless (null stream) (multiple-value-bind (words bytes) (truncate alignment sb!vm:n-word-bytes) (when (> words 0) - (print-inst (* words sb!vm:n-word-bytes) stream dstate)) + (print-inst (* words sb!vm:n-word-bytes) stream dstate + :trailing-space nil)) (when (> bytes 0) - (print-inst bytes stream dstate))) - (print-bytes alignment stream dstate)) + (print-inst bytes stream dstate :trailing-space nil))) + (pad-inst-column stream (+ prefix-len alignment)) + (decf (dstate-cur-offs dstate) prefix-len) + (print-bytes (+ prefix-len alignment) stream dstate)) (incf (dstate-next-offs dstate) alignment))) ;;; Iterate through the instructions in SEGMENT, calling FUNCTION for ;;; each instruction, with arguments of CHUNK, STREAM, and DSTATE. +;;; Additionally, unless STREAM is NIL, several items are output to it: +;;; things printed from several hooks, for example labels, and instruction +;;; bytes before FUNCTION is called, notes and a newline afterwards. +;;; Instructions having an INST-PRINTER of NIL are treated as prefix +;;; instructions which makes them print on the same line as the following +;;; instruction, outputting their INST-PRINT-NAME (unless that is NIL) +;;; before FUNCTION is called for the following instruction. (defun map-segment-instructions (function segment dstate &optional stream) (declare (type function function) (type segment segment) @@ -493,7 +514,8 @@ (let ((ispace (get-inst-space)) (prefix-p nil) ; just processed a prefix inst - (prefix-len 0)) ; length of any prefix instruction(s) + (prefix-len 0) ; sum of lengths of any prefix instruction(s) + (prefix-print-names nil)) ; reverse list of prefixes seen (rewind-current-segment dstate segment) @@ -501,6 +523,11 @@ (when (>= (dstate-cur-offs dstate) (seg-length (dstate-segment dstate))) ;; done! + (when (and stream (> prefix-len 0)) + (pad-inst-column stream prefix-len) + (decf (dstate-cur-offs dstate) prefix-len) + (print-bytes prefix-len stream dstate) + (incf (dstate-cur-offs dstate) prefix-len)) (return)) (setf (dstate-next-offs dstate) (dstate-cur-offs dstate)) @@ -514,56 +541,73 @@ (sb!sys:without-gcing (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment))) - (let ((chunk - (sap-ref-dchunk (dstate-segment-sap dstate) - (dstate-cur-offs dstate) - (dstate-byte-order dstate)))) - (let ((fun-prefix-p (call-fun-hooks chunk stream dstate))) - (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) - (setf prefix-p fun-prefix-p) + (let* ((chunk + (sap-ref-dchunk (dstate-segment-sap dstate) + (dstate-cur-offs dstate) + (dstate-byte-order dstate))) + (fun-prefix-p (call-fun-hooks chunk stream dstate))) + (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) + (setf prefix-p fun-prefix-p) (let ((inst (find-inst chunk ispace))) (cond ((null inst) - (handle-bogus-instruction stream dstate)) + (handle-bogus-instruction stream dstate prefix-len) + (setf prefix-p nil)) (t - (setf (dstate-inst-properties dstate) nil) (setf (dstate-next-offs dstate) (+ (dstate-cur-offs dstate) (inst-length inst))) - (let ((orig-next (dstate-next-offs dstate))) - (print-inst (inst-length inst) stream dstate :trailing-space nil) - (let ((prefilter (inst-prefilter inst)) - (control (inst-control inst))) - (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)) - (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)) - - (setf prefix-len (+ (inst-length inst) suffix-len)))) - - (funcall function chunk inst) - - (when control - (funcall control chunk inst stream dstate)) - )))))))))) + (let ((orig-next (dstate-next-offs dstate)) + (prefilter (inst-prefilter inst)) + (control (inst-control inst))) + (print-inst (inst-length inst) stream dstate + :trailing-space nil) + (when prefilter + (funcall prefilter chunk dstate)) + + (setf prefix-p (null (inst-printer inst))) + + (when stream + ;; Print any instruction bytes recognized by + ;; the prefilter which calls read-suffix and + ;; updates next-offs. + (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)) + ;; Keep track of the number of bytes + ;; printed so far. + (incf prefix-len (+ (inst-length inst) + suffix-len))) + (if prefix-p + (let ((name (inst-print-name inst))) + (when name + (push name prefix-print-names))) + (progn + ;; PREFIX-LEN includes the length of the + ;; current (non-prefix) instruction here. + (pad-inst-column stream prefix-len) + (dolist (name (reverse prefix-print-names)) + (princ name stream) + (write-char #\space stream))))) + + (funcall function chunk inst) + + (when control + (funcall control chunk inst stream dstate)))))))))) (setf (dstate-cur-offs dstate) (dstate-next-offs dstate)) - (unless (null stream) + (when stream (unless prefix-p - (setf prefix-len 0) + (setf prefix-len 0 + prefix-print-names nil) (print-notes-and-newline stream dstate)) - (setf (dstate-output-state dstate) nil))))) + (setf (dstate-output-state dstate) nil)) + (unless prefix-p + (setf (dstate-inst-properties dstate) nil))))) + ;;; Make an initial non-printing disassembly pass through DSTATE, ;;; noting any addresses that are referenced by instructions in this @@ -747,9 +791,7 @@ (dotimes (offs num) (format stream "~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs)))) (when trailing-space - (dotimes (i (- *disassem-inst-column-width* (* 2 num))) - (write-char #\space stream)) - (write-char #\space stream)))) + (pad-inst-column stream num)))) ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions. (defun print-bytes (num stream dstate) @@ -795,10 +837,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*) + (let ((alignment *disassem-inst-alignment-bytes*) (arg-column (+ (or *disassem-opcode-column-width* 0) *disassem-location-column-width* @@ -808,8 +847,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*))) @@ -947,12 +985,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 +1008,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 +1026,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 @@ -1494,12 +1536,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) @@ -1507,13 +1553,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))))) @@ -1528,11 +1574,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