X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=3879374f0d919783bc9605f173d54566e103ca52;hb=c713eb2b521b048ff2c927ec52b861787d289f85;hp=c634cda8642e6180517ec6ccb789151289f5ea12;hpb=5eb97830eca716fef626c6e12429c99c9b97e3c8;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index c634cda..3879374 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -17,10 +17,10 @@ ;;;; combining instructions where one specializes another +;;; Return non-NIL if the instruction SPECIAL is a more specific +;;; version of GENERAL (i.e., the same instruction, but with more +;;; constraints). (defun inst-specializes-p (special general) - #!+sb-doc - "Returns non-NIL if the instruction SPECIAL is a more specific version of - GENERAL (i.e., the same instruction, but with more constraints)." (declare (type instruction special general)) (let ((smask (inst-mask special)) (gmask (inst-mask general))) @@ -29,30 +29,29 @@ (dchunk-strict-superset-p smask gmask)))) ;;; a bit arbitrary, but should work ok... +;;; +;;; Return an integer corresponding to the specificity of the +;;; instruction INST. (defun specializer-rank (inst) - #!+sb-doc - "Returns an integer corresponding to the specificity of the instruction INST." (declare (type instruction inst)) (* (dchunk-count-bits (inst-mask inst)) 4)) +;;; Order the list of instructions INSTS with more specific (more +;;; constant bits, or same-as argument constains) ones first. Returns +;;; the ordered list. (defun order-specializers (insts) - #!+sb-doc - "Order the list of instructions INSTS with more specific (more constant - bits, or same-as argument constains) ones first. Returns the ordered list." (declare (type list insts)) - (sort insts - #'(lambda (i1 i2) - (> (specializer-rank i1) (specializer-rank i2))))) + (sort insts #'> :key #'specializer-rank)) (defun specialization-error (insts) - (error "Instructions either aren't related or conflict in some way:~% ~S" - 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 +;;; specializers list, and it is returned. Otherwise an error is signaled. (defun try-specializing (insts) - #!+sb-doc - "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 - specializers list, and it is returned. Otherwise an error is signaled." (declare (type list insts)) (let ((masters (copy-list insts))) (dolist (possible-master insts) @@ -76,18 +75,16 @@ #!-sb-fluid (declaim (inline inst-matches-p choose-inst-specialization)) +;;; Return non-NIL if all constant-bits in INST match CHUNK. (defun inst-matches-p (inst chunk) - #!+sb-doc - "Returns non-NIL if all constant-bits in INST match CHUNK." (declare (type instruction inst) (type dchunk chunk)) (dchunk= (dchunk-and (inst-mask inst) chunk) (inst-id inst))) +;;; Given an instruction object, INST, and a bit-pattern, CHUNK, pick +;;; the most specific instruction on INST's specializer list whose +;;; constraints are met by CHUNK. If none do, then return INST. (defun choose-inst-specialization (inst chunk) - #!+sb-doc - "Given an instruction object, INST, and a bit-pattern, CHUNK, picks the - most specific instruction on INST's specializer list whose constraints are - met by CHUNK. If none do, then INST is returned." (declare (type instruction inst) (type dchunk chunk)) (or (dolist (spec (inst-specializers inst) nil) @@ -98,10 +95,9 @@ ;;;; searching for an instruction in instruction space +;;; Return the instruction object within INST-SPACE corresponding to the +;;; bit-pattern CHUNK, or NIL if there isn't one. (defun find-inst (chunk inst-space) - #!+sb-doc - "Returns the instruction object within INST-SPACE corresponding to the - bit-pattern CHUNK, or NIL if there isn't one." (declare (type dchunk chunk) (type (or null inst-space instruction) inst-space)) (etypecase inst-space @@ -121,11 +117,10 @@ ;;;; building the instruction space +;;; Returns an instruction-space object corresponding to the list of +;;; instructions INSTS. If the optional parameter INITIAL-MASK is +;;; supplied, only bits it has set are used. (defun build-inst-space (insts &optional (initial-mask dchunk-one)) - #!+sb-doc - "Returns an instruction-space object corresponding to the list of - instructions INSTS. If the optional parameter INITIAL-MASK is supplied, only - bits it has set are used." ;; This is done by finding any set of bits that's common to ;; all instructions, building an instruction-space node that selects on those ;; bits, and recursively handle sets of instructions with a common value for @@ -159,12 +154,12 @@ (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))) + :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 @@ -183,9 +178,8 @@ 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)) - #!+sb-doc - "Prints a nicely formatted version of INST-SPACE." (etypecase inst-space (null) (instruction @@ -203,12 +197,12 @@ 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))) + (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.) @@ -225,7 +219,7 @@ ;;; ;;; start of instructions ;;; ... -;;; function-headers and lra's buried in here randomly +;;; fun-headers and lra's buried in here randomly ;;; ... ;;; start of trace-table ;;; @@ -244,28 +238,28 @@ #!-sb-fluid (declaim (inline words-to-bytes bytes-to-words)) (eval-when (:compile-toplevel :load-toplevel :execute) + ;;; Convert a word-offset NUM to a byte-offset. (defun words-to-bytes (num) - "Converts a word-offset NUM to a byte-offset." (declare (type offset num)) (ash num sb!vm:word-shift)) ) ; EVAL-WHEN +;;; Convert a byte-offset NUM to a word-offset. (defun bytes-to-words (num) - #!+sb-doc - "Converts a byte-offset NUM to a word-offset." (declare (type offset num)) (ash num (- sb!vm:word-shift))) (defconstant lra-size (words-to-bytes 1)) -(defstruct offs-hook +(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)) - (sap-maker (required-argument) + (:constructor %make-segment) + (:copier nil)) + (sap-maker (missing-arg) :type (function () sb!sys:system-area-pointer)) (length 0 :type length) (virtual-location 0 :type address) @@ -275,7 +269,7 @@ (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~]" + (format stream "#X~X[~W]~:[ (#X~X)~;~*~]~@[ in ~S~]" addr (seg-length seg) (= (seg-virtual-location seg) addr) @@ -286,60 +280,64 @@ ;;; 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)) - (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 + (:constructor %make-dstate) + (:copier nil)) + ;; offset of current pos in segment + (cur-offs 0 :type offset) + ;; offset of next position + (next-offs 0 :type offset) + ;; a sap pointing to our segment + (segment-sap (missing-arg) :type sb!sys:system-area-pointer) + ;; the current segment + (segment nil :type (or null segment)) + ;; what to align to in most cases + (alignment sb!vm:n-word-bytes :type alignment) (byte-order :little-endian :type (member :big-endian :little-endian)) - - (properties nil :type list) ; for user code to hang stuff off of + ;; for user code to hang stuff off of + (properties nil :type list) (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))) + ;; used for prettifying printing + (addr-print-len nil :type (or null (integer 0 20))) (argument-column 0 :type column) - (output-state :beginning ; to make output look nicer + ;; to make output look nicer + (output-state :beginning :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 + ;; alist of (address . label-number) + (labels nil :type list) + ;; same as LABELS slot data, but in a different form + (label-hash (make-hash-table) :type hash-table) + ;; list of function + (fun-hooks nil :type list) - ;; 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 + ;; alist of (address . label-number), popped as it's used + (cur-labels nil :type list) + ;; OFFS-HOOKs, popped as they're used + (cur-offs-hooks nil :type list) - (notes nil :type list) ; for the current location + ;; for the current location + (notes nil :type list) - (current-valid-locations nil ; currently active source variables - :type (or null (vector bit)))) + ;; currently active source variables + (current-valid-locations nil :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~]" + "+~W~@[ in ~S~]" (dstate-cur-offs dstate) (dstate-segment dstate)))) +;;; Return the absolute address of the current instruction in DSTATE. (defun dstate-cur-addr (dstate) - #!+sb-doc - "Returns the absolute address of the current instruction in 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) - #!+sb-doc - "Returns the absolute address of the next instruction in DSTATE." (the address (+ (seg-virtual-location (dstate-segment dstate)) (dstate-next-offs dstate)))) @@ -347,55 +345,54 @@ (defun fun-self (fun) (declare (type compiled-function fun)) - (sb!kernel:%function-self fun)) + (sb!kernel:%simple-fun-self 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 fun)) (defun fun-address (function) (declare (type compiled-function function)) - (- (sb!kernel:get-lisp-obj-address function) sb!vm:function-pointer-type)) + (- (sb!kernel:get-lisp-obj-address function) sb!vm:fun-pointer-lowtag)) +;;; the offset of FUNCTION from the start of its code-component's +;;; instruction area (defun fun-insts-offset (function) - #!+sb-doc - "Offset of FUNCTION from the start of its code-component's instruction area." (declare (type compiled-function function)) (- (fun-address function) (sb!sys:sap-int (sb!kernel:code-instructions (fun-code function))))) +;;; the offset of FUNCTION from the start of its code-component (defun fun-offset (function) - #!+sb-doc - "Offset of FUNCTION from the start of its code-component." (declare (type compiled-function function)) (words-to-bytes (sb!kernel:get-closure-length function))) ;;;; operations on code-components (which hold the instructions for ;;;; one or more functions) +;;; Return the length of the instruction area in CODE-COMPONENT. (defun code-inst-area-length (code-component) - #!+sb-doc - "Returns the length of the instruction area in CODE-COMPONENT." (declare (type sb!kernel:code-component code-component)) (sb!kernel:code-header-ref code-component sb!vm:code-trace-table-offset-slot)) +;;; Return the address of the instruction area in CODE-COMPONENT. (defun code-inst-area-address (code-component) - #!+sb-doc - "Returns the address of the instruction area in 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) - #!+sb-doc - "Returns the first function in CODE-COMPONENT." (declare (type sb!kernel:code-component code-component)) (sb!kernel:code-header-ref code-component sb!vm:code-trace-table-offset-slot)) +|# (defun segment-offs-to-code-offs (offset segment) (sb!sys:without-gcing @@ -433,7 +430,7 @@ (type disassem-state dstate)) (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate)) (dstate-cur-offs dstate)) - (* 2 sb!vm:word-bytes)) + (* 2 sb!vm:n-word-bytes)) ;; Check type. (= (sb!sys:sap-ref-8 (dstate-segment-sap dstate) (if (eq (dstate-byte-order dstate) @@ -441,16 +438,15 @@ (dstate-cur-offs dstate) (+ (dstate-cur-offs dstate) (1- lra-size)))) - sb!vm:return-pc-header-type)) + sb!vm:return-pc-header-widetag)) (unless (null stream) (princ '.lra stream)) (incf (dstate-next-offs dstate) lra-size)) nil) +;;; Print the fun-header (entry-point) pseudo-instruction at the +;;; current location in DSTATE to STREAM. (defun fun-header-hook (stream dstate) - #!+sb-doc - "Print the function-header (entry-point) pseudo-instruction at the current - location in DSTATE to STREAM." (declare (type (or null stream) stream) (type disassem-state dstate)) (unless (null stream) @@ -461,19 +457,22 @@ (segment-offs-to-code-offs (dstate-cur-offs dstate) seg))) (name (sb!kernel:code-header-ref code - (+ woffs sb!vm:function-name-slot))) + (+ woffs + sb!vm:simple-fun-name-slot))) (args (sb!kernel:code-header-ref code - (+ woffs sb!vm:function-arglist-slot))) + (+ woffs + sb!vm:simple-fun-arglist-slot))) (type (sb!kernel:code-header-ref code - (+ woffs sb!vm:function-type-slot)))) + (+ 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 () + (note (lambda (stream) + (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) @@ -486,7 +485,7 @@ (alignment (dstate-alignment dstate))) (unless (aligned-p location alignment) (when stream - (format stream "~A~Vt~D~%" '.align + (format stream "~A~Vt~W~%" '.align (dstate-argument-column dstate) alignment)) (incf(dstate-next-offs dstate) @@ -499,16 +498,16 @@ (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))))))) + (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)) (let ((cur-offs (dstate-cur-offs dstate))) @@ -524,12 +523,12 @@ (not (offs-hook-before-address next-hook)))) (return)) (unless (< hook-offs cur-offs) - (funcall (offs-hook-function next-hook) stream dstate)) + (funcall (offs-hook-fun 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) +(defun call-fun-hooks (chunk stream dstate) (let ((hooks (dstate-fun-hooks dstate)) (cur-offs (dstate-cur-offs dstate))) (setf (dstate-next-offs dstate) cur-offs) @@ -542,17 +541,16 @@ (let ((alignment (dstate-alignment dstate))) (unless (null stream) (multiple-value-bind (words bytes) - (truncate alignment sb!vm:word-bytes) + (truncate alignment sb!vm:n-word-bytes) (when (> words 0) (print-words words stream dstate)) (when (> bytes 0) (print-bytes bytes 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. (defun map-segment-instructions (function segment dstate &optional stream) - #!+sb-doc - "Iterate through the instructions in SEGMENT, calling FUNCTION - for each instruction, with arguments of CHUNK, STREAM, and DSTATE." (declare (type function function) (type segment segment) (type disassem-state dstate) @@ -571,10 +569,10 @@ (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) + (call-offs-hooks nil stream dstate) (unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) (sb!sys:without-gcing @@ -584,7 +582,7 @@ (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))) + (let ((fun-prefix-p (call-fun-hooks chunk stream dstate))) (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate)) (setf prefix-p fun-prefix-p) (let ((inst (find-inst chunk ispace))) @@ -615,31 +613,30 @@ (print-notes-and-newline stream dstate)) (setf (dstate-output-state dstate) nil))))) +;;; Make an initial non-printing disassembly pass through DSTATE, +;;; noting any addresses that are referenced by instructions in this +;;; segment. (defun add-segment-labels (segment dstate) - #!+sb-doc - "Make an initial non-printing disassembly pass through DSTATE, noting any - addresses that are referenced by instructions in this segment." ;; add labels at the beginning with a label-number of nil; we'll notice ;; later and fill them in (and sort them) (declare (type disassem-state dstate)) (let ((labels (dstate-labels dstate))) (map-segment-instructions - #'(lambda (chunk inst) - (declare (type dchunk chunk) (type instruction inst)) - (let ((labeller (inst-labeller inst))) - (when labeller - (setf labels (funcall labeller chunk labels dstate))))) + (lambda (chunk inst) + (declare (type dchunk chunk) (type instruction inst)) + (let ((labeller (inst-labeller inst))) + (when labeller + (setf labels (funcall labeller chunk labels dstate))))) segment dstate) (setf (dstate-labels dstate) labels) ;; erase any notes that got there by accident (setf (dstate-notes dstate) nil))) +;;; If any labels in DSTATE have been added since the last call to +;;; this function, give them label-numbers, enter them in the +;;; hash-table, and make sure the label list is in sorted order. (defun number-labels (dstate) - #!+sb-doc - "If any labels in DSTATE have been added since the last call to this - function, give them label-numbers, enter them in the hash-table, and make - sure the label list is in sorted order." (let ((labels (dstate-labels dstate))) (when (and labels (null (cdar labels))) ;; at least one label left un-numbered @@ -654,19 +651,18 @@ (incf max) (setf (cdr label) max) (setf (gethash (car label) label-hash) - (format nil "L~D" max))))) + (format nil "L~W" max))))) (setf (dstate-labels dstate) labels)))) +;;; Get the instruction-space, creating it if necessary. (defun get-inst-space () - #!+sb-doc - "Get the instruction-space, creating it if necessary." (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))) + (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)) @@ -683,26 +679,26 @@ (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))))) + (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))))) + (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))) @@ -712,10 +708,9 @@ ;; 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) - #!+sb-doc - "Print the current address in DSTATE to STREAM, plus any labels that - correspond to it, and leave the cursor in the instruction column." (declare (type stream stream) (type disassem-state dstate)) (let* ((location @@ -726,15 +721,15 @@ (when (null plen) (setf plen location-column-width) - (set-location-printing-range dstate - (seg-virtual-location (dstate-segment dstate)) - (seg-length (dstate-segment dstate)))) + (let ((seg (dstate-segment dstate))) + (set-location-printing-range dstate + (seg-virtual-location seg) + (seg-length seg)))) (when (eq (dstate-output-state dstate) :beginning) (setf plen location-column-width)) (fresh-line stream) - ;; MNA: compiler message patch (setf location-column-width (+ 2 location-column-width)) (princ "; " stream) @@ -759,7 +754,7 @@ (when (or (null label-location) (> label-location location)) (return)) (unless (< label-location location) - (format stream " L~D:" (cdr next-label))) + (format stream " L~W:" (cdr next-label))) (pop (dstate-cur-labels dstate)))) ;; move to the instruction column @@ -774,30 +769,27 @@ (*print-level* 3)) ,@body))) +;;; Print a newline to STREAM, inserting any pending notes in DSTATE +;;; as end-of-line comments. If there is more than one note, a +;;; separate line will be used for each one. (defun print-notes-and-newline (stream dstate) - #!+sb-doc - "Print a newline to STREAM, inserting any pending notes in DSTATE as - end-of-line comments. If there is more than one note, a separate line - will be used for each one." (declare (type stream stream) (type disassem-state dstate)) (with-print-restrictions (dolist (note (dstate-notes dstate)) - (format stream "~Vt; " *disassem-note-column*) - ;; MNA: compiler message patch + (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)))) + (funcall note stream)))) (terpri stream)) (fresh-line stream) (setf (dstate-notes dstate) nil))) +;;; Disassemble NUM bytes to STREAM as simple `BYTE' instructions. (defun print-bytes (num stream dstate) - #!+sb-doc - "Disassemble NUM bytes to STREAM as simple `BYTE' instructions" (declare (type offset num) (type stream stream) (type disassem-state dstate)) @@ -809,9 +801,8 @@ (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) - #!+sb-doc - "Disassemble NUM machine-words to STREAM as simple `WORD' instructions" (declare (type offset num) (type stream stream) (type disassem-state dstate)) @@ -823,25 +814,24 @@ (unless (zerop word-offs) (write-string ", " stream)) (let ((word 0) (bit-shift 0)) - (dotimes (byte-offs sb!vm:word-bytes) + (dotimes (byte-offs sb!vm:n-word-bytes) (let ((byte (sb!sys:sap-ref-8 sap (+ start-offs - (* word-offs sb!vm:word-bytes) + (* word-offs sb!vm:n-word-bytes) byte-offs)))) (setf word (if (eq byte-order :big-endian) - (+ (ash word sb!vm:byte-bits) byte) + (+ (ash word sb!vm:n-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))))) + (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*)) - #!+sb-doc - "Make a disassembler-state object." (let ((sap (sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8))))) (alignment *disassem-inst-alignment-bytes*) @@ -869,7 +859,7 @@ ((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) + (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. @@ -882,15 +872,15 @@ (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))))))) + (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))))))) (defun vector-sap-maker (vector offset) (declare (optimize (speed 3)) @@ -907,23 +897,24 @@ (declare (optimize (speed 3)) (type address address)) (let ((sap (sb!sys:int-sap address))) - #'(lambda () sap))) + (lambda () sap))) +;;; Return a memory segment located at the system-area-pointer returned by +;;; SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE. +;;; +;;; &KEY arguments include :VIRTUAL-LOCATION (by default the same as +;;; the address), :DEBUG-FUN, :SOURCE-FORM-CACHE (a +;;; SOURCE-FORM-CACHE object), and :HOOKS (a list of OFFS-HOOK +;;; objects). (defun make-segment (sap-maker length &key code virtual-location - debug-function source-form-cache + debug-fun source-form-cache hooks) - #!+sb-doc - "Return a memory segment located at the system-area-pointer returned by - SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE. - Optional keyword arguments include :VIRTUAL-LOCATION (by default the same as - the address), :DEBUG-FUNCTION, :SOURCE-FORM-CACHE (a source-form-cache - object), and :HOOKS (a list of offs-hook objects)." (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-function) debug-function) + (type (or null sb!di:debug-fun) debug-fun) (type (or null source-form-cache) source-form-cache)) (let* ((segment (%make-segment @@ -933,7 +924,7 @@ (sb!sys:sap-int (funcall sap-maker))) :hooks hooks :code code))) - (add-debugging-hooks segment debug-function source-form-cache) + (add-debugging-hooks segment debug-fun source-form-cache) (add-fun-header-hooks segment) segment)) @@ -958,7 +949,7 @@ (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 @@ -971,28 +962,28 @@ (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~%" + (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:function-name-slot)) + code (+ fun-offset sb!vm:simple-fun-name-slot)) (sb!kernel:code-header-ref - code (+ fun-offset sb!vm:function-arglist-slot)) + code (+ fun-offset sb!vm:simple-fun-arglist-slot)) (sb!kernel:code-header-ref - code (+ fun-offset sb!vm:function-type-slot))))))) + code (+ fun-offset sb!vm:simple-fun-type-slot))))))) ;;; getting at the source code... -(defstruct (source-form-cache (:conc-name sfcache-)) +(defstruct (source-form-cache (:conc-name sfcache-) + (: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) + (toplevel-form-index -1 :type fixnum) + (toplevel-form nil :type list) (form-number-mapping-table nil :type (or null (vector list))) (last-location-retrieved nil :type (or null sb!di:code-location)) - (last-form-retrieved -1 :type fixnum) - ) + (last-form-retrieved -1 :type fixnum)) -(defun get-top-level-form (debug-source tlf-index) +(defun get-toplevel-form (debug-source tlf-index) (let ((name (sb!di:debug-source-name debug-source))) (ecase (sb!di:debug-source-from debug-source) (:file @@ -1018,17 +1009,18 @@ (file-position f char-offset)) (t (warn "Source file ~S has been modified; ~@ - using form offset instead of file index." + 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)))) + (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 @@ -1038,41 +1030,41 @@ (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))))) + (eq (sb!di:code-location-toplevel-form-offset loc) + (sfcache-toplevel-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)) + (tlf-index (sb!di:code-location-toplevel-form-offset loc)) (form-number (sb!di:code-location-form-number loc)) - (top-level-form + (toplevel-form (if cache-valid - (sfcache-top-level-form cache) - (get-top-level-form (sb!di:code-location-debug-source loc) + (sfcache-toplevel-form cache) + (get-toplevel-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)))) + (sb!di:form-number-translations toplevel-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-toplevel-form-index cache) tlf-index + (sfcache-toplevel-form cache) toplevel-form (sfcache-form-number-mapping-table cache) mapping-table)) - (cond ((null top-level-form) + (cond ((null toplevel-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)) + (setf (sfcache-toplevel-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 + (sb!di:source-path-context toplevel-form (aref mapping-table form-number) context))))) @@ -1087,31 +1079,29 @@ (values nil nil) (values (get-source-form loc context cache) t))) -;;;; stuff to use debugging-info to augment the disassembly +;;;; stuff to use debugging info to augment the disassembly -(defun code-function-map (code) +(defun code-fun-map (code) (declare (type sb!kernel:code-component code)) - (sb!di::get-debug-info-function-map (sb!kernel:%code-debug-info code))) + (sb!c::compiled-debug-info-fun-map (sb!kernel:%code-debug-info code))) -(defstruct location-group - (locations #() :type (vector (or list fixnum))) - ) +(defstruct (location-group (:copier nil)) + (locations #() :type (vector (or list fixnum)))) -(defstruct storage-info +(defstruct (storage-info (:copier nil)) (groups nil :type list) ; alist of (name . location-group) (debug-vars #() :type vector)) +;;; Return the vector of DEBUG-VARs currently associated with DSTATE. (defun dstate-debug-vars (dstate) - #!+sb-doc - "Return the vector of DEBUG-VARs currently associated with DSTATE." (declare (type disassem-state dstate)) (storage-info-debug-vars (seg-storage-info (dstate-segment dstate)))) +;;; Given the OFFSET of a location within the location-group called +;;; LG-NAME, see whether there's a current mapping to a source +;;; variable in DSTATE, and if so, return the offset of that variable +;;; in the current debug-var vector. (defun find-valid-storage-location (offset lg-name dstate) - #!+sb-doc - "Given the OFFSET of a location within the location-group called LG-NAME, - see whether there's a current mapping to a source variable in DSTATE, and - if so, return the offset of that variable in the current debug-var vector." (declare (type offset offset) (type symbol lg-name) (type disassem-state dstate)) @@ -1135,11 +1125,11 @@ (zerop (bit currently-valid used-by))) used-by)) (list - (some #'(lambda (num) - (and (not - (zerop - (bit currently-valid num))) - num)) + (some (lambda (num) + (and (not + (zerop + (bit currently-valid num))) + num)) used-by))))) (and debug-var-num (progn @@ -1152,11 +1142,10 @@ 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) - #!+sb-doc - "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." (declare (type vector vec) (type fixnum new-len)) (let ((new @@ -1167,15 +1156,14 @@ (setf (aref new i) (aref vec i))) new)) -(defun storage-info-for-debug-function (debug-function) - #!+sb-doc - "Returns a STORAGE-INFO struction describing the object-to-source - variable mappings from DEBUG-FUNCTION." - (declare (type sb!di:debug-function debug-function)) +;;; Return a STORAGE-INFO struction describing the object-to-source +;;; variable mappings from DEBUG-FUN. +(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-function-debug-vars - debug-function))) + (debug-vars (sb!di::debug-fun-debug-vars + debug-fun))) (and debug-vars (dotimes (debug-var-offset (length debug-vars) @@ -1183,7 +1171,7 @@ :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) + (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 @@ -1191,7 +1179,7 @@ (sb!c:sc-sb (aref sc-vec (sb!c:sc-offset-scn sc-offset)))))) #+nil - (format t ";;; SET: ~S[~D]~%" + (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)))) @@ -1223,9 +1211,9 @@ ))))))) ))) -(defun source-available-p (debug-function) +(defun source-available-p (debug-fun) (handler-case - (sb!di:do-debug-function-blocks (block debug-function) + (sb!di:do-debug-fun-blocks (block debug-fun) (declare (ignore block)) (return t)) (sb!di:no-debug-blocks () nil))) @@ -1238,23 +1226,23 @@ (setf (dstate-output-state dstate) :block-boundary)))) -(defun add-source-tracking-hooks (segment debug-function &optional sfcache) - #!+sb-doc - "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 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-function) debug-function) + (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 + :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-function-blocks (block debug-function) + (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))) @@ -1264,8 +1252,8 @@ (/= pc last-block-pc)) (setf first-location-in-block-p nil) (add-hook pc - #'(lambda (stream dstate) - (print-block-boundary stream dstate)) + (lambda (stream dstate) + (print-block-boundary stream dstate)) t) (setf last-block-pc pc)) @@ -1278,17 +1266,17 @@ (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))) + (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. @@ -1297,78 +1285,77 @@ 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)))) + (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))))) -(defun add-debugging-hooks (segment debug-function &optional sfcache) - (when debug-function +(defun add-debugging-hooks (segment debug-fun &optional sfcache) + (when debug-fun (setf (seg-storage-info segment) - (storage-info-for-debug-function debug-function)) - (add-source-tracking-hooks segment debug-function sfcache) - (let ((kind (sb!di:debug-function-kind debug-function))) - (flet ((anh (n) + (storage-info-for-debug-fun debug-fun)) + (add-source-tracking-hooks segment debug-fun sfcache) + (let ((kind (sb!di:debug-fun-kind debug-fun))) + (flet ((add-new-hook (n) (push (make-offs-hook :offset 0 - :function #'(lambda (stream dstate) - (declare (ignore stream)) - (note n dstate))) + :fun (lambda (stream dstate) + (declare (ignore stream)) + (note n dstate))) (seg-hooks segment)))) (case kind (:external) ((nil) - (anh "No-arg-parsing entry point")) + (add-new-hook "no-arg-parsing entry point")) (t - (anh #'(lambda (stream) - (format stream "~S entry point" kind))))))))) + (add-new-hook (lambda (stream) + (format stream "~S entry point" kind))))))))) -(defun get-function-segments (function) - #!+sb-doc - "Returns a list of the segments of memory containing machine code - instructions for FUNCTION." +;;; Return a list of the segments of memory containing machine code +;;; instructions for FUNCTION. +(defun get-fun-segments (function) (declare (type compiled-function function)) (let* ((code (fun-code function)) - (function-map (code-function-map code)) - (fname (sb!kernel:%function-name function)) + (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-function nil) + (last-debug-fun nil) (segments nil)) (flet ((add-seg (offs len df) (when (> len 0) (push (make-code-segment code offs len - :debug-function df + :debug-fun df :source-form-cache sfcache) segments)))) - (dotimes (fmap-index (length function-map)) - (let ((fmap-entry (aref function-map fmap-index))) + (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-function) - (setf last-debug-function nil)) + last-debug-fun) + (setf last-debug-fun nil)) (setf last-offset fmap-entry)) - (sb!c::compiled-debug-function - (let ((name (sb!c::compiled-debug-function-name fmap-entry)) - (kind (sb!c::compiled-debug-function-kind 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~%" + (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-function-start-pc fmap-entry)) + (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)) @@ -1380,154 +1367,129 @@ (return)) (when first-block-seen-p (setf nil-block-seen-p t)))) - (setf last-debug-function - (sb!di::make-compiled-debug-function fmap-entry code)) - ))))) + (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-function) + (when (and first-block-seen-p last-debug-fun) (add-seg last-offset (- max-offset last-offset) - last-debug-function)) + last-debug-fun)) (if (null segments) (let ((offs (fun-insts-offset function))) - (make-code-segment code offs (- max-offset offs))) + (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-offs 0) + (start-offset 0) (length (code-inst-area-length code))) - #!+sb-doc - "Returns a list of the segments of memory containing machine code - instructions for the code-component CODE. If START-OFFS and/or LENGTH is - supplied, only that part of the code-segment is used (but these are - constrained to lie within the code-segment)." (declare (type sb!kernel:code-component code) - (type offset start-offs) + (type offset start-offset) (type length length)) (let ((segments nil)) (when code - (let ((function-map (code-function-map code)) + (let ((fun-map (code-fun-map code)) (sfcache (make-source-form-cache))) (let ((last-offset 0) - (last-debug-function nil)) + (last-debug-fun nil)) (flet ((add-seg (offs len df) (let* ((restricted-offs - (min (max start-offs offs) (+ start-offs length))) + (min (max start-offset offs) + (+ start-offset length))) (restricted-len - (- (min (max start-offs (+ offs len)) - (+ start-offs length)) + (- (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-function df + :debug-fun df :source-form-cache sfcache) segments))))) - (dotimes (fmap-index (length function-map)) - (let ((fmap-entry (aref function-map fmap-index))) - (etypecase fmap-entry + (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 (- fmap-entry last-offset) - last-debug-function) - (setf last-debug-function nil) - (setf last-offset fmap-entry)) - (sb!c::compiled-debug-function - (setf last-debug-function - (sb!di::make-compiled-debug-function fmap-entry - code)))))) - (when last-debug-function + (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-function)))))) + last-debug-fun)))))) (if (null segments) - (make-code-segment code start-offs length) + (make-code-segment code start-offset length) (nreverse segments)))) -#+nil -(defun find-function-segment (fun) - #!+sb-doc - "Return the address of the instructions for function and its length. - The length is computed using a heuristic, and so may not be accurate." - (declare (type compiled-function fun)) - (let* ((code - (fun-code fun)) - (fun-addr - (- (sb!kernel:get-lisp-obj-address fun) sb!vm:function-pointer-type)) - (max-length - (code-inst-area-length code)) - (upper-bound - (+ (code-inst-area-address code) max-length))) - (do ((some-fun (code-first-function code) - (fun-next some-fun))) - ((null some-fun) - (values fun-addr (- upper-bound fun-addr))) - (let ((some-addr (fun-address some-fun))) - (when (and (> some-addr fun-addr) - (< some-addr upper-bound)) - (setf upper-bound some-addr)))))) - +;;; 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) - #!+sb-doc - "Returns 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, this will return 0 and 0." (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))) + (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) - #!+sb-doc - "Computes 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 it can find references from one to another." (declare (type list seglist) (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 + ;; 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))) + (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) - #!+sb-doc - "Disassemble the machine code instructions in SEGMENT to STREAM." (declare (type segment segment) (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)))) + (lambda (chunk inst) + (declare (type dchunk chunk) (type instruction inst)) + (let ((printer (inst-printer inst))) + (when printer + (funcall printer chunk inst stream dstate)))) segment dstate stream))) +;;; Disassemble the machine code instructions in each memory segment +;;; in SEGMENTS in turn to STREAM. (defun disassemble-segments (segments stream dstate) - #!+sb-doc - "Disassemble the machine code instructions in each memory segment in - SEGMENTS in turn to STREAM." (declare (type list segments) (type stream stream) (type disassem-state dstate)) @@ -1543,42 +1505,41 @@ (dolist (seg segments) (disassemble-segment seg stream dstate))))) -;;;; top-level functions +;;;; top level functions -(defun disassemble-function (function &key - (stream *standard-output*) - (use-labels t)) - #!+sb-doc - "Disassemble the machine code instructions for FUNCTION." - (declare (type compiled-function function) +;;; Disassemble the machine code instructions for FUNCTION. +(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))) +;;; FIXME: We probably don't need this any more now that there are +;;; no interpreted functions, only compiled ones. (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 "cannot compile a lexical closure")) + (error "can't compile a lexical closure")) (compile nil lambda))) -(defun compiled-function-or-lose (thing &optional (name thing)) +(defun compiled-fun-or-lose (thing &optional (name thing)) (cond ((or (symbolp thing) (and (listp thing) (eq (car thing) 'setf))) - (compiled-function-or-lose (fdefinition thing) thing)) - ((sb!eval:interpreted-function-p thing) - (compile-function-lambda-expr thing)) + (compiled-fun-or-lose (fdefinition thing) thing)) ((functionp thing) thing) ((and (listp thing) - (eq (car thing) 'sb!impl::lambda)) + (eq (car thing) 'lambda)) (compile nil thing)) (t (error "can't make a compiled function from ~S" name)))) @@ -1587,7 +1548,7 @@ (stream *standard-output*) (use-labels t)) #!+sb-doc - "Disassemble the machine code associated with OBJECT, which can be a + "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." @@ -1595,25 +1556,21 @@ (type (or (member t) stream) stream) (type (member t nil) use-labels)) (pprint-logical-block (*standard-output* nil :per-line-prefix "; ") - (let ((fun (compiled-function-or-lose object))) - (if (typep fun 'sb!kernel:byte-function) - (sb!c:disassem-byte-fun fun) - ;; we can't detect closures, so be careful - (disassemble-function (fun-self fun) - :stream stream - :use-labels use-labels))) - (values))) + (disassemble-fun (compiled-fun-or-lose object) + :stream stream + :use-labels use-labels) + 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)) - #!+sb-doc - "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." (declare (type (or address sb!sys:system-area-pointer) address) (type length length) (type stream stream) @@ -1640,12 +1597,11 @@ (label-segments segments dstate)) (disassemble-segments segments stream dstate))) +;;; 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)) - #!+sb-doc - "Disassemble the machine code instructions associated with - CODE-COMPONENT (this may include multiple entry points)." (declare (type (or null sb!kernel:code-component compiled-function) code-component) (type stream stream) @@ -1660,22 +1616,19 @@ (label-segments segments dstate)) (disassemble-segments segments stream dstate))) -;;; Code for making useful segments from arbitrary lists of code-blocks +;;; code for making useful segments from arbitrary lists of code-blocks -;;; The maximum size of an instruction -- 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!). +;;; 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 sap-to-vector (sap start end) - (let* ((length (- end start)) - (result (make-array length :element-type '(unsigned-byte 8))) - (sap (sb!sys:sap+ sap start))) - (dotimes (i length) - (setf (aref result i) (sb!sys:sap-ref-8 sap i))) - result)) - -(defun add-block-segments (sap amount seglist location connecting-vec dstate) +(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) @@ -1686,25 +1639,27 @@ (setf (seg-length seg) length) (incf location length) (push seg seglist))))) - (let ((connecting-overflow 0)) + (let ((connecting-overflow 0) + (amount (length seg-code-block))) (when connecting-vec - ;; tack on some of the new block to the old overflow vector + ;; Tack on some of the new block to the old overflow vector. (let* ((beginning-of-block-amount - (if sap (min max-instruction-size amount) 0)) + (if seg-code-block (min max-instruction-size amount) 0)) (connecting-vec - (if sap + (if seg-code-block (concatenate '(vector (unsigned-byte 8)) connecting-vec - (sap-to-vector sap 0 beginning-of-block-amount)) + (subseq seg-code-block 0 beginning-of-block-amount)) connecting-vec))) (when (and (< (length connecting-vec) max-instruction-size) - (not (null sap))) + (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 sap wasn't large - ;; enough to do this (and is now entirely on the end of the - ;; overflow-vector), just save it for next time. + ;; 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 @@ -1715,8 +1670,8 @@ :virtual-location location))) (setf connecting-overflow (segment-overflow seg dstate)) (addit seg connecting-overflow))))) - (cond ((null sap) - ;; Nothing more to add. + (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 @@ -1724,25 +1679,25 @@ ;; in the overflow vector for the time-being. (values seglist location - (sap-to-vector sap connecting-overflow amount))) + (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-segment #'(lambda () - (sb!sys:sap+ sap connecting-overflow)) - initial-length - :virtual-location location)) + (make-vector-segment seg-code-block + connecting-overflow + initial-length + :virtual-location location)) (overflow (segment-overflow seg dstate))) (addit seg overflow) (values seglist location - (sap-to-vector sap - (+ connecting-overflow (seg-length seg)) - amount)))))))) + (subseq seg-code-block + (+ connecting-overflow (seg-length seg)) + amount)))))))) ;;;; code to disassemble assembler segments @@ -1752,32 +1707,27 @@ (let ((location 0) (disassem-segments nil) (connecting-vec nil)) - (error "stub: code not converted to new SEGMENT WHN 19990322" ; KLUDGE - assem-segment) ; (to avoid "ASSEM-SEGMENT defined but never used") - ;; old code, needs to be converted to use less-SAPpy ASSEM-SEGMENTs: - #|(sb!assem:segment-map-output + (sb!assem:on-segment-contents-vectorly assem-segment - #'(lambda (sap amount) - (multiple-value-setq (disassem-segments location connecting-vec) - (add-block-segments sap amount - disassem-segments location - connecting-vec - dstate))))|# + (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 nil - disassem-segments location + (add-block-segments nil + disassem-segments + location connecting-vec dstate))) (sort disassem-segments #'< :key #'seg-virtual-location))) -;;; FIXME: I noticed that this is only called by #!+SB-SHOW code. It would -;;; be good to see whether this is the only caller of any other functions. -#!+sb-show +;;; Disassemble the machine code instructions associated with +;;; ASSEM-SEGMENT (of type assem:segment). (defun disassemble-assem-segment (assem-segment stream) - #!+sb-doc - "Disassemble the machine code instructions associated with - ASSEM-SEGMENT (of type assem:segment)." (declare (type sb!assem:segment assem-segment) (type stream stream)) (let* ((dstate (make-dstate)) @@ -1788,27 +1738,25 @@ ;;; routines to find things in the Lisp environment -(defconstant groked-symbol-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) - #!+sb-doc - "An alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots in a -symbol object that we know about.") + :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 +;;; big deal... Return two values, the symbol and the name of the +;;; access function of the slot. (defun grok-symbol-slot-ref (address) - #!+sb-doc - "Given ADDRESS, try and figure out if which slot of which symbol is being - refered to. Of course we can just give up, so it's not a big deal... - Returns two values, the symbol and the name of the access function of the - slot." (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 groked-symbol-slots (cdr slots-tail))) + (do ((slots-tail *grokked-symbol-slots* (cdr slots-tail))) ((null slots-tail) (values nil nil)) (let* ((field (car slots-tail)) @@ -1816,31 +1764,30 @@ symbol object that we know about.") (maybe-symbol-addr (- address slot-offset)) (maybe-symbol (sb!kernel:make-lisp-obj - (+ maybe-symbol-addr sb!vm:other-pointer-type)))) + (+ 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)) +;;; Given a BYTE-OFFSET from NIL, try and figure out which slot of +;;; which symbol is being referred to. Of course we can just give up, +;;; so it's not a big deal... Return two values, the symbol and the +;;; access function. (defun grok-nil-indexed-symbol-slot-ref (byte-offset) - #!+sb-doc - "Given a BYTE-OFFSET from NIL, try and figure out if which slot of which - symbol is being refered to. Of course we can just give up, so it's not a big - deal... Returns two values, the symbol and the access function." (declare (type offset byte-offset)) (grok-symbol-slot-ref (+ *address-of-nil-object* byte-offset))) +;;; Return the Lisp object located BYTE-OFFSET from NIL. (defun get-nil-indexed-object (byte-offset) - #!+sb-doc - "Returns the lisp object located BYTE-OFFSET from NIL." (declare (type offset byte-offset)) (sb!kernel:make-lisp-obj (+ *address-of-nil-object* byte-offset))) +;;; Return two values; the Lisp object located at BYTE-OFFSET in the +;;; constant area of the code-object in the current segment and T, or +;;; NIL and NIL if there is no code-object in the current segment. (defun get-code-constant (byte-offset dstate) #!+sb-doc - "Returns two values; the lisp-object located at BYTE-OFFSET in the constant - area of the code-object in the current segment and T, or NIL and NIL if - there is no code-object in the current segment." (declare (type offset byte-offset) (type disassem-state dstate)) (let ((code (seg-code (dstate-segment dstate)))) @@ -1848,23 +1795,49 @@ symbol object that we know about.") (values (sb!kernel:code-header-ref code (ash (+ byte-offset - sb!vm:other-pointer-type) + sb!vm:other-pointer-lowtag) (- sb!vm:word-shift))) t) (values nil nil)))) +(defun get-code-constant-absolute (addr dstate) + (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-lowtag))) + (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))))))) + (defvar *assembler-routines-by-addr* nil) +(defvar *foreign-symbols-by-addr* nil) + +;;; 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)) + htable) + addr-hash) + +;;; Return the name of the primitive Lisp assembler routine or foreign +;;; symbol located at ADDRESS, or NIL if there isn't one. (defun find-assembler-routine (address) - #!+sb-doc - "Returns the name of the primitive lisp assembler routine located at - ADDRESS, or NIL if there isn't one." (declare (type address address)) (when (null *assembler-routines-by-addr*) - (setf *assembler-routines-by-addr* (make-hash-table)) - (maphash #'(lambda (name address) - (setf (gethash address *assembler-routines-by-addr*) name)) - sb!kernel:*assembler-routines*)) + (setf *assembler-routines-by-addr* + (invert-address-hash sb!fasl:*assembler-routines*)) + (setf *assembler-routines-by-addr* + (invert-address-hash sb!fasl:*static-foreign-symbols* + *assembler-routines-by-addr*))) (gethash address *assembler-routines-by-addr*)) ;;;; some handy function for machine-dependent code to use... @@ -1909,11 +1882,10 @@ symbol object that we know about.") ;;;; optional routines to make notes about code +;;; Store NOTE (which can be either a string or a function with a +;;; single stream argument) to be printed as an end-of-line comment +;;; after the current instruction is disassembled. (defun note (note dstate) - #!+sb-doc - "Store NOTE (which can be either a string or a function with a single - stream argument) to be printed as an end-of-line comment after the current - instruction is disassembled." (declare (type (or string function) note) (type disassem-state dstate)) (push note (dstate-notes dstate))) @@ -1927,99 +1899,112 @@ symbol object that we know about.") (prin1-short thing stream) (prin1-short `',thing stream))) +;;; Store a note about the lisp constant located BYTE-OFFSET bytes +;;; from the current code-component, to be printed as an end-of-line +;;; comment after the current instruction is disassembled. (defun note-code-constant (byte-offset dstate) - #!+sb-doc - "Store a note about the lisp constant located BYTE-OFFSET bytes from the - current code-component, to be printed as an end-of-line comment after the - current instruction is disassembled." (declare (type offset byte-offset) (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)) + (note (lambda (stream) + (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) + (declare (type address addr) + (type disassem-state dstate)) + (multiple-value-bind (const valid) + (get-code-constant-absolute addr dstate) + (when valid + (note (lambda (stream) + (prin1-quoted-short const stream)) + dstate)) + (values const valid))) + +;;; If the memory address located NIL-BYTE-OFFSET bytes from the +;;; constant NIL is a valid slot in a symbol, store a note describing +;;; which symbol and slot, to be printed as an end-of-line comment +;;; after the current instruction is disassembled. Returns non-NIL iff +;;; a note was recorded. (defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate) - #!+sb-doc - "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL - is a valid slot in a symbol, store a note describing which symbol and slot, - to be printed as an end-of-line comment after the current instruction is - disassembled. Returns non-NIL iff a note was recorded." (declare (type offset nil-byte-offset) (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)) + (note (lambda (stream) + (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 +;;; constant NIL is a valid lisp object, store a note describing which +;;; symbol and slot, to be printed as an end-of-line comment after the +;;; current instruction is disassembled. Returns non-NIL iff a note +;;; was recorded. (defun maybe-note-nil-indexed-object (nil-byte-offset dstate) - #!+sb-doc - "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL - is a valid lisp object, store a note describing which symbol and slot, to - be printed as an end-of-line comment after the current instruction is - disassembled. Returns non-NIL iff a note was recorded." (declare (type offset nil-byte-offset) (type disassem-state dstate)) (let ((obj (get-nil-indexed-object nil-byte-offset))) - (note #'(lambda (stream) - (prin1-quoted-short obj stream)) + (note (lambda (stream) + (prin1-quoted-short obj stream)) dstate) t)) +;;; If ADDRESS is the address of a primitive assembler routine or +;;; foreign symbol, store a note describing which one, to be printed +;;; as an end-of-line comment after the current instruction is +;;; disassembled. Returns non-NIL iff a note was recorded. If +;;; NOTE-ADDRESS-P is non-NIL, a note of the address is also made. (defun maybe-note-assembler-routine (address note-address-p dstate) - #!+sb-doc - "If ADDRESS is the address of a primitive assembler routine, store a note - describing which one, to be printed as an end-of-line comment after the - current instruction is disassembled. Returns non-NIL iff a note was - recorded. If NOTE-ADDRESS-P is non-NIL, a note of the address is also made." - (declare (type address address) - (type disassem-state dstate)) + (declare (type disassem-state dstate)) + (unless (typep address 'address) + (return-from maybe-note-assembler-routine nil)) (let ((name (find-assembler-routine address))) (unless (null name) - (note #'(lambda (stream) - (if NOTE-ADDRESS-P - (format stream "#X~8,'0x: ~S" address name) - (prin1 name stream))) + (note (lambda (stream) + (if note-address-p + (format stream "#x~8,'0x: ~a" address name) + (princ name stream))) dstate)) name)) +;;; If there's a valid mapping from OFFSET in the storage class +;;; SC-NAME to a source variable, make a note of the source-variable +;;; name, to be printed as an end-of-line comment after the current +;;; instruction is disassembled. Returns non-NIL iff a note was +;;; recorded. (defun maybe-note-single-storage-ref (offset sc-name dstate) - #!+sb-doc - "If there's a valid mapping from OFFSET in the storage class SC-NAME to a - source variable, make a note of the source-variable name, to be printed as - an end-of-line comment after the current instruction is disassembled. - Returns non-NIL iff a note was recorded." (declare (type offset offset) (type symbol sc-name) (type disassem-state dstate)) (let ((storage-location (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)) + (note (lambda (stream) + (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 +;;; SB-NAME to a source variable, make a note equating ASSOC-WITH with +;;; the source-variable name, to be printed as an end-of-line comment +;;; after the current instruction is disassembled. Returns non-NIL iff +;;; a note was recorded. (defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate) - #!+sb-doc - "If there's a valid mapping from OFFSET in the storage-base called SB-NAME - to a source variable, make a note equating ASSOC-WITH with the - source-variable name, to be printed as an end-of-line comment after the - current instruction is disassembled. Returns non-NIL iff a note was - recorded." (declare (type offset offset) (type symbol sb-name) (type (or symbol string) assoc-with) @@ -2027,13 +2012,13 @@ symbol object that we know about.") (let ((storage-location (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)) + (note (lambda (stream) + (format stream "~A = ~S" + assoc-with + (sb!di:debug-var-symbol + (aref (dstate-debug-vars dstate) + storage-location)) + stream)) dstate) t))) @@ -2050,24 +2035,23 @@ symbol object that we know about.") (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 +;;; arguments to the break. +;;; +;;; ERROR-PARSE-FUN should be a function that accepts: +;;; 1) a SYSTEM-AREA-POINTER +;;; 2) a BYTE-OFFSET from the SAP to begin at +;;; 3) optionally, LENGTH-ONLY, which if non-NIL, means to only return +;;; the byte length of the arguments (to avoid unnecessary consing) +;;; It should read information from the SAP starting at BYTE-OFFSET, and +;;; return four values: +;;; 1) the error number +;;; 2) the total length, in bytes, of the information +;;; 3) a list of SC-OFFSETs of the locations of the error parameters +;;; 4) a list of the length (as read from the SAP), in bytes, of each +;;; of the return values. (defun handle-break-args (error-parse-fun stream dstate) - #!+sb-doc - "When called from an error break instruction's :DISASSEM-CONTROL (or - :DISASSEM-PRINTER) function, will correctly deal with printing the - arguments to the break. - - ERROR-PARSE-FUN should be a function that accepts: - 1) a SYSTEM-AREA-POINTER - 2) a BYTE-OFFSET from the SAP to begin at - 3) optionally, LENGTH-ONLY, which if non-NIL, means to only return - the byte length of the arguments (to avoid unnecessary consing) - It should read information from the SAP starting at BYTE-OFFSET, and return - four values: - 1) the error number - 2) the total length, in bytes, of the information - 3) a list of SC-OFFSETs of the locations of the error parameters - 4) a list of the length (as read from the SAP), in bytes, of each of the - return-values." (declare (type function error-parse-fun) (type (or null stream) stream) (type disassem-state dstate))