X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=6c922b6941806006e7a77f67e2d3bed3484a2228;hb=0a82f2db352cc348d2107a882e50af222ff97ed3;hp=380472c8044630c853eb106ac7039d384f26db80;hpb=0b5610d8a220a4b20cbeac958953ca4d67c00038;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 380472c..6c922b6 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,28 @@ (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" + (error "~@" 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 +74,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 +94,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 +116,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 +153,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 +177,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 +196,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.) @@ -244,15 +237,14 @@ #!-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))) @@ -289,43 +281,48 @@ (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 - + ;; 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 (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 + ;; 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) + ;; 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) - (fun-hooks nil :type list) ; list of function + ;; alist of (address . label-number), popped as it's used + (cur-labels nil :type list) ; + ;; list of offs-hook, popped as it's used + (cur-offs-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 + ;; for the current location + (notes nil :type list) - (notes nil :type list) ; for the current location - - (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 @@ -333,15 +330,13 @@ (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)))) @@ -349,52 +344,48 @@ (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))) +;;; 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)) @@ -435,7 +426,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) @@ -443,16 +434,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 function-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) @@ -463,19 +453,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) @@ -501,12 +494,12 @@ (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))) @@ -544,17 +537,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) @@ -617,31 +609,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 @@ -659,16 +650,15 @@ (format nil "L~D" 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)) @@ -685,26 +675,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))) @@ -714,10 +704,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 @@ -776,29 +765,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*) + (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)) @@ -810,9 +797,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)) @@ -824,25 +810,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*) @@ -883,15 +868,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)) @@ -908,23 +893,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 @@ -934,7 +920,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)) @@ -959,7 +945,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 @@ -976,11 +962,11 @@ 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... @@ -1026,10 +1012,10 @@ (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 @@ -1090,9 +1076,9 @@ ;;;; 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!di::get-debug-info-fun-map (sb!kernel:%code-debug-info code))) (defstruct (location-group (:copier nil)) (locations #() :type (vector (or list fixnum)))) @@ -1101,17 +1087,16 @@ (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 +1120,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 +1137,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 +1151,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) @@ -1223,9 +1206,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,13 +1221,13 @@ (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) @@ -1254,7 +1237,7 @@ :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 +1247,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 +1261,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 ";;; [~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. @@ -1297,78 +1280,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))) + (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 ((anh (n) (push (make-offs-hook :offset 0 - :function #'(lambda (stream dstate) - (declare (ignore stream)) - (note n dstate))) + :function (lambda (stream dstate) + (declare (ignore stream)) + (note n dstate))) (seg-hooks segment)))) (case kind (:external) ((nil) - (anh "No-arg-parsing entry point")) + (anh "no-arg-parsing entry point")) (t - (anh #'(lambda (stream) - (format stream "~S entry point" kind))))))))) + (anh (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) - #!+sb-doc - "Returns a list of the segments of memory containing machine code - instructions for 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~%" 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 +1362,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))) (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)) @@ -1545,11 +1502,10 @@ ;;;; top-level functions +;;; Disassemble the machine code instructions for FUNCTION. (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) (type stream stream) (type (member t nil) use-labels)) @@ -1565,7 +1521,7 @@ (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)) @@ -1573,12 +1529,10 @@ (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)) ((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 +1541,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 +1549,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-function (compiled-function-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 +1590,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 +1609,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 +1632,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 +1663,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 +1672,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 +1700,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,7 +1731,7 @@ ;;; 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) @@ -1804,7 +1747,7 @@ ;;; 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) @@ -1814,7 +1757,7 @@ (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)))))))) @@ -1845,22 +1788,49 @@ (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) -;;; Return the name of the primitive Lisp assembler routine located at -;;; ADDRESS, or NIL if there isn't one. +(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) (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... @@ -1905,11 +1875,10 @@ ;;;; 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))) @@ -1923,99 +1892,112 @@ (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) @@ -2023,13 +2005,13 @@ (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))) @@ -2046,24 +2028,23 @@ (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))