X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=878935359971dbfeda1cd6e9885a0ea210c97428;hb=56ce3857f7830670d55d2fe17246353dff2e71f7;hp=1b38c051cdb490529d95993846c26daeb16fc8f5;hpb=3c65762b927af861c9c8bc416e4cbac9a14ec0c3;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 1b38c05..8789353 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -218,7 +218,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 ;;; @@ -252,13 +252,13 @@ (defstruct (offs-hook (:copier nil)) (offset 0 :type offset) - (function (required-argument) :type function) + (function (missing-arg) :type function) (before-address nil :type (member t nil))) (defstruct (segment (:conc-name seg-) (:constructor %make-segment) (:copier nil)) - (sap-maker (required-argument) + (sap-maker (missing-arg) :type (function () sb!sys:system-area-pointer)) (length 0 :type length) (virtual-location 0 :type address) @@ -281,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 - - (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 + ;; 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) ; + ;; list of offs-hook, popped as it's 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 @@ -421,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) @@ -435,7 +440,7 @@ (incf (dstate-next-offs dstate) lra-size)) nil) -;;; Print the function-header (entry-point) pseudo-instruction at the +;;; Print the fun-header (entry-point) pseudo-instruction at the ;;; current location in DSTATE to STREAM. (defun fun-header-hook (stream dstate) (declare (type (or null stream) stream) @@ -532,7 +537,7 @@ (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) @@ -805,19 +810,19 @@ (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)) @@ -968,13 +973,13 @@ (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)) -(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 @@ -1000,7 +1005,8 @@ (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))))) @@ -1020,41 +1026,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))))) @@ -1367,7 +1373,8 @@ 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 @@ -1495,7 +1502,7 @@ (dolist (seg segments) (disassemble-segment seg stream dstate))))) -;;;; top-level functions +;;;; top level functions ;;; Disassemble the machine code instructions for FUNCTION. (defun disassemble-function (function &key @@ -1726,7 +1733,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) @@ -1742,7 +1749,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)