X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdisassem.lisp;h=785c81ffde2cd6ddfb1ffa94d0d6cd9c02f915e3;hb=6a9bbe6f36179cee92001a1f9ed5ff38be512644;hp=6d8e46960c074d5c25d9c7330cddb89c9fff5ccf;hpb=d40a76606c86722b0aef8179155f9f2840739b72;p=sbcl.git diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index 6d8e469..785c81f 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 @@ -298,8 +301,8 @@ (defvar *disassem-arg-types* nil) (defvar *disassem-fun-cache* (make-fun-cache)) -(defstruct (argument (:conc-name arg-) - (:copier nil)) +(defstruct (arg (:copier nil) + (:predicate nil)) (name nil :type symbol) (fields nil :type list) @@ -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)) @@ -427,7 +430,7 @@ (munge-fun-refs (cddr override) evalp))) overrides)) -(defparameter *arg-function-params* +(defparameter *arg-fun-params* '((:printer . (value stream dstate)) (:use-label . (value dstate)) (:prefilter . (value dstate)))) @@ -438,7 +441,7 @@ (wrapper-defs nil)) ((null tail) (values params (nreverse wrapper-defs))) - (let ((fun-arg (assoc (car tail) *arg-function-params*))) + (let ((fun-arg (assoc (car tail) *arg-fun-params*))) (when fun-arg (let* ((fun-form (cadr tail)) (quoted-fun-form `',fun-form)) @@ -584,7 +587,7 @@ fields, they are all sign-extended. :TYPE arg-type-name - Inherit any properties of the given argument-type. + Inherit any properties of the given argument type. :PREFILTER function A function which is called (along with all other prefilters, in the @@ -666,7 +669,7 @@ (let* ((arg-pos (position arg-name args :key #'arg-name)) (arg (if (null arg-pos) - (let ((arg (make-argument :name arg-name))) + (let ((arg (make-arg :name arg-name))) (if (null args) (setf args (list arg)) (push arg (cdr (last args)))) @@ -816,39 +819,38 @@ (car (push (cons kind nil) (cdr this-arg-temps)))))) (setf (cdr this-kind-temps) (cons vars forms))))) -(defmacro define-argument-type (name &rest args) - #!+sb-doc - "DEFINE-ARGUMENT-TYPE Name {Key Value}* - Define a disassembler argument type NAME (which can then be referenced in - another argument definition using the :TYPE argument). &KEY args are: - - :SIGN-EXTEND boolean - If non-NIL, the raw value of this argument is sign-extended. - - :TYPE arg-type-name - Inherit any properties of given argument-type. - - :PREFILTER function - A function which is called (along with all other prefilters, in the - order that their arguments appear in the instruction- format) before - any printing is done, to filter the raw value. Any uses of READ-SUFFIX - must be done inside a prefilter. - - :PRINTER function-string-or-vector - A function, string, or vector which is used to print an argument of - this type. - - :USE-LABEL - If non-NIL, the value of an argument of this type is used as an - address, and if that address occurs inside the disassembled code, it is - replaced by a label. If this is a function, it is called to filter the - value." +;;; DEFINE-ARG-TYPE Name {Key Value}* +;;; +;;; Define a disassembler argument type NAME (which can then be referenced in +;;; another argument definition using the :TYPE argument). &KEY args are: +;;; +;;; :SIGN-EXTEND boolean +;;; If non-NIL, the raw value of this argument is sign-extended. +;;; +;;; :TYPE arg-type-name +;;; Inherit any properties of given arg-type. +;;; +;;; :PREFILTER function +;;; A function which is called (along with all other prefilters, +;;; in the order that their arguments appear in the instruction- +;;; format) before any printing is done, to filter the raw value. +;;; Any uses of READ-SUFFIX must be done inside a prefilter. +;;; +;;; :PRINTER function-string-or-vector +;;; A function, string, or vector which is used to print an argument of +;;; this type. +;;; +;;; :USE-LABEL +;;; If non-NIL, the value of an argument of this type is used as +;;; an address, and if that address occurs inside the disassembled +;;; code, it is replaced by a label. If this is a function, it is +;;; called to filter the value. +(defmacro define-arg-type (name &rest args) (gen-arg-type-def-form name args)) +;;; Generate a form to define a disassembler argument type. See +;;; DEFINE-ARG-TYPE for more information. (defun gen-arg-type-def-form (name args &optional (evalp t)) - #!+sb-doc - "Generate a form to define a disassembler argument type. See - DEFINE-ARGUMENT-TYPE for more info." (multiple-value-bind (args wrapper-defs) (munge-fun-refs args evalp t name) `(progn @@ -944,7 +946,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) @@ -989,13 +991,13 @@ (valsrc-value thing) thing)) -(defstruct (cached-function (:conc-name cached-fun-) - (:copier nil)) +(defstruct (cached-fun (:conc-name cached-fun-) + (:copier nil)) (funstate nil :type (or null funstate)) (constraint nil :type list) (name nil :type (or null symbol))) -(defun find-cached-function (cached-funs args constraint) +(defun find-cached-fun (cached-funs args constraint) (dolist (cached-fun cached-funs nil) (let ((funstate (cached-fun-funstate cached-fun))) (when (and (equal constraint (cached-fun-constraint cached-fun)) @@ -1003,29 +1005,29 @@ (funstate-compatible-p funstate args))) (return cached-fun))))) -(defmacro !with-cached-function ((name-var - funstate-var - cache - cache-slot - args - &key - constraint - (stem (missing-arg))) - &body defun-maker-forms) +(defmacro !with-cached-fun ((name-var + funstate-var + cache + cache-slot + args + &key + constraint + (stem (missing-arg))) + &body defun-maker-forms) (let ((cache-var (gensym)) (constraint-var (gensym))) `(let* ((,constraint-var ,constraint) - (,cache-var (find-cached-function (,cache-slot ,cache) - ,args ,constraint-var))) + (,cache-var (find-cached-fun (,cache-slot ,cache) + ,args ,constraint-var))) (cond (,cache-var (values (cached-fun-name ,cache-var) nil)) (t (let* ((,name-var (symbolicate "CACHED-FUN--" ,stem)) (,funstate-var (make-funstate ,args)) (,cache-var - (make-cached-function :name ,name-var - :funstate ,funstate-var - :constraint ,constraint-var))) + (make-cached-fun :name ,name-var + :funstate ,funstate-var + :constraint ,constraint-var))) (values ,name-var `(progn ,(progn ,@defun-maker-forms) @@ -1038,7 +1040,7 @@ (if (null printer-source) (values nil nil) (let ((printer-source (preprocess-printer printer-source args))) - (!with-cached-function + (!with-cached-fun (name funstate cache fun-cache-printers args :constraint printer-source :stem (concatenate 'string @@ -1215,6 +1217,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 @@ -1411,7 +1414,7 @@ (mapcar #'arg-name (remove-if-not #'arg-use-label args)))) (if (null labelled-fields) (values nil nil) - (!with-cached-function + (!with-cached-fun (name funstate cache fun-cache-labellers args :stem (concatenate 'string "LABELLER-" (string %name)) :constraint labelled-fields) @@ -1449,7 +1452,7 @@ (remove-if-not #'arg-prefilter args)))) (if (null filtered-args) (values nil nil) - (!with-cached-function + (!with-cached-fun (name funstate cache fun-cache-prefilters args :stem (concatenate 'string (string %name) @@ -1480,7 +1483,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))))))))) @@ -1509,11 +1512,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)) @@ -1554,6 +1557,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. ;;;