X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdisassem.lisp;h=785c81ffde2cd6ddfb1ffa94d0d6cd9c02f915e3;hb=9767de1cecfe50560fe1da69fd458b6148a66da3;hp=93d9eb88172174780ce6b0bbb10f513a8366b061;hpb=09957fcf57b49ed5ae5f05d62ad12d7ddbfd8e1d;p=sbcl.git diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index 93d9eb8..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) @@ -85,7 +84,7 @@ ;; these are not in the params because they only exist at compile time (defparameter ,(format-table-name) (make-hash-table)) (defparameter ,(arg-type-table-name) nil) - (defparameter ,(function-cache-name) (make-function-cache))) + (defparameter ,(fun-cache-name) (make-fun-cache))) (let ((params (or sb!c:*backend-disassem-params* (setf sb!c:*backend-disassem-params* (make-params))))) @@ -102,14 +101,18 @@ |# ;;;; cached functions +;;;; +;;;; FIXME: Is it important to cache these? For performance? Or why? +;;;; If performance: *Really*? How fast does disassembly need to be?? +;;;; So: Could we just punt this? -(defstruct (function-cache (:copier nil)) +(defstruct (fun-cache (:copier nil)) (printers nil :type list) (labellers nil :type list) (prefilters nil :type list)) -(defvar *disassem-function-cache* (make-function-cache)) -(declaim (type function-cache *disassem-function-cache*)) +(defvar *disassem-fun-cache* (make-fun-cache)) +(declaim (type fun-cache *disassem-fun-cache*)) ;;;; A DCHUNK contains the bits we look at to decode an ;;;; instruction. @@ -128,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)) @@ -229,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) @@ -256,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 @@ -292,10 +299,10 @@ (defvar *disassem-inst-formats* (make-hash-table)) (defvar *disassem-arg-types* nil) -(defvar *disassem-function-cache* (make-function-cache)) +(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) @@ -315,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)) @@ -423,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)))) @@ -434,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)) @@ -479,7 +486,7 @@ `(let* ((*current-instruction-flavor* ',(cons base-name format-name)) (,format-var (format-or-lose ',format-name)) (args ,(gen-args-def-form field-defs format-var evalp)) - (funcache *disassem-function-cache*)) + (funcache *disassem-fun-cache*)) (multiple-value-bind (printer-fun printer-defun) (find-printer-fun ',uniquified-name ',format-name @@ -580,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 @@ -662,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)))) @@ -812,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 @@ -940,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) @@ -985,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)) @@ -999,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) @@ -1034,8 +1040,8 @@ (if (null printer-source) (values nil nil) (let ((printer-source (preprocess-printer printer-source args))) - (!with-cached-function - (name funstate cache function-cache-printers args + (!with-cached-fun + (name funstate cache fun-cache-printers args :constraint printer-source :stem (concatenate 'string (string %name) @@ -1211,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 @@ -1407,8 +1414,8 @@ (mapcar #'arg-name (remove-if-not #'arg-use-label args)))) (if (null labelled-fields) (values nil nil) - (!with-cached-function - (name funstate cache function-cache-labellers args + (!with-cached-fun + (name funstate cache fun-cache-labellers args :stem (concatenate 'string "LABELLER-" (string %name)) :constraint labelled-fields) (let ((labels-form 'labels)) @@ -1445,8 +1452,8 @@ (remove-if-not #'arg-prefilter args)))) (if (null filtered-args) (values nil nil) - (!with-cached-function - (name funstate cache function-cache-prefilters args + (!with-cached-fun + (name funstate cache fun-cache-prefilters args :stem (concatenate 'string (string %name) "-" @@ -1476,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))))))))) @@ -1505,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)) @@ -1550,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. ;;;