X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdisassem.lisp;h=5332dea0b7a690776396e191d202a5ef1518285b;hb=988afd9d54ba6c8a915544822658824ab6ae0d6c;hp=1477c4cffebf81af11128cc8ea058a37d57ec335;hpb=0bca0cb1bf5ce5572ab5cd7ba59f87fed1f2edb0;p=sbcl.git diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index 1477c4c..5332dea 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -13,16 +13,16 @@ ;;; types and defaults -(defconstant label-column-width 7) +(def!constant label-column-width 7) (deftype text-width () '(integer 0 1000)) (deftype alignment () '(integer 0 64)) (deftype offset () '(signed-byte 24)) (deftype address () '(unsigned-byte 32)) -(deftype length () '(unsigned-byte 24)) +(deftype disassem-length () '(unsigned-byte 24)) (deftype column () '(integer 0 1000)) -(defconstant max-filtered-value-index 32) +(def!constant max-filtered-value-index 32) (deftype filtered-value-index () `(integer 0 ,max-filtered-value-index)) (deftype filtered-value-vector () @@ -35,7 +35,6 @@ (declaim (type hash-table *disassem-insts*)) (defvar *disassem-inst-space* nil) -(declaim (type (or null inst-space) *disassem-inst-space*)) ;;; minimum alignment of instructions, in bytes (defvar *disassem-inst-alignment-bytes* sb!vm:n-word-bytes) @@ -132,15 +131,15 @@ dchunk= dchunk-count-bits)) -(defconstant dchunk-bits 32) +(def!constant dchunk-bits 32) (deftype dchunk () `(unsigned-byte ,dchunk-bits)) (deftype dchunk-index () `(integer 0 ,dchunk-bits)) -(defconstant dchunk-zero 0) -(defconstant dchunk-one #xFFFFFFFF) +(def!constant dchunk-zero 0) +(def!constant dchunk-one #xFFFFFFFF) (defun dchunk-extract (from pos) (declare (type dchunk from)) @@ -233,7 +232,7 @@ (mask dchunk-zero :type dchunk) ; bits in the inst that are constant (id dchunk-zero :type dchunk) ; value of those constant bits - (length 0 :type length) ; in bytes + (length 0 :type disassem-length) ; in bytes (print-name nil :type symbol) @@ -260,6 +259,10 @@ (def!method print-object ((ispace inst-space) stream) (print-unreadable-object (ispace stream :type t :identity t))) +;;; now that we've defined the structure, we can declaim the type of +;;; the variable: +(declaim (type (or null inst-space) *disassem-inst-space*)) + (defstruct (inst-space-choice (:conc-name ischoice-) (:copier nil)) (common-id dchunk-zero :type dchunk) ; applies to *parent's* mask @@ -319,7 +322,7 @@ (name nil) (args nil :type list) - (length 0 :type length) ; in bytes + (length 0 :type disassem-length) ; in bytes (default-printer nil :type list)) @@ -344,6 +347,7 @@ (let* ((old-arg (car this-arg-temps)) (new-arg (find (arg-name old-arg) args :key #'arg-name))) (and new-arg + (= (arg-position old-arg) (arg-position new-arg)) (every (lambda (this-kind-temps) (funcall (find-arg-form-checker (car this-kind-temps)) @@ -943,7 +947,7 @@ (let ((form (maybe-listify adjusted-forms))) (if (and (not (eq use-label t)) (not (atom adjusted-forms)) - (/= (Length adjusted-forms) 1)) + (/= (length adjusted-forms) 1)) (pd-error "cannot label a multiple-field argument ~ unless using a function: ~S" arg) @@ -1214,6 +1218,7 @@ (cons car cdr))) (defun sharing-mapcar (fun list) + (declare (type function fun)) #!+sb-doc "A simple (one list arg) mapcar that avoids consing up a new list as long as the results of calling FUN on the elements of LIST are @@ -1479,7 +1484,7 @@ (declare (ignorable #'local-filter #'local-extract) (inline (setf local-filtered-value) local-filter local-extract)) - ;; Use them for side-effects only. + ;; Use them for side effects only. (let* ,(make-arg-temp-bindings funstate) ,@(forms))))))))) @@ -1508,11 +1513,11 @@ (declaim (maybe-inline sign-extend aligned-p align tab tab0)) (defun bytes-to-bits (bytes) - (declare (type length bytes)) + (declare (type disassem-length bytes)) (* bytes sb!vm:n-byte-bits)) (defun bits-to-bytes (bits) - (declare (type length bits)) + (declare (type disassem-length bits)) (multiple-value-bind (bytes rbits) (truncate bits sb!vm:n-byte-bits) (when (not (zerop rbits)) @@ -1553,6 +1558,71 @@ (type disassem-state dstate) (optimize (speed 3) (safety 0))) (sign-extend (read-suffix length dstate) length)) + +;;; All state during disassembly. We store some seemingly redundant +;;; information so that we can allow garbage collect during disassembly and +;;; not get tripped up by a code block being moved... +(defstruct (disassem-state (:conc-name dstate-) + (:constructor %make-dstate) + (:copier nil)) + ;; 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)) + ;; for user code to hang stuff off of + (properties nil :type list) + (filtered-values (make-array max-filtered-value-index) + :type filtered-value-vector) + ;; used for prettifying printing + (addr-print-len nil :type (or null (integer 0 20))) + (argument-column 0 :type column) + ;; to make output look nicer + (output-state :beginning + :type (member :beginning + :block-boundary + nil)) + + ;; 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) + + ;; 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) + + ;; for the current location + (notes nil :type list) + + ;; 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 + "+~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) + (the address (+ (seg-virtual-location (dstate-segment dstate)) + (dstate-cur-offs dstate)))) + +;;; Return the absolute address of the next instruction in DSTATE. +(defun dstate-next-addr (dstate) + (the address (+ (seg-virtual-location (dstate-segment dstate)) + (dstate-next-offs dstate)))) ;;; Get the value of the property called NAME in DSTATE. Also SETF'able. ;;;