X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=0603947086d132d28fa77448390f333a6e0d46ed;hb=5f891793819e3cd714c443c9a0a7223b4fb13dd0;hp=ca5ca262a5f9cba43531a75b05b5cfaf1373fe83;hpb=b6cb3d5b2e2a0d6e6c92a2f3d852051540660fef;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index ca5ca26..0603947 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -23,10 +23,10 @@ (defun inst-specializes-p (special general) (declare (type instruction special general)) (let ((smask (inst-mask special)) - (gmask (inst-mask general))) + (gmask (inst-mask general))) (and (dchunk= (inst-id general) - (dchunk-and (inst-id special) gmask)) - (dchunk-strict-superset-p smask gmask)))) + (dchunk-and (inst-id special) gmask)) + (dchunk-strict-superset-p smask gmask)))) ;;; a bit arbitrary, but should work ok... ;;; @@ -44,8 +44,9 @@ (sort insts #'> :key #'specializer-rank)) (defun specialization-error (insts) - (error "~@" - insts)) + (bug + "~@" + insts)) ;;; Given a list of instructions INSTS, Sees if one of these instructions is a ;;; more general form of all the others, in which case they are put into its @@ -55,20 +56,20 @@ (let ((masters (copy-list insts))) (dolist (possible-master insts) (dolist (possible-specializer insts) - (unless (or (eq possible-specializer possible-master) - (inst-specializes-p possible-specializer possible-master)) - (setf masters (delete possible-master masters)) - (return) ; exit the inner loop - ))) + (unless (or (eq possible-specializer possible-master) + (inst-specializes-p possible-specializer possible-master)) + (setf masters (delete possible-master masters)) + (return) ; exit the inner loop + ))) (cond ((null masters) - (specialization-error insts)) - ((cdr masters) - (error "multiple specializing masters: ~S" masters)) - (t - (let ((master (car masters))) - (setf (inst-specializers master) - (order-specializers (remove master insts))) - master))))) + (specialization-error insts)) + ((cdr masters) + (error "multiple specializing masters: ~S" masters)) + (t + (let ((master (car masters))) + (setf (inst-specializers master) + (order-specializers (remove master insts))) + master))))) ;;;; choosing an instruction @@ -77,7 +78,7 @@ ;;; Return non-NIL if all constant-bits in INST match CHUNK. (defun inst-matches-p (inst chunk) (declare (type instruction inst) - (type dchunk chunk)) + (type dchunk chunk)) (dchunk= (dchunk-and (inst-mask inst) chunk) (inst-id inst))) ;;; Given an instruction object, INST, and a bit-pattern, CHUNK, pick @@ -85,11 +86,11 @@ ;;; constraints are met by CHUNK. If none do, then return INST. (defun choose-inst-specialization (inst chunk) (declare (type instruction inst) - (type dchunk chunk)) + (type dchunk chunk)) (or (dolist (spec (inst-specializers inst) nil) - (declare (type instruction spec)) - (when (inst-matches-p spec chunk) - (return spec))) + (declare (type instruction spec)) + (when (inst-matches-p spec chunk) + (return spec))) inst)) ;;;; searching for an instruction in instruction space @@ -98,21 +99,21 @@ ;;; bit-pattern CHUNK, or NIL if there isn't one. (defun find-inst (chunk inst-space) (declare (type dchunk chunk) - (type (or null inst-space instruction) inst-space)) + (type (or null inst-space instruction) inst-space)) (etypecase inst-space (null nil) (instruction (if (inst-matches-p inst-space chunk) - (choose-inst-specialization inst-space chunk) - nil)) + (choose-inst-specialization inst-space chunk) + nil)) (inst-space (let* ((mask (ispace-valid-mask inst-space)) - (id (dchunk-and mask chunk))) + (id (dchunk-and mask chunk))) (declare (type dchunk id mask)) (dolist (choice (ispace-choices inst-space)) - (declare (type inst-space-choice choice)) - (when (dchunk= id (ischoice-common-id choice)) - (return (find-inst chunk (ischoice-subspace choice))))))))) + (declare (type inst-space-choice choice)) + (when (dchunk= id (ischoice-common-id choice)) + (return (find-inst chunk (ischoice-subspace choice))))))))) ;;;; building the instruction space @@ -129,37 +130,37 @@ ;; bits, TRY-SPECIALIZING is called, which handles the cases of many ;; variations on a single instruction. (declare (type list insts) - (type dchunk initial-mask)) + (type dchunk initial-mask)) (cond ((null insts) - nil) - ((null (cdr insts)) - (car insts)) - (t - (let ((vmask (dchunk-copy initial-mask))) - (dolist (inst insts) - (dchunk-andf vmask (inst-mask inst))) - (if (dchunk-zerop vmask) - (try-specializing insts) - (let ((buckets nil)) - (dolist (inst insts) - (let* ((common-id (dchunk-and (inst-id inst) vmask)) - (bucket (assoc common-id buckets :test #'dchunk=))) - (cond ((null bucket) - (push (list common-id inst) buckets)) - (t - (push inst (cdr bucket)))))) - (let ((submask (dchunk-clear initial-mask vmask))) - (if (= (length buckets) 1) - (try-specializing insts) - (make-inst-space - :valid-mask vmask - :choices (mapcar (lambda (bucket) - (make-inst-space-choice - :subspace (build-inst-space - (cdr bucket) - submask) - :common-id (car bucket))) - buckets)))))))))) + nil) + ((null (cdr insts)) + (car insts)) + (t + (let ((vmask (dchunk-copy initial-mask))) + (dolist (inst insts) + (dchunk-andf vmask (inst-mask inst))) + (if (dchunk-zerop vmask) + (try-specializing insts) + (let ((buckets nil)) + (dolist (inst insts) + (let* ((common-id (dchunk-and (inst-id inst) vmask)) + (bucket (assoc common-id buckets :test #'dchunk=))) + (cond ((null bucket) + (push (list common-id inst) buckets)) + (t + (push inst (cdr bucket)))))) + (let ((submask (dchunk-clear initial-mask vmask))) + (if (= (length buckets) 1) + (try-specializing insts) + (make-inst-space + :valid-mask vmask + :choices (mapcar (lambda (bucket) + (make-inst-space-choice + :subspace (build-inst-space + (cdr bucket) + submask) + :common-id (car bucket))) + buckets)))))))))) ;;;; an inst-space printer for debugging purposes @@ -167,15 +168,15 @@ (do ((bit (1- word-size) (1- bit))) ((< bit 0)) (write-char (cond ((logbitp bit mask) - (if (logbitp bit num) #\1 #\0)) - ((< bit show) #\x) - (t #\space))))) + (if (logbitp bit num) #\1 #\0)) + ((< bit show) #\x) + (t #\space))))) (defun print-inst-bits (inst) (print-masked-binary (inst-id inst) - (inst-mask inst) - dchunk-bits - (bytes-to-bits (inst-length inst)))) + (inst-mask inst) + dchunk-bits + (bytes-to-bits (inst-length inst)))) ;;; Print a nicely-formatted version of INST-SPACE. (defun print-inst-space (inst-space &optional (indent 0)) @@ -183,8 +184,8 @@ (null) (instruction (format t "~Vt[~A(~A)~40T" indent - (inst-name inst-space) - (inst-format-name inst-space)) + (inst-name inst-space) + (inst-format-name inst-space)) (print-inst-bits inst-space) (dolist (inst (inst-specializers inst-space)) (format t "~%~Vt:~A~40T" indent (inst-name inst)) @@ -193,46 +194,46 @@ (terpri)) (inst-space (format t "~Vt---- ~8,'0X ----~%" - indent - (ispace-valid-mask inst-space)) + indent + (ispace-valid-mask inst-space)) (map nil - (lambda (choice) - (format t "~Vt~8,'0X ==>~%" - (+ 2 indent) - (ischoice-common-id choice)) - (print-inst-space (ischoice-subspace choice) - (+ 4 indent))) - (ispace-choices inst-space))))) + (lambda (choice) + (format t "~Vt~8,'0X ==>~%" + (+ 2 indent) + (ischoice-common-id choice)) + (print-inst-space (ischoice-subspace choice) + (+ 4 indent))) + (ispace-choices inst-space))))) ;;;; (The actual disassembly part follows.) ;;; Code object layout: -;;; header-word -;;; code-size (starting from first inst, in words) -;;; entry-points (points to first function header) -;;; debug-info -;;; trace-table-offset (starting from first inst, in bytes) -;;; constant1 -;;; constant2 -;;; ... -;;; -;;; start of instructions -;;; ... -;;; function-headers and lra's buried in here randomly -;;; ... -;;; start of trace-table -;;; +;;; header-word +;;; code-size (starting from first inst, in words) +;;; entry-points (points to first function header) +;;; debug-info +;;; trace-table-offset (starting from first inst, in bytes) +;;; constant1 +;;; constant2 +;;; ... +;;; +;;; start of instructions +;;; ... +;;; fun-headers and lra's buried in here randomly +;;; ... +;;; start of trace-table +;;; ;;; ;;; Function header layout (dual word aligned): -;;; header-word -;;; self pointer -;;; next pointer (next function header) -;;; name -;;; arglist -;;; type +;;; header-word +;;; self pointer +;;; next pointer (next function header) +;;; name +;;; arglist +;;; type ;;; ;;; LRA layout (dual word aligned): -;;; header-word +;;; header-word #!-sb-fluid (declaim (inline words-to-bytes bytes-to-words)) @@ -252,15 +253,15 @@ (defstruct (offs-hook (:copier nil)) (offset 0 :type offset) - (function (required-argument) :type function) + (fun (missing-arg) :type function) (before-address nil :type (member t nil))) (defstruct (segment (:conc-name seg-) - (:constructor %make-segment) - (:copier nil)) - (sap-maker (required-argument) - :type (function () sb!sys:system-area-pointer)) - (length 0 :type length) + (:constructor %make-segment) + (:copier nil)) + (sap-maker (missing-arg) + :type (function () sb!sys:system-area-pointer)) + (length 0 :type disassem-length) (virtual-location 0 :type address) (storage-info nil :type (or null storage-info)) (code nil :type (or null sb!kernel:code-component)) @@ -268,90 +269,30 @@ (def!method print-object ((seg segment) stream) (print-unreadable-object (seg stream :type t) (let ((addr (sb!sys:sap-int (funcall (seg-sap-maker seg))))) - (format stream "#X~X[~D]~:[ (#X~X)~;~*~]~@[ in ~S~]" - addr - (seg-length seg) - (= (seg-virtual-location seg) addr) - (seg-virtual-location seg) - (seg-code seg))))) - -;;; All state during disassembly. We store some seemingly redundant -;;; information so that we can allow garbage collect during disassembly and -;;; not get tripped up by a code block being moved... -(defstruct (disassem-state (:conc-name dstate-) - (:constructor %make-dstate) - (:copier nil)) - (cur-offs 0 :type offset) ; offset of current pos in segment - (next-offs 0 :type offset) ; offset of next position - - (segment-sap (required-argument) :type sb!sys:system-area-pointer) - ; a sap pointing to our segment - (segment nil :type (or null segment)) ; the current segment - - (alignment sb!vm:word-bytes :type alignment) ; what to align to in most cases - (byte-order :little-endian - :type (member :big-endian :little-endian)) - - (properties nil :type list) ; for user code to hang stuff off of - (filtered-values (make-array max-filtered-value-index) - :type filtered-value-vector) - - (addr-print-len nil :type ; used for prettifying printing - (or null (integer 0 20))) - (argument-column 0 :type column) - (output-state :beginning ; to make output look nicer - :type (member :beginning - :block-boundary - nil)) - - (labels nil :type list) ; alist of (address . label-number) - (label-hash (make-hash-table) ; same thing in a different form - :type hash-table) - - (fun-hooks nil :type list) ; list of function - - ;; these next two are popped as they are used - (cur-labels nil :type list) ; alist of (address . label-number) - (cur-offs-hooks nil :type list) ; list of offs-hook - - (notes nil :type list) ; for the current location - - (current-valid-locations nil ; currently active source variables - :type (or null (vector bit)))) -(def!method print-object ((dstate disassem-state) stream) - (print-unreadable-object (dstate stream :type t) - (format stream - "+~D~@[ in ~S~]" - (dstate-cur-offs dstate) - (dstate-segment dstate)))) - -;;; Return the absolute address of the current instruction in DSTATE. -(defun dstate-cur-addr (dstate) - (the address (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate)))) - -;;; Return the absolute address of the next instruction in DSTATE. -(defun dstate-next-addr (dstate) - (the address (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-next-offs dstate)))) + (format stream "#X~X[~W]~:[ (#X~X)~;~*~]~@[ in ~S~]" + addr + (seg-length seg) + (= (seg-virtual-location seg) addr) + (seg-virtual-location seg) + (seg-code seg))))) ;;;; function ops (defun fun-self (fun) (declare (type compiled-function fun)) - (sb!kernel:%function-self fun)) + (sb!kernel:%simple-fun-self (sb!kernel:%fun-fun fun))) (defun fun-code (fun) (declare (type compiled-function fun)) - (sb!kernel:function-code-header (fun-self fun))) + (sb!kernel:fun-code-header (fun-self fun))) (defun fun-next (fun) (declare (type compiled-function fun)) - (sb!kernel:%function-next fun)) + (sb!kernel:%simple-fun-next (sb!kernel:%fun-fun fun))) -(defun fun-address (function) - (declare (type compiled-function function)) - (- (sb!kernel:get-lisp-obj-address function) sb!vm:function-pointer-type)) +(defun fun-address (fun) + (declare (type compiled-function 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 @@ -372,234 +313,302 @@ (defun code-inst-area-length (code-component) (declare (type sb!kernel:code-component code-component)) (sb!kernel:code-header-ref code-component - sb!vm:code-trace-table-offset-slot)) + sb!vm:code-trace-table-offset-slot)) ;;; Return the address of the instruction area in CODE-COMPONENT. (defun code-inst-area-address (code-component) (declare (type sb!kernel:code-component code-component)) (sb!sys:sap-int (sb!kernel:code-instructions code-component))) +;;; unused as of sbcl-0.pre7.129 +#| ;;; Return the first function in CODE-COMPONENT. (defun code-first-function (code-component) (declare (type sb!kernel:code-component code-component)) (sb!kernel:code-header-ref code-component - sb!vm:code-trace-table-offset-slot)) + sb!vm:code-trace-table-offset-slot)) +|# (defun segment-offs-to-code-offs (offset segment) (sb!sys:without-gcing (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment)))) - (code-addr - (logandc1 sb!vm:lowtag-mask - (sb!kernel:get-lisp-obj-address (seg-code segment)))) - (addr (+ offset seg-base-addr))) + (code-addr + (logandc1 sb!vm:lowtag-mask + (sb!kernel:get-lisp-obj-address (seg-code segment)))) + (addr (+ offset seg-base-addr))) (declare (type address seg-base-addr code-addr addr)) (- addr code-addr)))) (defun code-offs-to-segment-offs (offset segment) (sb!sys:without-gcing (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment)))) - (code-addr - (logandc1 sb!vm:lowtag-mask - (sb!kernel:get-lisp-obj-address (seg-code segment)))) - (addr (+ offset code-addr))) + (code-addr + (logandc1 sb!vm:lowtag-mask + (sb!kernel:get-lisp-obj-address (seg-code segment)))) + (addr (+ offset code-addr))) (declare (type address seg-base-addr code-addr addr)) (- addr seg-base-addr)))) (defun code-insts-offs-to-segment-offs (offset segment) (sb!sys:without-gcing (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment)))) - (code-insts-addr - (sb!sys:sap-int (sb!kernel:code-instructions (seg-code segment)))) - (addr (+ offset code-insts-addr))) + (code-insts-addr + (sb!sys:sap-int (sb!kernel:code-instructions (seg-code segment)))) + (addr (+ offset code-insts-addr))) (declare (type address seg-base-addr code-insts-addr addr)) (- addr seg-base-addr)))) (defun lra-hook (chunk stream dstate) (declare (type dchunk chunk) - (ignore chunk) - (type (or null stream) stream) - (type disassem-state dstate)) + (ignore chunk) + (type (or null stream) stream) + (type disassem-state dstate)) (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate)) - (* 2 sb!vm:word-bytes)) - ;; Check type. - (= (sb!sys:sap-ref-8 (dstate-segment-sap dstate) - (if (eq (dstate-byte-order dstate) - :little-endian) - (dstate-cur-offs dstate) - (+ (dstate-cur-offs dstate) - (1- lra-size)))) - sb!vm:return-pc-header-type)) + (dstate-cur-offs dstate)) + (* 2 sb!vm:n-word-bytes)) + ;; Check type. + (= (sb!sys:sap-ref-8 (dstate-segment-sap dstate) + (if (eq (dstate-byte-order dstate) + :little-endian) + (dstate-cur-offs dstate) + (+ (dstate-cur-offs dstate) + (1- lra-size)))) + sb!vm:return-pc-header-widetag)) (unless (null stream) - (princ '.lra stream)) - (incf (dstate-next-offs dstate) lra-size)) + (note "possible LRA header" dstate))) nil) -;;; Print the function-header (entry-point) pseudo-instruction at the +;;; Print the fun-header (entry-point) pseudo-instruction at the ;;; current location in DSTATE to STREAM. (defun fun-header-hook (stream dstate) (declare (type (or null stream) stream) - (type disassem-state dstate)) + (type disassem-state dstate)) (unless (null stream) (let* ((seg (dstate-segment dstate)) - (code (seg-code seg)) - (woffs - (bytes-to-words - (segment-offs-to-code-offs (dstate-cur-offs dstate) seg))) - (name - (sb!kernel:code-header-ref code - (+ woffs sb!vm:function-name-slot))) - (args - (sb!kernel:code-header-ref code - (+ woffs sb!vm:function-arglist-slot))) - (type - (sb!kernel:code-header-ref code - (+ woffs sb!vm:function-type-slot)))) + (code (seg-code seg)) + (woffs + (bytes-to-words + (segment-offs-to-code-offs (dstate-cur-offs dstate) seg))) + (name + (sb!kernel:code-header-ref code + (+ woffs + sb!vm:simple-fun-name-slot))) + (args + (sb!kernel:code-header-ref code + (+ woffs + sb!vm:simple-fun-arglist-slot))) + (type + (sb!kernel:code-header-ref code + (+ woffs + sb!vm:simple-fun-type-slot)))) (format stream ".~A ~S~:A" 'entry name args) (note (lambda (stream) - (format stream "~:S" type)) ; use format to print NIL as () - dstate))) + (format stream "~:S" type)) ; use format to print NIL as () + dstate))) (incf (dstate-next-offs dstate) - (words-to-bytes sb!vm:function-code-offset))) + (words-to-bytes sb!vm:simple-fun-code-offset))) (defun alignment-hook (chunk stream dstate) (declare (type dchunk chunk) - (ignore chunk) - (type (or null stream) stream) - (type disassem-state dstate)) + (ignore chunk) + (type (or null stream) stream) + (type disassem-state dstate)) (let ((location - (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate))) - (alignment (dstate-alignment dstate))) + (+ (seg-virtual-location (dstate-segment dstate)) + (dstate-cur-offs dstate))) + (alignment (dstate-alignment dstate))) (unless (aligned-p location alignment) (when stream - (format stream "~A~Vt~D~%" '.align - (dstate-argument-column dstate) - alignment)) - (incf(dstate-next-offs dstate) - (- (align location alignment) location))) + (format stream "~A~Vt~W~%" '.align + (dstate-argument-column dstate) + alignment)) + (incf (dstate-next-offs dstate) + (- (align location alignment) location))) nil)) (defun rewind-current-segment (dstate segment) (declare (type disassem-state dstate) - (type segment segment)) + (type segment segment)) (setf (dstate-segment dstate) segment) (setf (dstate-cur-offs-hooks dstate) - (stable-sort (nreverse (copy-list (seg-hooks segment))) - (lambda (oh1 oh2) - (or (< (offs-hook-offset oh1) (offs-hook-offset oh2)) - (and (= (offs-hook-offset oh1) - (offs-hook-offset oh2)) - (offs-hook-before-address oh1) - (not (offs-hook-before-address oh2))))))) + (stable-sort (nreverse (copy-list (seg-hooks segment))) + (lambda (oh1 oh2) + (or (< (offs-hook-offset oh1) (offs-hook-offset oh2)) + (and (= (offs-hook-offset oh1) + (offs-hook-offset oh2)) + (offs-hook-before-address oh1) + (not (offs-hook-before-address oh2))))))) (setf (dstate-cur-offs dstate) 0) (setf (dstate-cur-labels dstate) (dstate-labels dstate))) -(defun do-offs-hooks (before-address stream dstate) +(defun call-offs-hooks (before-address stream dstate) (declare (type (or null stream) stream) - (type disassem-state dstate)) + (type disassem-state dstate)) (let ((cur-offs (dstate-cur-offs dstate))) (setf (dstate-next-offs dstate) cur-offs) (loop (let ((next-hook (car (dstate-cur-offs-hooks dstate)))) - (when (null next-hook) - (return)) - (let ((hook-offs (offs-hook-offset next-hook))) - (when (or (> hook-offs cur-offs) - (and (= hook-offs cur-offs) - before-address - (not (offs-hook-before-address next-hook)))) - (return)) - (unless (< hook-offs cur-offs) - (funcall (offs-hook-function next-hook) stream dstate)) - (pop (dstate-cur-offs-hooks dstate)) - (unless (= (dstate-next-offs dstate) cur-offs) - (return))))))) - -(defun do-fun-hooks (chunk stream dstate) + (when (null next-hook) + (return)) + (let ((hook-offs (offs-hook-offset next-hook))) + (when (or (> hook-offs cur-offs) + (and (= hook-offs cur-offs) + before-address + (not (offs-hook-before-address next-hook)))) + (return)) + (unless (< hook-offs cur-offs) + (funcall (offs-hook-fun next-hook) stream dstate)) + (pop (dstate-cur-offs-hooks dstate)) + (unless (= (dstate-next-offs dstate) cur-offs) + (return))))))) + +(defun call-fun-hooks (chunk stream dstate) (let ((hooks (dstate-fun-hooks dstate)) - (cur-offs (dstate-cur-offs dstate))) + (cur-offs (dstate-cur-offs dstate))) (setf (dstate-next-offs dstate) cur-offs) (dolist (hook hooks nil) (let ((prefix-p (funcall hook chunk stream dstate))) - (unless (= (dstate-next-offs dstate) cur-offs) - (return prefix-p)))))) + (unless (= (dstate-next-offs dstate) cur-offs) + (return prefix-p)))))) + +;;; 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)) + (when (> *disassem-inst-column-width* 0) + (dotimes (i (- *disassem-inst-column-width* (* 2 n-bytes))) + (write-char #\space stream)) + (write-char #\space stream))) -(defun handle-bogus-instruction (stream dstate) +(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:word-bytes) - (when (> words 0) - (print-words words stream dstate)) - (when (> bytes 0) - (print-bytes bytes stream dstate)))) + (truncate alignment sb!vm:n-word-bytes) + (when (> words 0) + (print-inst (* words sb!vm:n-word-bytes) stream dstate + :trailing-space nil)) + (when (> bytes 0) + (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) - (type disassem-state dstate) - (type (or null stream) stream)) + (type segment segment) + (type disassem-state 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) ; sum of lengths of any prefix instruction(s) + (prefix-print-names nil)) ; reverse list of prefixes seen (rewind-current-segment dstate segment) (loop (when (>= (dstate-cur-offs dstate) - (seg-length (dstate-segment dstate))) - ;; done! - (return)) + (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)) - (do-offs-hooks t stream dstate) + (call-offs-hooks t stream dstate) (unless (or prefix-p (null stream)) - (print-current-address stream dstate)) - (do-offs-hooks nil stream dstate) + (print-current-address stream dstate)) + (call-offs-hooks nil stream dstate) (unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) - (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 (do-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)) - (t - (setf (dstate-next-offs dstate) - (+ (dstate-cur-offs dstate) - (inst-length inst))) - - (let ((prefilter (inst-prefilter inst)) - (control (inst-control inst))) - (when prefilter - (funcall prefilter chunk dstate)) - - (funcall function chunk inst) - - (setf prefix-p (null (inst-printer inst))) - - (when control - (funcall control chunk inst stream dstate)))))) - ))))) + (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))) + (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 prefix-len) + (setf prefix-p nil)) + (t + (setf (dstate-next-offs dstate) + (+ (dstate-cur-offs dstate) + (inst-length inst))) + (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) - (unless prefix-p - (print-notes-and-newline stream dstate)) - (setf (dstate-output-state dstate) nil))))) + (when stream + (unless prefix-p + (setf prefix-len 0 + prefix-print-names nil) + (print-notes-and-newline stream dstate)) + (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 @@ -613,8 +622,8 @@ (lambda (chunk inst) (declare (type dchunk chunk) (type instruction inst)) (let ((labeller (inst-labeller inst))) - (when labeller - (setf labels (funcall labeller chunk labels dstate))))) + (when labeller + (setf labels (funcall labeller chunk labels dstate))))) segment dstate) (setf (dstate-labels dstate) labels) @@ -630,16 +639,16 @@ ;; at least one label left un-numbered (setf labels (sort labels #'< :key #'car)) (let ((max -1) - (label-hash (dstate-label-hash dstate))) - (dolist (label labels) - (when (not (null (cdr label))) - (setf max (max max (cdr label))))) - (dolist (label labels) - (when (null (cdr label)) - (incf max) - (setf (cdr label) max) - (setf (gethash (car label) label-hash) - (format nil "L~D" max))))) + (label-hash (dstate-label-hash dstate))) + (dolist (label labels) + (when (not (null (cdr label))) + (setf max (max max (cdr label))))) + (dolist (label labels) + (when (null (cdr label)) + (incf max) + (setf (cdr label) max) + (setf (gethash (car label) label-hash) + (format nil "L~W" max))))) (setf (dstate-labels dstate) labels)))) ;;; Get the instruction-space, creating it if necessary. @@ -647,12 +656,12 @@ (let ((ispace *disassem-inst-space*)) (when (null ispace) (let ((insts nil)) - (maphash (lambda (name inst-flavs) - (declare (ignore name)) - (dolist (flav inst-flavs) - (push flav insts))) - *disassem-insts*) - (setf ispace (build-inst-space insts))) + (maphash (lambda (name inst-flavs) + (declare (ignore name)) + (dolist (flav inst-flavs) + (push flav insts))) + *disassem-insts*) + (setf ispace (build-inst-space insts))) (setf *disassem-inst-space* ispace)) ispace)) @@ -661,58 +670,58 @@ (defun add-offs-hook (segment addr hook) (let ((entry (cons addr hook))) (if (null (seg-hooks segment)) - (setf (seg-hooks segment) (list entry)) - (push entry (cdr (last (seg-hooks segment))))))) + (setf (seg-hooks segment) (list entry)) + (push entry (cdr (last (seg-hooks segment))))))) (defun add-offs-note-hook (segment addr note) (add-offs-hook segment - addr - (lambda (stream dstate) - (declare (type (or null stream) stream) - (type disassem-state dstate)) - (when stream - (note note dstate))))) + addr + (lambda (stream dstate) + (declare (type (or null stream) stream) + (type disassem-state dstate)) + (when stream + (note note dstate))))) (defun add-offs-comment-hook (segment addr comment) (add-offs-hook segment - addr - (lambda (stream dstate) - (declare (type (or null stream) stream) - (ignore dstate)) - (when stream - (write-string ";;; " stream) - (etypecase comment - (string - (write-string comment stream)) - (function - (funcall comment stream))) - (terpri stream))))) + addr + (lambda (stream dstate) + (declare (type (or null stream) stream) + (ignore dstate)) + (when stream + (write-string ";;; " stream) + (etypecase comment + (string + (write-string comment stream)) + (function + (funcall comment stream))) + (terpri stream))))) (defun add-fun-hook (dstate function) (push function (dstate-fun-hooks dstate))) (defun set-location-printing-range (dstate from length) (setf (dstate-addr-print-len dstate) - ;; 4 bits per hex digit - (ceiling (integer-length (logxor from (+ from length))) 4))) + ;; 4 bits per hex digit + (ceiling (integer-length (logxor from (+ from length))) 4))) ;;; Print the current address in DSTATE to STREAM, plus any labels that ;;; correspond to it, and leave the cursor in the instruction column. (defun print-current-address (stream dstate) (declare (type stream stream) - (type disassem-state dstate)) + (type disassem-state dstate)) (let* ((location - (+ (seg-virtual-location (dstate-segment dstate)) - (dstate-cur-offs dstate))) - (location-column-width *disassem-location-column-width*) - (plen (dstate-addr-print-len dstate))) + (+ (seg-virtual-location (dstate-segment dstate)) + (dstate-cur-offs dstate))) + (location-column-width *disassem-location-column-width*) + (plen (dstate-addr-print-len dstate))) (when (null plen) (setf plen location-column-width) (let ((seg (dstate-segment dstate))) - (set-location-printing-range dstate - (seg-virtual-location seg) - (seg-length seg)))) + (set-location-printing-range dstate + (seg-virtual-location seg) + (seg-length seg)))) (when (eq (dstate-output-state dstate) :beginning) (setf plen location-column-width)) @@ -726,24 +735,24 @@ ;; usually avoids any consing] (tab0 (- location-column-width plen) stream) (let* ((printed-bits (* 4 plen)) - (printed-value (ldb (byte printed-bits 0) location)) - (leading-zeros - (truncate (- printed-bits (integer-length printed-value)) 4))) + (printed-value (ldb (byte printed-bits 0) location)) + (leading-zeros + (truncate (- printed-bits (integer-length printed-value)) 4))) (dotimes (i leading-zeros) - (write-char #\0 stream)) + (write-char #\0 stream)) (unless (zerop printed-value) - (write printed-value :stream stream :base 16 :radix nil)) + (write printed-value :stream stream :base 16 :radix nil)) (write-char #\: stream)) ;; print any labels (loop (let* ((next-label (car (dstate-cur-labels dstate))) - (label-location (car next-label))) - (when (or (null label-location) (> label-location location)) - (return)) - (unless (< label-location location) - (format stream " L~D:" (cdr next-label))) - (pop (dstate-cur-labels dstate)))) + (label-location (car next-label))) + (when (or (null label-location) (> label-location location)) + (return)) + (unless (< label-location location) + (format stream " L~W:" (cdr next-label))) + (pop (dstate-cur-labels dstate)))) ;; move to the instruction column (tab0 (+ location-column-width 1 label-column-width) stream) @@ -752,9 +761,9 @@ (eval-when (:compile-toplevel :execute) (sb!xc:defmacro with-print-restrictions (&rest body) `(let ((*print-pretty* t) - (*print-lines* 2) - (*print-length* 4) - (*print-level* 3)) + (*print-lines* 2) + (*print-length* 4) + (*print-level* 3)) ,@body))) ;;; Print a newline to STREAM, inserting any pending notes in DSTATE @@ -762,128 +771,138 @@ ;;; separate line will be used for each one. (defun print-notes-and-newline (stream dstate) (declare (type stream stream) - (type disassem-state dstate)) + (type disassem-state dstate)) (with-print-restrictions (dolist (note (dstate-notes dstate)) (format stream "~Vt " *disassem-note-column*) (pprint-logical-block (stream nil :per-line-prefix "; ") (etypecase note - (string - (write-string note stream)) - (function - (funcall note stream)))) + (string + (write-string note stream)) + (function + (funcall note stream)))) (terpri stream)) (fresh-line stream) (setf (dstate-notes dstate) nil))) +;;; Print NUM instruction bytes to STREAM as hex values. +(defun print-inst (num stream dstate &key (offset 0) (trailing-space t)) + (when (> *disassem-inst-column-width* 0) + (let ((sap (dstate-segment-sap dstate)) + (start-offs (+ offset (dstate-cur-offs dstate)))) + (dotimes (offs num) + (format stream "~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs)))) + (when trailing-space + (pad-inst-column stream num))))) + ;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions. (defun print-bytes (num stream dstate) (declare (type offset num) - (type stream stream) - (type disassem-state dstate)) + (type stream stream) + (type disassem-state dstate)) (format stream "~A~Vt" 'BYTE (dstate-argument-column dstate)) (let ((sap (dstate-segment-sap dstate)) - (start-offs (dstate-cur-offs dstate))) + (start-offs (dstate-cur-offs dstate))) (dotimes (offs num) (unless (zerop offs) - (write-string ", " stream)) + (write-string ", " stream)) (format stream "#X~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs)))))) ;;; Disassemble NUM machine-words to STREAM as simple `WORD' instructions. (defun print-words (num stream dstate) (declare (type offset num) - (type stream stream) - (type disassem-state dstate)) + (type stream stream) + (type disassem-state dstate)) (format stream "~A~Vt" 'WORD (dstate-argument-column dstate)) (let ((sap (dstate-segment-sap dstate)) - (start-offs (dstate-cur-offs dstate)) - (byte-order (dstate-byte-order dstate))) + (start-offs (dstate-cur-offs dstate)) + (byte-order (dstate-byte-order dstate))) (dotimes (word-offs num) (unless (zerop word-offs) - (write-string ", " stream)) + (write-string ", " stream)) (let ((word 0) (bit-shift 0)) - (dotimes (byte-offs sb!vm:word-bytes) - (let ((byte - (sb!sys:sap-ref-8 - sap - (+ start-offs - (* word-offs sb!vm:word-bytes) - byte-offs)))) - (setf word - (if (eq byte-order :big-endian) - (+ (ash word sb!vm:byte-bits) byte) - (+ word (ash byte bit-shift)))) - (incf bit-shift sb!vm:byte-bits))) - (format stream "#X~V,'0X" (ash sb!vm:word-bits -2) word))))) + (dotimes (byte-offs sb!vm:n-word-bytes) + (let ((byte + (sb!sys:sap-ref-8 + sap + (+ start-offs + (* word-offs sb!vm:n-word-bytes) + byte-offs)))) + (setf word + (if (eq byte-order :big-endian) + (+ (ash word sb!vm:n-byte-bits) byte) + (+ word (ash byte bit-shift)))) + (incf bit-shift sb!vm:n-byte-bits))) + (format stream "#X~V,'0X" (ash sb!vm:n-word-bits -2) word))))) (defvar *default-dstate-hooks* (list #'lra-hook)) ;;; 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*) - (arg-column - (+ (or *disassem-opcode-column-width* 0) - *disassem-location-column-width* - 1 - label-column-width))) + (let ((alignment *disassem-inst-alignment-bytes*) + (arg-column + (+ 2 + *disassem-location-column-width* + 1 + label-column-width + *disassem-inst-column-width* + (if (zerop *disassem-inst-column-width*) 0 1) + *disassem-opcode-column-width*))) (when (> alignment 1) (push #'alignment-hook fun-hooks)) - (%make-dstate :segment-sap sap - :fun-hooks fun-hooks - :argument-column arg-column - :alignment alignment - :byte-order sb!c:*backend-byte-order*))) + (%make-dstate :fun-hooks fun-hooks + :argument-column arg-column + :alignment alignment + :byte-order sb!c:*backend-byte-order*))) (defun add-fun-header-hooks (segment) (declare (type segment segment)) (do ((fun (sb!kernel:code-header-ref (seg-code segment) - sb!vm:code-entry-points-slot) - (fun-next fun)) + sb!vm:code-entry-points-slot) + (fun-next fun)) (length (seg-length segment))) ((null fun)) (let ((offset (code-offs-to-segment-offs (fun-offset fun) segment))) (when (<= 0 offset length) - (push (make-offs-hook :offset offset :function #'fun-header-hook) - (seg-hooks segment)))))) + (push (make-offs-hook :offset offset :fun #'fun-header-hook) + (seg-hooks segment)))))) ;;; 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) - (type offset offset)) + (type (function (t) sb!sys:system-area-pointer) function) + (type offset offset)) (let ((old-sap (sb!sys:sap+ (funcall function input) offset))) (declare (type sb!sys:system-area-pointer old-sap)) (lambda () (let ((new-addr - (+ (sb!sys:sap-int (funcall function input)) offset))) - ;; Saving the sap like this avoids consing except when the sap - ;; changes (because the sap-int, arith, etc., get inlined). - (declare (type address new-addr)) - (if (= (sb!sys:sap-int old-sap) new-addr) - old-sap - (setf old-sap (sb!sys:int-sap new-addr))))))) + (+ (sb!sys:sap-int (funcall function input)) offset))) + ;; Saving the sap like this avoids consing except when the sap + ;; changes (because the sap-int, arith, etc., get inlined). + (declare (type address new-addr)) + (if (= (sb!sys:sap-int old-sap) new-addr) + old-sap + (setf old-sap (sb!sys:int-sap new-addr))))))) (defun vector-sap-maker (vector offset) (declare (optimize (speed 3)) - (type offset offset)) + (type offset offset)) (sap-maker #'sb!sys:vector-sap vector offset)) (defun code-sap-maker (code offset) (declare (optimize (speed 3)) - (type sb!kernel:code-component code) - (type offset offset)) + (type sb!kernel:code-component code) + (type offset offset)) (sap-maker #'sb!kernel:code-instructions code offset)) (defun memory-sap-maker (address) (declare (optimize (speed 3)) - (type address address)) + (type address address)) (let ((sap (sb!sys:int-sap address))) (lambda () sap))) @@ -895,188 +914,113 @@ ;;; SOURCE-FORM-CACHE object), and :HOOKS (a list of OFFS-HOOK ;;; objects). (defun make-segment (sap-maker length - &key - code virtual-location - debug-fun source-form-cache - hooks) + &key + code virtual-location + debug-fun source-form-cache + hooks) (declare (type (function () sb!sys:system-area-pointer) sap-maker) - (type length length) - (type (or null address) virtual-location) - (type (or null sb!di:debug-fun) debug-fun) - (type (or null source-form-cache) source-form-cache)) + (type disassem-length length) + (type (or null address) virtual-location) + (type (or null sb!di:debug-fun) debug-fun) + (type (or null source-form-cache) source-form-cache)) (let* ((segment - (%make-segment - :sap-maker sap-maker - :length length - :virtual-location (or virtual-location - (sb!sys:sap-int (funcall sap-maker))) - :hooks hooks - :code code))) + (%make-segment + :sap-maker sap-maker + :length length + :virtual-location (or virtual-location + (sb!sys:sap-int (funcall sap-maker))) + :hooks hooks + :code code))) (add-debugging-hooks segment debug-fun source-form-cache) (add-fun-header-hooks segment) segment)) (defun make-vector-segment (vector offset &rest args) (declare (type vector vector) - (type offset offset) - (inline make-segment)) + (type offset offset) + (inline make-segment)) (apply #'make-segment (vector-sap-maker vector offset) args)) (defun make-code-segment (code offset length &rest args) (declare (type sb!kernel:code-component code) - (type offset offset) - (inline make-segment)) + (type offset offset) + (inline make-segment)) (apply #'make-segment (code-sap-maker code offset) length :code code args)) (defun make-memory-segment (address &rest args) (declare (type address address) - (inline make-segment)) + (inline make-segment)) (apply #'make-segment (memory-sap-maker address) args)) ;;; just for fun (defun print-fun-headers (function) (declare (type compiled-function function)) (let* ((self (fun-self function)) - (code (sb!kernel:function-code-header self))) + (code (sb!kernel:fun-code-header self))) (format t "Code-header ~S: size: ~S, trace-table-offset: ~S~%" - code - (sb!kernel:code-header-ref code - sb!vm:code-code-size-slot) - (sb!kernel:code-header-ref code - sb!vm:code-trace-table-offset-slot)) + code + (sb!kernel:code-header-ref code + sb!vm:code-code-size-slot) + (sb!kernel:code-header-ref code + sb!vm:code-trace-table-offset-slot)) (do ((fun (sb!kernel:code-header-ref code sb!vm:code-entry-points-slot) - (fun-next fun))) - ((null fun)) + (fun-next fun))) + ((null fun)) (let ((fun-offset (sb!kernel:get-closure-length fun))) - ;; There is function header fun-offset words from the - ;; code header. - (format t "Fun-header ~S at offset ~D (words): ~S~A => ~S~%" - fun - fun-offset - (sb!kernel:code-header-ref - code (+ fun-offset sb!vm:function-name-slot)) - (sb!kernel:code-header-ref - code (+ fun-offset sb!vm:function-arglist-slot)) - (sb!kernel:code-header-ref - code (+ fun-offset sb!vm:function-type-slot))))))) + ;; There is function header fun-offset words from the + ;; code header. + (format t "Fun-header ~S at offset ~W (words): ~S~A => ~S~%" + fun + fun-offset + (sb!kernel:code-header-ref + code (+ fun-offset sb!vm:simple-fun-name-slot)) + (sb!kernel:code-header-ref + code (+ fun-offset sb!vm:simple-fun-arglist-slot)) + (sb!kernel:code-header-ref + code (+ fun-offset sb!vm:simple-fun-type-slot))))))) ;;; getting at the source code... (defstruct (source-form-cache (:conc-name sfcache-) - (:copier nil)) + (:copier nil)) (debug-source nil :type (or null sb!di:debug-source)) - (top-level-form-index -1 :type fixnum) - (top-level-form nil :type list) - (form-number-mapping-table nil :type (or null (vector list))) + (toplevel-form-index -1 :type fixnum) (last-location-retrieved nil :type (or null sb!di:code-location)) (last-form-retrieved -1 :type fixnum)) -(defun get-top-level-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) - nil) - (t - (let ((start-positions - (sb!di:debug-source-start-positions debug-source))) - (cond ((null start-positions) - (warn "There is no start positions map.") - nil) - (t - (let* ((local-tlf-index - (- tlf-index - (sb!di:debug-source-root-number - debug-source))) - (char-offset - (aref start-positions local-tlf-index))) - (with-open-file (f name) - (cond ((= (sb!di:debug-source-created debug-source) - (file-write-date name)) - (file-position f char-offset)) - (t - (warn "Source file ~S has been modified; ~@ - using form offset instead of file index." - name) - (let ((*read-suppress* t)) - (dotimes (i local-tlf-index) (read f))))) - (let ((*readtable* (copy-readtable))) - (set-dispatch-macro-character - #\# #\. - (lambda (stream sub-char &rest rest) - (declare (ignore rest sub-char)) - (let ((token (read stream t nil t))) - (format nil "#.~S" token)))) - (read f)) - )))))))) - (:lisp - (aref name tlf-index))))) - -(defun cache-valid (loc cache) - (and cache - (and (eq (sb!di:code-location-debug-source loc) - (sfcache-debug-source cache)) - (eq (sb!di:code-location-top-level-form-offset loc) - (sfcache-top-level-form-index cache))))) - -(defun get-source-form (loc context &optional cache) - (let* ((cache-valid (cache-valid loc cache)) - (tlf-index (sb!di:code-location-top-level-form-offset loc)) - (form-number (sb!di:code-location-form-number loc)) - (top-level-form - (if cache-valid - (sfcache-top-level-form cache) - (get-top-level-form (sb!di:code-location-debug-source loc) - tlf-index))) - (mapping-table - (if cache-valid - (sfcache-form-number-mapping-table cache) - (sb!di:form-number-translations top-level-form tlf-index)))) - (when (and (not cache-valid) cache) - (setf (sfcache-debug-source cache) (sb!di:code-location-debug-source loc) - (sfcache-top-level-form-index cache) tlf-index - (sfcache-top-level-form cache) top-level-form - (sfcache-form-number-mapping-table cache) mapping-table)) - (cond ((null top-level-form) - nil) - ((> 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 - ;; Disable future warnings. - (setf (sfcache-top-level-form cache) nil)) - nil) - (t - (when cache - (setf (sfcache-last-location-retrieved cache) loc) - (setf (sfcache-last-form-retrieved cache) form-number)) - (sb!di:source-path-context top-level-form - (aref mapping-table form-number) - context))))) - (defun get-different-source-form (loc context &optional cache) - (if (and (cache-valid loc cache) - (or (= (sb!di:code-location-form-number loc) - (sfcache-last-form-retrieved cache)) - (and (sfcache-last-location-retrieved cache) - (sb!di:code-location= - loc - (sfcache-last-location-retrieved cache))))) + (if (and cache + (eq (sb!di:code-location-debug-source loc) + (sfcache-debug-source cache)) + (eq (sb!di:code-location-toplevel-form-offset loc) + (sfcache-toplevel-form-index cache)) + (or (eql (sb!di:code-location-form-number loc) + (sfcache-last-form-retrieved cache)) + (awhen (sfcache-last-location-retrieved cache) + (sb!di:code-location= loc it)))) (values nil nil) - (values (get-source-form loc context cache) t))) + (let ((form (sb!debug::code-location-source-form loc context nil))) + (when cache + (setf (sfcache-debug-source cache) + (sb!di:code-location-debug-source loc)) + (setf (sfcache-toplevel-form-index cache) + (sb!di:code-location-toplevel-form-offset loc)) + (setf (sfcache-last-form-retrieved cache) + (sb!di:code-location-form-number loc)) + (setf (sfcache-last-location-retrieved cache) loc)) + (values form t)))) -;;;; stuff to use debugging-info to augment the disassembly +;;;; stuff to use debugging info to augment the disassembly (defun code-fun-map (code) (declare (type sb!kernel:code-component code)) - (sb!di::get-debug-info-fun-map (sb!kernel:%code-debug-info code))) + (sb!c::compiled-debug-info-fun-map (sb!kernel:%code-debug-info code))) (defstruct (location-group (:copier nil)) (locations #() :type (vector (or list fixnum)))) (defstruct (storage-info (:copier nil)) - (groups nil :type list) ; alist of (name . location-group) + (groups nil :type list) ; alist of (name . location-group) (debug-vars #() :type vector)) ;;; Return the vector of DEBUG-VARs currently associated with DSTATE. @@ -1090,55 +1034,55 @@ ;;; in the current debug-var vector. (defun find-valid-storage-location (offset lg-name dstate) (declare (type offset offset) - (type symbol lg-name) - (type disassem-state dstate)) + (type symbol lg-name) + (type disassem-state dstate)) (let* ((storage-info - (seg-storage-info (dstate-segment dstate))) - (location-group - (and storage-info - (cdr (assoc lg-name (storage-info-groups storage-info))))) - (currently-valid - (dstate-current-valid-locations dstate))) + (seg-storage-info (dstate-segment dstate))) + (location-group + (and storage-info + (cdr (assoc lg-name (storage-info-groups storage-info))))) + (currently-valid + (dstate-current-valid-locations dstate))) (and location-group - (not (null currently-valid)) - (let ((locations (location-group-locations location-group))) - (and (< offset (length locations)) - (let ((used-by (aref locations offset))) - (and used-by - (let ((debug-var-num - (typecase used-by - (fixnum - (and (not - (zerop (bit currently-valid used-by))) - used-by)) - (list - (some (lambda (num) - (and (not - (zerop - (bit currently-valid num))) - num)) - used-by))))) - (and debug-var-num - (progn - ;; Found a valid storage reference! - ;; can't use it again until it's revalidated... - (setf (bit (dstate-current-valid-locations - dstate) - debug-var-num) - 0) - debug-var-num)) - )))))))) + (not (null currently-valid)) + (let ((locations (location-group-locations location-group))) + (and (< offset (length locations)) + (let ((used-by (aref locations offset))) + (and used-by + (let ((debug-var-num + (typecase used-by + (fixnum + (and (not + (zerop (bit currently-valid used-by))) + used-by)) + (list + (some (lambda (num) + (and (not + (zerop + (bit currently-valid num))) + num)) + used-by))))) + (and debug-var-num + (progn + ;; Found a valid storage reference! + ;; can't use it again until it's revalidated... + (setf (bit (dstate-current-valid-locations + dstate) + debug-var-num) + 0) + debug-var-num)) + )))))))) ;;; Return a new vector which has the same contents as the old one ;;; VEC, plus new cells (for a total size of NEW-LEN). The additional ;;; elements are initialized to INITIAL-ELEMENT. (defun grow-vector (vec new-len &optional initial-element) (declare (type vector vec) - (type fixnum new-len)) + (type fixnum new-len)) (let ((new - (make-sequence `(vector ,(array-element-type vec) ,new-len) - new-len - :initial-element initial-element))) + (make-sequence `(vector ,(array-element-type vec) ,new-len) + new-len + :initial-element initial-element))) (dotimes (i (length vec)) (setf (aref new i) (aref vec i))) new)) @@ -1148,328 +1092,314 @@ (defun storage-info-for-debug-fun (debug-fun) (declare (type sb!di:debug-fun debug-fun)) (let ((sc-vec sb!c::*backend-sc-numbers*) - (groups nil) - (debug-vars (sb!di::debug-fun-debug-vars - debug-fun))) + (groups nil) + (debug-vars (sb!di::debug-fun-debug-vars + debug-fun))) (and debug-vars - (dotimes (debug-var-offset - (length debug-vars) - (make-storage-info :groups groups - :debug-vars debug-vars)) - (let ((debug-var (aref debug-vars debug-var-offset))) - #+nil - (format t ";;; At offset ~D: ~S~%" debug-var-offset debug-var) - (let* ((sc-offset - (sb!di::compiled-debug-var-sc-offset debug-var)) - (sb-name - (sb!c:sb-name - (sb!c:sc-sb (aref sc-vec - (sb!c:sc-offset-scn sc-offset)))))) - #+nil - (format t ";;; SET: ~S[~D]~%" - sb-name (sb!c:sc-offset-offset sc-offset)) - (unless (null sb-name) - (let ((group (cdr (assoc sb-name groups)))) - (when (null group) - (setf group (make-location-group)) - (push `(,sb-name . ,group) groups)) - (let* ((locations (location-group-locations group)) - (length (length locations)) - (offset (sb!c:sc-offset-offset sc-offset))) - (when (>= offset length) - (setf locations - (grow-vector locations - (max (* 2 length) - (1+ offset)) - nil) - (location-group-locations group) - locations)) - (let ((already-there (aref locations offset))) - (cond ((null already-there) - (setf (aref locations offset) debug-var-offset)) - ((eql already-there debug-var-offset)) - (t - (if (listp already-there) - (pushnew debug-var-offset - (aref locations offset)) - (setf (aref locations offset) - (list debug-var-offset - already-there))))) - ))))))) - ))) + (dotimes (debug-var-offset + (length debug-vars) + (make-storage-info :groups groups + :debug-vars debug-vars)) + (let ((debug-var (aref debug-vars debug-var-offset))) + #+nil + (format t ";;; At offset ~W: ~S~%" debug-var-offset debug-var) + (let* ((sc-offset + (sb!di::compiled-debug-var-sc-offset debug-var)) + (sb-name + (sb!c:sb-name + (sb!c:sc-sb (aref sc-vec + (sb!c:sc-offset-scn sc-offset)))))) + #+nil + (format t ";;; SET: ~S[~W]~%" + sb-name (sb!c:sc-offset-offset sc-offset)) + (unless (null sb-name) + (let ((group (cdr (assoc sb-name groups)))) + (when (null group) + (setf group (make-location-group)) + (push `(,sb-name . ,group) groups)) + (let* ((locations (location-group-locations group)) + (length (length locations)) + (offset (sb!c:sc-offset-offset sc-offset))) + (when (>= offset length) + (setf locations + (grow-vector locations + (max (* 2 length) + (1+ offset)) + nil) + (location-group-locations group) + locations)) + (let ((already-there (aref locations offset))) + (cond ((null already-there) + (setf (aref locations offset) debug-var-offset)) + ((eql already-there debug-var-offset)) + (t + (if (listp already-there) + (pushnew debug-var-offset + (aref locations offset)) + (setf (aref locations offset) + (list debug-var-offset + already-there))))) + ))))))) + ))) (defun source-available-p (debug-fun) (handler-case (sb!di:do-debug-fun-blocks (block debug-fun) - (declare (ignore block)) - (return t)) + (declare (ignore block)) + (return t)) (sb!di:no-debug-blocks () nil))) (defun print-block-boundary (stream dstate) (let ((os (dstate-output-state dstate))) (when (not (eq os :beginning)) (when (not (eq os :block-boundary)) - (terpri stream)) + (terpri stream)) (setf (dstate-output-state dstate) - :block-boundary)))) + :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) - (type (or null source-form-cache) sfcache)) + (type (or null sb!di:debug-fun) debug-fun) + (type (or null source-form-cache) sfcache)) (let ((last-block-pc -1)) (flet ((add-hook (pc fun &optional before-address) - (push (make-offs-hook - :offset pc ;; ##### FIX to account for non-zero offs in code - :function fun - :before-address before-address) - (seg-hooks segment)))) + (push (make-offs-hook + :offset pc ;; ### FIX to account for non-zero offs in code + :fun fun + :before-address before-address) + (seg-hooks segment)))) (handler-case - (sb!di:do-debug-fun-blocks (block debug-fun) - (let ((first-location-in-block-p t)) - (sb!di:do-debug-block-locations (loc block) - (let ((pc (sb!di::compiled-code-location-pc loc))) - - ;; Put blank lines in at block boundaries - (when (and first-location-in-block-p - (/= pc last-block-pc)) - (setf first-location-in-block-p nil) - (add-hook pc - (lambda (stream dstate) - (print-block-boundary stream dstate)) - t) - (setf last-block-pc pc)) - - ;; Print out corresponding source; this information is not - ;; all that accurate, but it's better than nothing - (unless (zerop (sb!di:code-location-form-number loc)) - (multiple-value-bind (form new) - (get-different-source-form loc 0 sfcache) - (when new - (let ((at-block-begin (= pc last-block-pc))) - (add-hook - pc - (lambda (stream dstate) - (declare (ignore dstate)) - (when stream - (unless at-block-begin - (terpri stream)) - (format stream ";;; [~D] " - (sb!di:code-location-form-number - loc)) - (prin1-short form stream) - (terpri stream) - (terpri stream))) - t))))) - - ;; Keep track of variable live-ness as best we can. - (let ((live-set - (copy-seq (sb!di::compiled-code-location-live-set - loc)))) - (add-hook - pc - (lambda (stream dstate) - (declare (ignore stream)) - (setf (dstate-current-valid-locations dstate) - live-set) - #+nil - (note (lambda (stream) - (let ((*print-length* nil)) - (format stream "live set: ~S" - live-set))) - dstate)))) - )))) - (sb!di:no-debug-blocks () nil))))) + (sb!di:do-debug-fun-blocks (block debug-fun) + (let ((first-location-in-block-p t)) + (sb!di:do-debug-block-locations (loc block) + (let ((pc (sb!di::compiled-code-location-pc loc))) + + ;; Put blank lines in at block boundaries + (when (and first-location-in-block-p + (/= pc last-block-pc)) + (setf first-location-in-block-p nil) + (add-hook pc + (lambda (stream dstate) + (print-block-boundary stream dstate)) + t) + (setf last-block-pc pc)) + + ;; Print out corresponding source; this information is not + ;; all that accurate, but it's better than nothing + (unless (zerop (sb!di:code-location-form-number loc)) + (multiple-value-bind (form new) + (get-different-source-form loc 0 sfcache) + (when new + (let ((at-block-begin (= pc last-block-pc))) + (add-hook + pc + (lambda (stream dstate) + (declare (ignore dstate)) + (when stream + (unless at-block-begin + (terpri stream)) + (format stream ";;; [~W] " + (sb!di:code-location-form-number + loc)) + (prin1-short form stream) + (terpri stream) + (terpri stream))) + t))))) + + ;; Keep track of variable live-ness as best we can. + (let ((live-set + (copy-seq (sb!di::compiled-code-location-live-set + loc)))) + (add-hook + pc + (lambda (stream dstate) + (declare (ignore stream)) + (setf (dstate-current-valid-locations dstate) + live-set) + #+nil + (note (lambda (stream) + (let ((*print-length* nil)) + (format stream "live set: ~S" + live-set))) + dstate)))) + )))) + (sb!di:no-debug-blocks () nil))))) + +(defvar *disassemble-annotate* t + "Annotate DISASSEMBLE output with source code.") (defun add-debugging-hooks (segment debug-fun &optional sfcache) (when debug-fun (setf (seg-storage-info segment) - (storage-info-for-debug-fun debug-fun)) - (add-source-tracking-hooks segment debug-fun sfcache) + (storage-info-for-debug-fun debug-fun)) + (when *disassemble-annotate* + (add-source-tracking-hooks segment debug-fun sfcache)) (let ((kind (sb!di:debug-fun-kind debug-fun))) - (flet ((anh (n) - (push (make-offs-hook - :offset 0 - :function (lambda (stream dstate) - (declare (ignore stream)) - (note n dstate))) - (seg-hooks segment)))) - (case kind - (:external) - ((nil) - (anh "no-arg-parsing entry point")) - (t - (anh (lambda (stream) - (format stream "~S entry point" kind))))))))) + (flet ((add-new-hook (n) + (push (make-offs-hook + :offset 0 + :fun (lambda (stream dstate) + (declare (ignore stream)) + (note n dstate))) + (seg-hooks segment)))) + (case kind + (:external) + ((nil) + (add-new-hook "no-arg-parsing entry point")) + (t + (add-new-hook (lambda (stream) + (format stream "~S entry point" kind))))))))) ;;; Return a list of the segments of memory containing machine code ;;; instructions for FUNCTION. -(defun get-function-segments (function) +(defun get-fun-segments (function) (declare (type compiled-function function)) (let* ((code (fun-code function)) - (fun-map (code-fun-map code)) - (fname (sb!kernel:%function-name function)) - (sfcache (make-source-form-cache))) + (fun-map (code-fun-map code)) + (fname (sb!kernel:%simple-fun-name function)) + (sfcache (make-source-form-cache))) (let ((first-block-seen-p nil) - (nil-block-seen-p nil) - (last-offset 0) - (last-debug-fun nil) - (segments nil)) + (nil-block-seen-p nil) + (last-offset 0) + (last-debug-fun nil) + (segments nil)) (flet ((add-seg (offs len df) - (when (> len 0) - (push (make-code-segment code offs len - :debug-fun df - :source-form-cache sfcache) - segments)))) - (dotimes (fmap-index (length fun-map)) - (let ((fmap-entry (aref fun-map fmap-index))) - (etypecase fmap-entry - (integer - (when first-block-seen-p - (add-seg last-offset - (- fmap-entry last-offset) - last-debug-fun) - (setf last-debug-fun nil)) - (setf last-offset fmap-entry)) - (sb!c::compiled-debug-fun - (let ((name (sb!c::compiled-debug-fun-name fmap-entry)) - (kind (sb!c::compiled-debug-fun-kind fmap-entry))) - #+nil - (format t ";;; SAW ~S ~S ~S,~S ~D,~D~%" - name kind first-block-seen-p nil-block-seen-p - last-offset - (sb!c::compiled-debug-fun-start-pc fmap-entry)) - (cond (#+nil (eq last-offset fun-offset) - (and (equal name fname) (not first-block-seen-p)) - (setf first-block-seen-p t)) - ((eq kind :external) - (when first-block-seen-p - (return))) - ((eq kind nil) - (when nil-block-seen-p - (return)) - (when first-block-seen-p - (setf nil-block-seen-p t)))) - (setf last-debug-fun - (sb!di::make-compiled-debug-fun fmap-entry code)) - ))))) - (let ((max-offset (code-inst-area-length code))) - (when (and first-block-seen-p last-debug-fun) - (add-seg last-offset - (- max-offset last-offset) - last-debug-fun)) - (if (null segments) - (let ((offs (fun-insts-offset function))) - (make-code-segment code offs (- max-offset offs))) - (nreverse segments))))))) + (when (> len 0) + (push (make-code-segment code offs len + :debug-fun df + :source-form-cache sfcache) + segments)))) + (dotimes (fmap-index (length fun-map)) + (let ((fmap-entry (aref fun-map fmap-index))) + (etypecase fmap-entry + (integer + (when first-block-seen-p + (add-seg last-offset + (- fmap-entry last-offset) + last-debug-fun) + (setf last-debug-fun nil)) + (setf last-offset fmap-entry)) + (sb!c::compiled-debug-fun + (let ((name (sb!c::compiled-debug-fun-name fmap-entry)) + (kind (sb!c::compiled-debug-fun-kind fmap-entry))) + #+nil + (format t ";;; SAW ~S ~S ~S,~S ~W,~W~%" + name kind first-block-seen-p nil-block-seen-p + last-offset + (sb!c::compiled-debug-fun-start-pc fmap-entry)) + (cond (#+nil (eq last-offset fun-offset) + (and (equal name fname) (not first-block-seen-p)) + (setf first-block-seen-p t)) + ((eq kind :external) + (when first-block-seen-p + (return))) + ((eq kind nil) + (when nil-block-seen-p + (return)) + (when first-block-seen-p + (setf nil-block-seen-p t)))) + (setf last-debug-fun + (sb!di::make-compiled-debug-fun fmap-entry code))))))) + (let ((max-offset (code-inst-area-length code))) + (when (and first-block-seen-p last-debug-fun) + (add-seg last-offset + (- max-offset last-offset) + last-debug-fun)) + (if (null segments) + (let ((offs (fun-insts-offset function))) + (list + (make-code-segment code offs (- max-offset offs)))) + (nreverse segments))))))) ;;; Return a list of the segments of memory containing machine code ;;; instructions for the code-component CODE. If START-OFFSET and/or ;;; LENGTH is supplied, only that part of the code-segment is used ;;; (but these are constrained to lie within the code-segment). (defun get-code-segments (code - &optional - (start-offset 0) - (length (code-inst-area-length code))) + &optional + (start-offset 0) + (length (code-inst-area-length code))) (declare (type sb!kernel:code-component code) - (type offset start-offset) - (type length length)) + (type offset start-offset) + (type disassem-length length)) (let ((segments nil)) (when code (let ((fun-map (code-fun-map code)) - (sfcache (make-source-form-cache))) - (let ((last-offset 0) - (last-debug-fun nil)) - (flet ((add-seg (offs len df) - (let* ((restricted-offs - (min (max start-offset offs) - (+ start-offset length))) - (restricted-len - (- (min (max start-offset (+ offs len)) - (+ start-offset length)) - restricted-offs))) - (when (> restricted-len 0) - (push (make-code-segment code - restricted-offs restricted-len - :debug-fun df - :source-form-cache sfcache) - segments))))) - (dotimes (fun-map-index (length fun-map)) - (let ((fun-map-entry (aref fun-map fun-map-index))) - (etypecase fun-map-entry - (integer - (add-seg last-offset (- fun-map-entry last-offset) - last-debug-fun) - (setf last-debug-fun nil) - (setf last-offset fun-map-entry)) - (sb!c::compiled-debug-fun - (setf last-debug-fun - (sb!di::make-compiled-debug-fun fun-map-entry - code)))))) - (when last-debug-fun - (add-seg last-offset - (- (code-inst-area-length code) last-offset) - last-debug-fun)))))) + (sfcache (make-source-form-cache))) + (let ((last-offset 0) + (last-debug-fun nil)) + (flet ((add-seg (offs len df) + (let* ((restricted-offs + (min (max start-offset offs) + (+ start-offset length))) + (restricted-len + (- (min (max start-offset (+ offs len)) + (+ start-offset length)) + restricted-offs))) + (when (> restricted-len 0) + (push (make-code-segment code + restricted-offs restricted-len + :debug-fun df + :source-form-cache sfcache) + segments))))) + (dotimes (fun-map-index (length fun-map)) + (let ((fun-map-entry (aref fun-map fun-map-index))) + (etypecase fun-map-entry + (integer + (add-seg last-offset (- fun-map-entry last-offset) + last-debug-fun) + (setf last-debug-fun nil) + (setf last-offset fun-map-entry)) + (sb!c::compiled-debug-fun + (setf last-debug-fun + (sb!di::make-compiled-debug-fun fun-map-entry + code)))))) + (when last-debug-fun + (add-seg last-offset + (- (code-inst-area-length code) last-offset) + last-debug-fun)))))) (if (null segments) - (make-code-segment code start-offset length) - (nreverse segments)))) + (make-code-segment code start-offset length) + (nreverse segments)))) -;;; Return two values: the amount by which the last instruction in the -;;; segment goes past the end of the segment, and the offset of the -;;; end of the segment from the beginning of that instruction. If all -;;; instructions fit perfectly, return 0 and 0. -(defun segment-overflow (segment dstate) - (declare (type segment segment) - (type disassem-state dstate)) - (let ((seglen (seg-length segment)) - (last-start 0)) - (map-segment-instructions (lambda (chunk inst) - (declare (ignore chunk inst)) - (setf last-start (dstate-cur-offs dstate))) - segment - dstate) - (values (- (dstate-cur-offs dstate) seglen) - (- seglen last-start)))) - ;;; Compute labels for all the memory segments in SEGLIST and adds ;;; them to DSTATE. It's important to call this function with all the ;;; segments you're interested in, so that it can find references from ;;; one to another. (defun label-segments (seglist dstate) (declare (type list seglist) - (type disassem-state dstate)) + (type disassem-state dstate)) (dolist (seg seglist) (add-segment-labels seg dstate)) ;; Now remove any labels that don't point anywhere in the segments ;; we have. (setf (dstate-labels dstate) - (remove-if (lambda (lab) - (not - (some (lambda (seg) - (let ((start (seg-virtual-location seg))) - (<= start - (car lab) - (+ start (seg-length seg))))) - seglist))) - (dstate-labels dstate)))) + (remove-if (lambda (lab) + (not + (some (lambda (seg) + (let ((start (seg-virtual-location seg))) + (<= start + (car lab) + (+ start (seg-length seg))))) + seglist))) + (dstate-labels dstate)))) ;;; Disassemble the machine code instructions in SEGMENT to STREAM. (defun disassemble-segment (segment stream dstate) (declare (type segment segment) - (type stream stream) - (type disassem-state dstate)) + (type stream stream) + (type disassem-state dstate)) (let ((*print-pretty* nil)) ; otherwise the pp conses hugely (number-labels dstate) (map-segment-instructions (lambda (chunk inst) (declare (type dchunk chunk) (type instruction inst)) (let ((printer (inst-printer inst))) - (when printer - (funcall printer chunk inst stream dstate)))) + (when printer + (funcall printer chunk inst stream dstate)))) segment dstate stream))) @@ -1478,106 +1408,118 @@ ;;; in SEGMENTS in turn to STREAM. (defun disassemble-segments (segments stream dstate) (declare (type list segments) - (type stream stream) - (type disassem-state dstate)) + (type stream stream) + (type disassem-state dstate)) (unless (null segments) + (format stream "~&; Size: ~a bytes" + (reduce #'+ segments :key #'seg-length)) (let ((first (car segments)) - (last (car (last segments)))) + (last (car (last segments)))) (set-location-printing-range dstate - (seg-virtual-location first) - (- (+ (seg-virtual-location last) - (seg-length last)) - (seg-virtual-location first))) + (seg-virtual-location first) + (- (+ (seg-virtual-location last) + (seg-length last)) + (seg-virtual-location first))) (setf (dstate-output-state dstate) :beginning) (dolist (seg segments) - (disassemble-segment seg stream dstate))))) + (disassemble-segment seg stream dstate))))) -;;;; top-level functions +;;;; top level functions ;;; Disassemble the machine code instructions for FUNCTION. -(defun disassemble-function (function &key - (stream *standard-output*) - (use-labels t)) - (declare (type compiled-function function) - (type stream stream) - (type (member t nil) use-labels)) +(defun disassemble-fun (fun &key + (stream *standard-output*) + (use-labels t)) + (declare (type compiled-function fun) + (type stream stream) + (type (member t nil) use-labels)) (let* ((dstate (make-dstate)) - (segments (get-function-segments function))) + (segments (get-fun-segments fun))) (when use-labels (label-segments segments dstate)) (disassemble-segments segments stream dstate))) -(defun compile-function-lambda-expr (function) - (declare (type function function)) - (multiple-value-bind (lambda closurep name) - (function-lambda-expression function) - (declare (ignore name)) - (when closurep - (error "can't compile a lexical closure")) - (compile nil lambda))) - -(defun compiled-function-or-lose (thing &optional (name thing)) - (cond ((or (symbolp thing) - (and (listp thing) - (eq (car thing) 'setf))) - (compiled-function-or-lose (fdefinition thing) thing)) - ((functionp thing) - thing) - ((and (listp thing) - (eq (car thing) 'lambda)) - (compile nil thing)) - (t - (error "can't make a compiled function from ~S" name)))) +(defun valid-extended-function-designators-for-disassemble-p (thing) + (cond ((legal-fun-name-p 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) + (eq (car thing) 'lambda)) + (compile nil thing)) + (t nil))) + +(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-designators-for-disassemble-p) + :format-control "Can't make a compiled function from ~S" + :format-arguments (list name))))) (defun disassemble (object &key - (stream *standard-output*) - (use-labels t)) + (stream *standard-output*) + (use-labels t)) #!+sb-doc "Disassemble the compiled code associated with OBJECT, which can be a function, a lambda expression, or a symbol with a function definition. If it is not already compiled, the compiler is called to produce something to disassemble." (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-function (compiled-function-or-lose object) - :stream stream - :use-labels use-labels) - nil)) + (type (or (member t) stream) stream) + (type (member t nil) use-labels)) + (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 ;;; could move during a GC, you'd better disable it around the call to ;;; this function. (defun disassemble-memory (address - length - &key - (stream *standard-output*) - code-component - (use-labels t)) + length + &key + (stream *standard-output*) + code-component + (use-labels t)) (declare (type (or address sb!sys:system-area-pointer) address) - (type length length) - (type stream stream) - (type (or null sb!kernel:code-component) code-component) - (type (member t nil) use-labels)) - (let* ((address - (if (sb!sys:system-area-pointer-p address) - (sb!sys:sap-int address) - address)) - (dstate (make-dstate)) - (segments - (if code-component - (let ((code-offs - (- address - (sb!sys:sap-int - (sb!kernel:code-instructions code-component))))) - (when (or (< code-offs 0) - (> code-offs (code-inst-area-length code-component))) - (error "address ~X not in the code component ~S" - address code-component)) - (get-code-segments code-component code-offs length)) - (list (make-memory-segment address length))))) + (type disassem-length length) + (type stream stream) + (type (or null sb!kernel:code-component) code-component) + (type (member t nil) use-labels)) + (let* ((address + (if (sb!sys:system-area-pointer-p address) + (sb!sys:sap-int address) + address)) + (dstate (make-dstate)) + (segments + (if code-component + (let ((code-offs + (- address + (sb!sys:sap-int + (sb!kernel:code-instructions code-component))))) + (when (or (< code-offs 0) + (> code-offs (code-inst-area-length code-component))) + (error "address ~X not in the code component ~S" + address code-component)) + (get-code-segments code-component code-offs length)) + (list (make-memory-segment address length))))) (when use-labels (label-segments segments dstate)) (disassemble-segments segments stream dstate))) @@ -1585,153 +1527,51 @@ ;;; Disassemble the machine code instructions associated with ;;; CODE-COMPONENT (this may include multiple entry points). (defun disassemble-code-component (code-component &key - (stream *standard-output*) - (use-labels t)) + (stream *standard-output*) + (use-labels t)) (declare (type (or null sb!kernel:code-component compiled-function) - code-component) - (type stream stream) - (type (member t nil) use-labels)) - (let* ((code-component - (if (functionp code-component) - (fun-code code-component) - code-component)) - (dstate (make-dstate)) - (segments (get-code-segments code-component))) + code-component) + (type stream stream) + (type (member t nil) use-labels)) + (let* ((code-component + (if (functionp code-component) + (fun-code code-component) + code-component)) + (dstate (make-dstate)) + (segments (get-code-segments code-component))) (when use-labels (label-segments segments dstate)) (disassemble-segments segments stream dstate))) -;;; code for making useful segments from arbitrary lists of code-blocks - -;;; the maximum size of an instruction. Note that this includes -;;; pseudo-instructions like error traps with their associated -;;; operands, so it should be big enough to include them, i.e. it's -;;; not just 4 on a risc machine! -(defconstant max-instruction-size 16) - -(defun add-block-segments (seg-code-block - seglist - location - connecting-vec - dstate) - (declare (type list seglist) - (type integer location) - (type (or null (vector (unsigned-byte 8))) connecting-vec) - (type disassem-state dstate)) - (flet ((addit (seg overflow) - (let ((length (+ (seg-length seg) overflow))) - (when (> length 0) - (setf (seg-length seg) length) - (incf location length) - (push seg seglist))))) - (let ((connecting-overflow 0) - (amount (length seg-code-block))) - (when connecting-vec - ;; Tack on some of the new block to the old overflow vector. - (let* ((beginning-of-block-amount - (if seg-code-block (min max-instruction-size amount) 0)) - (connecting-vec - (if seg-code-block - (concatenate - '(vector (unsigned-byte 8)) - connecting-vec - (subseq seg-code-block 0 beginning-of-block-amount)) - connecting-vec))) - (when (and (< (length connecting-vec) max-instruction-size) - (not (null seg-code-block))) - (return-from add-block-segments - ;; We want connecting vectors to be large enough to hold - ;; any instruction, and since the current seg-code-block - ;; wasn't large enough to do this (and is now entirely - ;; on the end of the overflow-vector), just save it for - ;; next time. - (values seglist location connecting-vec))) - (when (> (length connecting-vec) 0) - (let ((seg - (make-vector-segment connecting-vec - 0 - (- (length connecting-vec) - beginning-of-block-amount) - :virtual-location location))) - (setf connecting-overflow (segment-overflow seg dstate)) - (addit seg connecting-overflow))))) - (cond ((null seg-code-block) - ;; nothing more to add - (values seglist location nil)) - ((< (- amount connecting-overflow) max-instruction-size) - ;; We can't create a segment with the minimum size - ;; required for an instruction, so just keep on accumulating - ;; in the overflow vector for the time-being. - (values seglist - location - (subseq seg-code-block connecting-overflow amount))) - (t - ;; Put as much as we can into a new segment, and the rest - ;; into the overflow-vector. - (let* ((initial-length - (- amount connecting-overflow max-instruction-size)) - (seg - (make-vector-segment seg-code-block - connecting-overflow - initial-length - :virtual-location location)) - (overflow - (segment-overflow seg dstate))) - (addit seg overflow) - (values seglist - location - (subseq seg-code-block - (+ connecting-overflow (seg-length seg)) - amount)))))))) - ;;;; code to disassemble assembler segments -(defun assem-segment-to-disassem-segments (assem-segment dstate) - (declare (type sb!assem:segment assem-segment) - (type disassem-state dstate)) - (let ((location 0) - (disassem-segments nil) - (connecting-vec nil)) - (sb!assem:on-segment-contents-vectorly - assem-segment - (lambda (seg-code-block) - (multiple-value-setq (disassem-segments location connecting-vec) - (add-block-segments seg-code-block - disassem-segments - location - connecting-vec - dstate)))) - (when connecting-vec - (setf disassem-segments - (add-block-segments nil - disassem-segments - location - connecting-vec - dstate))) - (sort disassem-segments #'< :key #'seg-virtual-location))) +(defun assem-segment-to-disassem-segment (assem-segment) + (declare (type sb!assem:segment assem-segment)) + (let ((contents (sb!assem:segment-contents-as-vector assem-segment))) + (make-vector-segment contents 0 (length contents) :virtual-location 0))) ;;; Disassemble the machine code instructions associated with ;;; ASSEM-SEGMENT (of type assem:segment). (defun disassemble-assem-segment (assem-segment stream) (declare (type sb!assem:segment assem-segment) - (type stream stream)) - (let* ((dstate (make-dstate)) - (disassem-segments - (assem-segment-to-disassem-segments assem-segment dstate))) + (type stream stream)) + (let ((dstate (make-dstate)) + (disassem-segments + (list (assem-segment-to-disassem-segment assem-segment)))) (label-segments disassem-segments dstate) (disassemble-segments disassem-segments stream dstate))) ;;; routines to find things in the Lisp environment -;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots +;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots ;;; in a symbol object that we know about (defparameter *grokked-symbol-slots* - (sort `((,sb!vm:symbol-value-slot . symbol-value) - (,sb!vm:symbol-plist-slot . symbol-plist) - (,sb!vm:symbol-name-slot . symbol-name) - (,sb!vm:symbol-package-slot . symbol-package)) - #'< - :key #'car)) + (sort (copy-list `((,sb!vm:symbol-value-slot . symbol-value) + (,sb!vm:symbol-plist-slot . symbol-plist) + (,sb!vm:symbol-name-slot . symbol-name) + (,sb!vm:symbol-package-slot . symbol-package))) + #'< + :key #'car)) ;;; Given ADDRESS, try and figure out if which slot of which symbol is ;;; being referred to. Of course we can just give up, so it's not a @@ -1739,19 +1579,19 @@ ;;; access function of the slot. (defun grok-symbol-slot-ref (address) (declare (type address address)) - (if (not (aligned-p address sb!vm:word-bytes)) + (if (not (aligned-p address sb!vm:n-word-bytes)) (values nil nil) (do ((slots-tail *grokked-symbol-slots* (cdr slots-tail))) - ((null slots-tail) - (values nil nil)) - (let* ((field (car slots-tail)) - (slot-offset (words-to-bytes (car field))) - (maybe-symbol-addr (- address slot-offset)) - (maybe-symbol - (sb!kernel:make-lisp-obj - (+ maybe-symbol-addr sb!vm:other-pointer-type)))) - (when (symbolp maybe-symbol) - (return (values maybe-symbol (cdr field)))))))) + ((null slots-tail) + (values nil nil)) + (let* ((field (car slots-tail)) + (slot-offset (words-to-bytes (car field))) + (maybe-symbol-addr (- address slot-offset)) + (maybe-symbol + (sb!kernel:make-lisp-obj + (+ maybe-symbol-addr sb!vm:other-pointer-lowtag)))) + (when (symbolp maybe-symbol) + (return (values maybe-symbol (cdr field)))))))) (defvar *address-of-nil-object* (sb!kernel:get-lisp-obj-address nil)) @@ -1774,33 +1614,46 @@ (defun get-code-constant (byte-offset dstate) #!+sb-doc (declare (type offset byte-offset) - (type disassem-state dstate)) + (type disassem-state dstate)) (let ((code (seg-code (dstate-segment dstate)))) (if code - (values - (sb!kernel:code-header-ref code - (ash (+ byte-offset - sb!vm:other-pointer-type) - (- sb!vm:word-shift))) - t) - (values nil nil)))) - -(defun get-code-constant-absolute (addr dstate) + (values + (sb!kernel:code-header-ref code + (ash (+ byte-offset + sb!vm:other-pointer-lowtag) + (- sb!vm:word-shift))) + t) + (values nil nil)))) + +(defstruct code-constant-raw value) +(def!method print-object ((self code-constant-raw) stream) + (format stream "#x~8,'0x" (code-constant-raw-value self))) + +(defun get-code-constant-absolute (addr dstate &optional width) (declare (type address addr)) (declare (type disassem-state dstate)) (let ((code (seg-code (dstate-segment dstate)))) (if (null code) (return-from get-code-constant-absolute (values nil nil))) - (let ((code-size (ash (sb!kernel:get-header-data code) sb!vm:word-shift))) - (sb!sys:without-gcing - (let ((code-addr (- (sb!kernel:get-lisp-obj-address code) - sb!vm:other-pointer-type))) - (if (or (< addr code-addr) (>= addr (+ code-addr code-size))) - (values nil nil) - (values (sb!kernel:code-header-ref - code - (ash (- addr code-addr) (- sb!vm:word-shift))) - t))))))) + (sb!sys:without-gcing + (let* ((n-header-words (sb!kernel:get-header-data code)) + (n-code-words (sb!kernel:%code-code-size code)) + (header-addr (- (sb!kernel:get-lisp-obj-address code) + sb!vm:other-pointer-lowtag))) + (cond ((<= header-addr addr (+ header-addr (ash (1- n-header-words) + sb!vm:word-shift))) + (values (sb!sys:sap-ref-lispobj (sb!sys:int-sap addr) 0) t)) + ;; guess it's a non-descriptor constant from the instructions + ((and (eq width :qword) + (< n-header-words + ;; convert ADDR to header-relative Nth word + (ash (- addr header-addr) (- sb!vm:word-shift)) + (+ n-header-words n-code-words))) + (values (make-code-constant-raw + :value (sb!sys:sap-ref-64 (sb!sys:int-sap addr) 0)) + t)) + (t + (values nil nil))))))) (defvar *assembler-routines-by-addr* nil) @@ -1809,7 +1662,7 @@ ;;; Build an address-name hash-table from the name-address hash (defun invert-address-hash (htable &optional (addr-hash (make-hash-table))) (maphash (lambda (name address) - (setf (gethash address addr-hash) name)) + (setf (gethash address addr-hash) name)) htable) addr-hash) @@ -1819,10 +1672,21 @@ (declare (type address address)) (when (null *assembler-routines-by-addr*) (setf *assembler-routines-by-addr* - (invert-address-hash sb!fasl:*assembler-routines*)) + (invert-address-hash sb!fasl:*assembler-routines*)) + #!-sb-dynamic-core (setf *assembler-routines-by-addr* - (invert-address-hash sb!fasl:*static-foreign-symbols* - *assembler-routines-by-addr*))) + (invert-address-hash sb!sys:*static-foreign-symbols* + *assembler-routines-by-addr*)) + (loop for static in sb!vm:*static-funs* + for address = (+ sb!vm::nil-value + (sb!vm::static-fun-offset static)) + do + (setf (gethash address *assembler-routines-by-addr*) + static)) + ;; Not really a routine, but it uses the similar logic for annotations + #!+sb-safepoint + (setf (gethash sb!vm::gc-safepoint-page-addr *assembler-routines-by-addr*) + "safepoint")) (gethash address *assembler-routines-by-addr*)) ;;;; some handy function for machine-dependent code to use... @@ -1831,38 +1695,55 @@ (defun sap-ref-int (sap offset length byte-order) (declare (type sb!sys:system-area-pointer sap) - (type (unsigned-byte 16) offset) - (type (member 1 2 4) length) - (type (member :little-endian :big-endian) byte-order) - (optimize (speed 3) (safety 0))) + (type (unsigned-byte 16) offset) + (type (member 1 2 4 8) length) + (type (member :little-endian :big-endian) byte-order) + (optimize (speed 3) (safety 0))) (ecase length (1 (sb!sys:sap-ref-8 sap offset)) (2 (if (eq byte-order :big-endian) - (+ (ash (sb!sys:sap-ref-8 sap offset) 8) - (sb!sys:sap-ref-8 sap (+ offset 1))) - (+ (ash (sb!sys:sap-ref-8 sap (+ offset 1)) 8) - (sb!sys:sap-ref-8 sap offset)))) + (+ (ash (sb!sys:sap-ref-8 sap offset) 8) + (sb!sys:sap-ref-8 sap (+ offset 1))) + (+ (ash (sb!sys:sap-ref-8 sap (+ offset 1)) 8) + (sb!sys:sap-ref-8 sap offset)))) (4 (if (eq byte-order :big-endian) - (+ (ash (sb!sys:sap-ref-8 sap offset) 24) - (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 16) - (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 8) - (sb!sys:sap-ref-8 sap (+ 3 offset))) - (+ (sb!sys:sap-ref-8 sap offset) - (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8) - (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16) - (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24)))))) + (+ (ash (sb!sys:sap-ref-8 sap offset) 24) + (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 16) + (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 8) + (sb!sys:sap-ref-8 sap (+ 3 offset))) + (+ (sb!sys:sap-ref-8 sap offset) + (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8) + (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16) + (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24)))) + (8 (if (eq byte-order :big-endian) + (+ (ash (sb!sys:sap-ref-8 sap offset) 56) + (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 48) + (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 40) + (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 32) + (ash (sb!sys:sap-ref-8 sap (+ 4 offset)) 24) + (ash (sb!sys:sap-ref-8 sap (+ 5 offset)) 16) + (ash (sb!sys:sap-ref-8 sap (+ 6 offset)) 8) + (sb!sys:sap-ref-8 sap (+ 7 offset))) + (+ (sb!sys:sap-ref-8 sap offset) + (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8) + (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16) + (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24) + (ash (sb!sys:sap-ref-8 sap (+ 4 offset)) 32) + (ash (sb!sys:sap-ref-8 sap (+ 5 offset)) 40) + (ash (sb!sys:sap-ref-8 sap (+ 6 offset)) 48) + (ash (sb!sys:sap-ref-8 sap (+ 7 offset)) 56)))))) (defun read-suffix (length dstate) - (declare (type (member 8 16 32) length) - (type disassem-state dstate) - (optimize (speed 3) (safety 0))) - (let ((length (ecase length (8 1) (16 2) (32 4)))) - (declare (type (unsigned-byte 3) length)) + (declare (type (member 8 16 32 64) length) + (type disassem-state dstate) + (optimize (speed 3) (safety 0))) + (let ((length (ecase length (8 1) (16 2) (32 4) (64 8)))) + (declare (type (unsigned-byte 4) length)) (prog1 (sap-ref-int (dstate-segment-sap dstate) - (dstate-next-offs dstate) - length - (dstate-byte-order dstate)) + (dstate-next-offs dstate) + length + (dstate-byte-order dstate)) (incf (dstate-next-offs dstate) length)))) ;;;; optional routines to make notes about code @@ -1872,7 +1753,7 @@ ;;; after the current instruction is disassembled. (defun note (note dstate) (declare (type (or string function) note) - (type disassem-state dstate)) + (type disassem-state dstate)) (push note (dstate-notes dstate))) (defun prin1-short (thing stream) @@ -1889,27 +1770,27 @@ ;;; comment after the current instruction is disassembled. (defun note-code-constant (byte-offset dstate) (declare (type offset byte-offset) - (type disassem-state dstate)) + (type disassem-state dstate)) (multiple-value-bind (const valid) (get-code-constant byte-offset dstate) (when valid (note (lambda (stream) - (prin1-quoted-short const stream)) - dstate)) + (prin1-quoted-short const stream)) + dstate)) const)) ;;; Store a note about the lisp constant located at ADDR in the ;;; current code-component, to be printed as an end-of-line comment ;;; after the current instruction is disassembled. -(defun note-code-constant-absolute (addr dstate) +(defun note-code-constant-absolute (addr dstate &optional width) (declare (type address addr) - (type disassem-state dstate)) + (type disassem-state dstate)) (multiple-value-bind (const valid) - (get-code-constant-absolute addr dstate) + (get-code-constant-absolute addr dstate width) (when valid (note (lambda (stream) - (prin1-quoted-short const stream)) - dstate)) + (prin1-quoted-short const stream)) + dstate)) (values const valid))) ;;; If the memory address located NIL-BYTE-OFFSET bytes from the @@ -1919,16 +1800,16 @@ ;;; a note was recorded. (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate) (declare (type offset nil-byte-offset) - (type disassem-state dstate)) + (type disassem-state dstate)) (multiple-value-bind (symbol access-fun) (grok-nil-indexed-symbol-slot-ref nil-byte-offset) (when access-fun (note (lambda (stream) - (prin1 (if (eq access-fun 'symbol-value) - symbol - `(,access-fun ',symbol)) - stream)) - dstate)) + (prin1 (if (eq access-fun 'symbol-value) + symbol + `(,access-fun ',symbol)) + stream)) + dstate)) access-fun)) ;;; If the memory address located NIL-BYTE-OFFSET bytes from the @@ -1938,11 +1819,11 @@ ;;; was recorded. (defun maybe-note-nil-indexed-object (nil-byte-offset dstate) (declare (type offset nil-byte-offset) - (type disassem-state dstate)) + (type disassem-state dstate)) (let ((obj (get-nil-indexed-object nil-byte-offset))) (note (lambda (stream) - (prin1-quoted-short obj stream)) - dstate) + (prin1-quoted-short obj stream)) + dstate) t)) ;;; If ADDRESS is the address of a primitive assembler routine or @@ -1954,13 +1835,16 @@ (declare (type disassem-state dstate)) (unless (typep address 'address) (return-from maybe-note-assembler-routine nil)) - (let ((name (find-assembler-routine address))) + (let ((name (or + (find-assembler-routine address) + #!+linkage-table + (sb!sys:sap-foreign-symbol (sb!sys:int-sap address))))) (unless (null name) (note (lambda (stream) - (if note-address-p + (if note-address-p (format stream "#x~8,'0x: ~a" address name) (princ name stream))) - dstate)) + dstate)) name)) ;;; If there's a valid mapping from OFFSET in the storage class @@ -1970,18 +1854,18 @@ ;;; recorded. (defun maybe-note-single-storage-ref (offset sc-name dstate) (declare (type offset offset) - (type symbol sc-name) - (type disassem-state dstate)) + (type symbol sc-name) + (type disassem-state dstate)) (let ((storage-location - (find-valid-storage-location offset sc-name dstate))) + (find-valid-storage-location offset sc-name dstate))) (when storage-location (note (lambda (stream) - (princ (sb!di:debug-var-symbol - (aref (storage-info-debug-vars - (seg-storage-info (dstate-segment dstate))) - storage-location)) - stream)) - dstate) + (princ (sb!di:debug-var-symbol + (aref (storage-info-debug-vars + (seg-storage-info (dstate-segment dstate))) + storage-location)) + stream)) + dstate) t))) ;;; If there's a valid mapping from OFFSET in the storage-base called @@ -1991,34 +1875,33 @@ ;;; a note was recorded. (defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate) (declare (type offset offset) - (type symbol sb-name) - (type (or symbol string) assoc-with) - (type disassem-state dstate)) + (type symbol sb-name) + (type (or symbol string) assoc-with) + (type disassem-state dstate)) (let ((storage-location - (find-valid-storage-location offset sb-name dstate))) + (find-valid-storage-location offset sb-name dstate))) (when storage-location (note (lambda (stream) - (format stream "~A = ~S" - assoc-with - (sb!di:debug-var-symbol - (aref (dstate-debug-vars dstate) - storage-location)) - stream)) - dstate) + (format stream "~A = ~S" + assoc-with + (sb!di:debug-var-symbol + (aref (dstate-debug-vars dstate) + storage-location)))) + dstate) t))) (defun get-internal-error-name (errnum) (car (svref sb!c:*backend-internal-errors* errnum))) (defun get-sc-name (sc-offs) - (sb!c::location-print-name + (sb!c:location-print-name ;; FIXME: This seems like an awful lot of computation just to get a name. ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons ;; up a new object? (sb!c:make-random-tn :kind :normal - :sc (svref sb!c:*backend-sc-numbers* - (sb!c:sc-offset-scn sc-offs)) - :offset (sb!c:sc-offset-offset sc-offs)))) + :sc (svref sb!c:*backend-sc-numbers* + (sb!c:sc-offset-scn sc-offs)) + :offset (sb!c:sc-offset-offset sc-offs)))) ;;; When called from an error break instruction's :DISASSEM-CONTROL (or ;;; :DISASSEM-PRINTER) function, will correctly deal with printing the @@ -2038,27 +1921,28 @@ ;;; of the return values. (defun handle-break-args (error-parse-fun stream dstate) (declare (type function error-parse-fun) - (type (or null stream) stream) - (type disassem-state dstate)) + (type (or null stream) stream) + (type disassem-state dstate)) (multiple-value-bind (errnum adjust sc-offsets lengths) (funcall error-parse-fun - (dstate-segment-sap dstate) - (dstate-next-offs dstate) - (null stream)) + (dstate-segment-sap dstate) + (dstate-next-offs dstate) + (null stream)) (when stream (setf (dstate-cur-offs dstate) - (dstate-next-offs dstate)) + (dstate-next-offs dstate)) (flet ((emit-err-arg (note) - (let ((num (pop lengths))) - (print-notes-and-newline stream dstate) - (print-current-address stream dstate) - (print-bytes num stream dstate) - (incf (dstate-cur-offs dstate) num) - (when note - (note note dstate))))) - (emit-err-arg nil) - (emit-err-arg (symbol-name (get-internal-error-name errnum))) - (dolist (sc-offs sc-offsets) - (emit-err-arg (get-sc-name sc-offs))))) + (let ((num (pop lengths))) + (print-notes-and-newline stream dstate) + (print-current-address stream dstate) + (print-inst num stream dstate) + (print-bytes num stream dstate) + (incf (dstate-cur-offs dstate) num) + (when note + (note note dstate))))) + (emit-err-arg nil) + (emit-err-arg (symbol-name (get-internal-error-name errnum))) + (dolist (sc-offs sc-offsets) + (emit-err-arg (get-sc-name sc-offs))))) (incf (dstate-next-offs dstate) - adjust))) + adjust)))