X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdisassem.lisp;h=a5165fe1bf0233c9754dac538eb9ba68b3c20e93;hb=c2431e2d0d0222a3cf20cfdfa48201bdcc65cd76;hp=d8afb76751df7c2b03311b334f5cb4fb19e162a7;hpb=50305b602c3953440af716137a56f50cd204375d;p=sbcl.git diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index d8afb76..a5165fe 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 address () '(unsigned-byte #.sb!vm:n-word-bits)) +(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) @@ -50,7 +49,15 @@ (defvar *disassem-opcode-column-width* 6) (declaim (type text-width *disassem-opcode-column-width*)) -(defvar *disassem-note-column* 45 +;;; the width of the column in which instruction-bytes are printed. A +;;; value of zero disables the printing of instruction bytes. +(defvar *disassem-inst-column-width* 16 + #!+sb-doc + "The width of instruction bytes.") +(declaim (type text-width *disassem-inst-column-width*)) + + +(defvar *disassem-note-column* (+ 45 *disassem-inst-column-width*) #!+sb-doc "The column in which end-of-line comments for notes are started.") @@ -85,7 +92,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 +109,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 +139,15 @@ dchunk= dchunk-count-bits)) -(defconstant dchunk-bits 32) +(def!constant dchunk-bits #.sb!vm:n-word-bits) (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 #.(1- (expt 2 sb!vm:n-word-bits))) (defun dchunk-extract (from pos) (declare (type dchunk from)) @@ -229,14 +240,14 @@ (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) ;; disassembly functions (prefilter nil :type (or null function)) (labeller nil :type (or null function)) - (printer (required-argument) :type (or null function)) + (printer (missing-arg) :type (or null function)) (control nil :type (or null function)) ;; instructions that are the same as this instruction but with more @@ -256,10 +267,14 @@ (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 - (subspace (required-argument) :type (or inst-space instruction))) + (subspace (missing-arg) :type (or inst-space instruction))) ;;;; These are the kind of values we can compute for an argument, and ;;;; how to compute them. The :CHECKER functions make sure that a given @@ -269,8 +284,8 @@ (defstruct (arg-form-kind (:copier nil)) (names nil :type list) - (producer (required-argument) :type function) - (checker (required-argument) :type function)) + (producer (missing-arg) :type function) + (checker (missing-arg) :type function)) (defun arg-form-kind-or-lose (kind) (or (getf *arg-form-kinds* kind) @@ -292,10 +307,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 +330,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)) @@ -336,16 +351,17 @@ (%make-funstate :args args)) (defun funstate-compatible-p (funstate args) - (every #'(lambda (this-arg-temps) - (let* ((old-arg (car this-arg-temps)) - (new-arg (find (arg-name old-arg) args :key #'arg-name))) - (and new-arg - (every #'(lambda (this-kind-temps) - (funcall (find-arg-form-checker - (car this-kind-temps)) - new-arg - old-arg)) - (cdr this-arg-temps))))) + (every (lambda (this-arg-temps) + (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)) + new-arg + old-arg)) + (cdr this-arg-temps))))) (funstate-arg-temps funstate))) (defun arg-or-lose (name funstate) @@ -418,12 +434,12 @@ (values wrapper-name `(defparameter ,wrapper-name ,form))))) (defun filter-overrides (overrides evalp) - (mapcar #'(lambda (override) - (list* (car override) (cadr override) - (munge-fun-refs (cddr override) evalp))) + (mapcar (lambda (override) + (list* (car override) (cadr override) + (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 +450,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)) @@ -452,20 +468,20 @@ (defun gen-args-def-form (overrides format-form &optional (evalp t)) (let ((args-var (gensym))) `(let ((,args-var (copy-list (format-args ,format-form)))) - ,@(mapcar #'(lambda (override) - (update-args-form args-var - `',(car override) - (and (cdr override) - (cons :value (cdr override))) - evalp)) + ,@(mapcar (lambda (override) + (update-args-form args-var + `',(car override) + (and (cdr override) + (cons :value (cdr override))) + evalp)) overrides) ,args-var))) (defun gen-printer-def-forms-def-form (base-name - uniquified-name - def - &optional - (evalp t)) + uniquified-name + def + &optional + (evalp t)) (declare (type symbol base-name)) (declare (type (or symbol string) uniquified-name)) (destructuring-bind @@ -479,11 +495,11 @@ `(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 - ,(if (eq printer-form :default) + ',format-name + ,(if (eq printer-form :default) `(format-default-printer ,format-var) (maybe-quote evalp printer-form)) args funcache) @@ -491,9 +507,9 @@ (find-labeller-fun ',uniquified-name args funcache) (multiple-value-bind (prefilter-fun prefilter-defun) (find-prefilter-fun ',uniquified-name - ',format-name - args - funcache) + ',format-name + args + funcache) (multiple-value-bind (mask id) (compute-mask-id args) (values @@ -580,7 +596,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 @@ -638,10 +654,10 @@ :args ,args-var)) (eval `(progn - ,@(mapcar #'(lambda (arg) - (when (arg-fields arg) - (gen-arg-access-macro-def-form - arg ,args-var ',name))) + ,@(mapcar (lambda (arg) + (when (arg-fields arg) + (gen-arg-access-macro-def-form + arg ,args-var ',name))) ,args-var)))))))))) ;;; FIXME: probably needed only at build-the-system time, not in @@ -662,13 +678,13 @@ (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)))) arg) (setf (nth arg-pos args) - (copy-structure (nth arg-pos args)))))) + (copy-structure (nth arg-pos args)))))) (when (and field-p (not fields-p)) (setf fields (list field)) (setf fields-p t)) @@ -691,20 +707,20 @@ can't specify fields except using DEFINE-INSTRUCTION-FORMAT~:>" arg-name)) (setf (arg-fields arg) - (mapcar #'(lambda (bytespec) - (when (> (+ (byte-position bytespec) - (byte-size bytespec)) - format-length) - (error "~@ (+ (byte-position bytespec) + (byte-size bytespec)) + format-length) + (error "~@" - arg-name - bytespec - format-length)) - (correct-dchunk-bytespec-for-endianness - bytespec - format-length - sb!c:*backend-byte-order*)) + instruction-format ~W bits wide.~:>" + arg-name + bytespec + format-length)) + (correct-dchunk-bytespec-for-endianness + bytespec + format-length + sb!c:*backend-byte-order*)) fields))) args)) @@ -752,8 +768,8 @@ ((atom (cadr atk)) (push `(,(cadr atk) ,(cddr atk)) bindings)) (t - (mapc #'(lambda (var form) - (push `(,var ,form) bindings)) + (mapc (lambda (var form) + (push `(,var ,form) bindings)) (cadr atk) (cddr atk)))))) bindings)) @@ -812,39 +828,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 @@ -855,35 +870,35 @@ (defmacro def-arg-form-kind ((&rest names) &rest inits) `(let ((kind (make-arg-form-kind :names ',names ,@inits))) - ,@(mapcar #'(lambda (name) - `(setf (getf *arg-form-kinds* ',name) kind)) + ,@(mapcar (lambda (name) + `(setf (getf *arg-form-kinds* ',name) kind)) names))) (def-arg-form-kind (:raw) - :producer #'(lambda (arg funstate) - (declare (ignore funstate)) - (mapcar #'(lambda (bytespec) - `(the (unsigned-byte ,(byte-size bytespec)) - (local-extract ',bytespec))) - (arg-fields arg))) - :checker #'(lambda (new-arg old-arg) - (equal (arg-fields new-arg) - (arg-fields old-arg)))) + :producer (lambda (arg funstate) + (declare (ignore funstate)) + (mapcar (lambda (bytespec) + `(the (unsigned-byte ,(byte-size bytespec)) + (local-extract ',bytespec))) + (arg-fields arg))) + :checker (lambda (new-arg old-arg) + (equal (arg-fields new-arg) + (arg-fields old-arg)))) (def-arg-form-kind (:sign-extended :unfiltered) - :producer #'(lambda (arg funstate) - (let ((raw-forms (gen-arg-forms arg :raw funstate))) - (if (and (arg-sign-extend-p arg) (listp raw-forms)) - (mapcar #'(lambda (form field) - `(the (signed-byte ,(byte-size field)) - (sign-extend ,form - ,(byte-size field)))) - raw-forms - (arg-fields arg)) - raw-forms))) - :checker #'(lambda (new-arg old-arg) - (equal (arg-sign-extend-p new-arg) - (arg-sign-extend-p old-arg)))) + :producer (lambda (arg funstate) + (let ((raw-forms (gen-arg-forms arg :raw funstate))) + (if (and (arg-sign-extend-p arg) (listp raw-forms)) + (mapcar (lambda (form field) + `(the (signed-byte ,(byte-size field)) + (sign-extend ,form + ,(byte-size field)))) + raw-forms + (arg-fields arg)) + raw-forms))) + :checker (lambda (new-arg old-arg) + (equal (arg-sign-extend-p new-arg) + (arg-sign-extend-p old-arg)))) (defun valsrc-equal (f1 f2) (if (null f1) @@ -892,73 +907,73 @@ (value-or-source f2)))) (def-arg-form-kind (:filtering) - :producer #'(lambda (arg funstate) - (let ((sign-extended-forms - (gen-arg-forms arg :sign-extended funstate)) - (pf (arg-prefilter arg))) - (if pf - (values - `(local-filter ,(maybe-listify sign-extended-forms) - ,(source-form pf)) - t) - (values sign-extended-forms nil)))) - :checker #'(lambda (new-arg old-arg) - (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg)))) + :producer (lambda (arg funstate) + (let ((sign-extended-forms + (gen-arg-forms arg :sign-extended funstate)) + (pf (arg-prefilter arg))) + (if pf + (values + `(local-filter ,(maybe-listify sign-extended-forms) + ,(source-form pf)) + t) + (values sign-extended-forms nil)))) + :checker (lambda (new-arg old-arg) + (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg)))) (def-arg-form-kind (:filtered :unadjusted) - :producer #'(lambda (arg funstate) - (let ((pf (arg-prefilter arg))) - (if pf - (values `(local-filtered-value ,(arg-position arg)) t) - (gen-arg-forms arg :sign-extended funstate)))) - :checker #'(lambda (new-arg old-arg) - (let ((pf1 (arg-prefilter new-arg)) - (pf2 (arg-prefilter old-arg))) - (if (null pf1) - (null pf2) - (= (arg-position new-arg) - (arg-position old-arg)))))) + :producer (lambda (arg funstate) + (let ((pf (arg-prefilter arg))) + (if pf + (values `(local-filtered-value ,(arg-position arg)) t) + (gen-arg-forms arg :sign-extended funstate)))) + :checker (lambda (new-arg old-arg) + (let ((pf1 (arg-prefilter new-arg)) + (pf2 (arg-prefilter old-arg))) + (if (null pf1) + (null pf2) + (= (arg-position new-arg) + (arg-position old-arg)))))) (def-arg-form-kind (:adjusted :numeric :unlabelled) - :producer #'(lambda (arg funstate) - (let ((filtered-forms (gen-arg-forms arg :filtered funstate)) - (use-label (arg-use-label arg))) - (if (and use-label (not (eq use-label t))) - (list - `(adjust-label ,(maybe-listify filtered-forms) - ,(source-form use-label))) - filtered-forms))) - :checker #'(lambda (new-arg old-arg) - (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg)))) + :producer (lambda (arg funstate) + (let ((filtered-forms (gen-arg-forms arg :filtered funstate)) + (use-label (arg-use-label arg))) + (if (and use-label (not (eq use-label t))) + (list + `(adjust-label ,(maybe-listify filtered-forms) + ,(source-form use-label))) + filtered-forms))) + :checker (lambda (new-arg old-arg) + (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg)))) (def-arg-form-kind (:labelled :final) - :producer #'(lambda (arg funstate) - (let ((adjusted-forms - (gen-arg-forms arg :adjusted funstate)) - (use-label (arg-use-label arg))) - (if use-label - (let ((form (maybe-listify adjusted-forms))) - (if (and (not (eq use-label t)) - (not (atom adjusted-forms)) - (/= (Length adjusted-forms) 1)) - (pd-error - "cannot label a multiple-field argument ~ + :producer (lambda (arg funstate) + (let ((adjusted-forms + (gen-arg-forms arg :adjusted funstate)) + (use-label (arg-use-label arg))) + (if use-label + (let ((form (maybe-listify adjusted-forms))) + (if (and (not (eq use-label t)) + (not (atom adjusted-forms)) + (/= (length adjusted-forms) 1)) + (pd-error + "cannot label a multiple-field argument ~ unless using a function: ~S" arg) - `((lookup-label ,form)))) - adjusted-forms))) - :checker #'(lambda (new-arg old-arg) - (let ((lf1 (arg-use-label new-arg)) - (lf2 (arg-use-label old-arg))) - (if (null lf1) (null lf2) t)))) + `((lookup-label ,form)))) + adjusted-forms))) + :checker (lambda (new-arg old-arg) + (let ((lf1 (arg-use-label new-arg)) + (lf2 (arg-use-label old-arg))) + (if (null lf1) (null lf2) t)))) ;;; This is a bogus kind that's just used to ensure that printers are ;;; compatible... (def-arg-form-kind (:printed) - :producer #'(lambda (&rest noise) - (declare (ignore noise)) - (pd-error "bogus! can't use the :printed value of an arg!")) - :checker #'(lambda (new-arg old-arg) - (valsrc-equal (arg-printer new-arg) (arg-printer old-arg)))) + :producer (lambda (&rest noise) + (declare (ignore noise)) + (pd-error "bogus! can't use the :printed value of an arg!")) + :checker (lambda (new-arg old-arg) + (valsrc-equal (arg-printer new-arg) (arg-printer old-arg)))) (defun remember-printer-use (arg funstate) (set-arg-temps nil nil arg :printed funstate)) @@ -985,13 +1000,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 +1014,29 @@ (funstate-compatible-p funstate args))) (return cached-fun))))) -(defmacro !with-cached-function ((name-var - funstate-var - cache - cache-slot - args - &key - constraint - (stem (required-argument))) - &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,20 +1049,20 @@ (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 - :constraint printer-source - :stem (concatenate 'string - (string %name) - "-" - (symbol-name %format-name) - "-PRINTER")) - (make-printer-defun printer-source funstate name))))) + (!with-cached-fun + (name funstate cache fun-cache-printers args + :constraint printer-source + :stem (concatenate 'string + (string %name) + "-" + (symbol-name %format-name) + "-PRINTER")) + (make-printer-defun printer-source funstate name))))) -(defun make-printer-defun (source funstate function-name) +(defun make-printer-defun (source funstate fun-name) (let ((printer-form (compile-printer-list source funstate)) (bindings (make-arg-temp-bindings funstate))) - `(defun ,function-name (chunk inst stream dstate) + `(defun ,fun-name (chunk inst stream dstate) (declare (type dchunk chunk) (type instruction inst) (type stream stream) @@ -1122,8 +1137,8 @@ test key (sharing-mapcar - #'(lambda (sub-test) - (preprocess-test subj sub-test args)) + (lambda (sub-test) + (preprocess-test subj sub-test args)) body)))) (t form))))) @@ -1147,24 +1162,24 @@ printer :cond (sharing-mapcar - #'(lambda (clause) - (let ((filtered-body - (sharing-mapcar - #'(lambda (sub-printer) - (preprocess-conditionals sub-printer args)) - (cdr clause)))) - (sharing-cons - clause - (preprocess-test (find-first-field-name filtered-body) - (car clause) - args) - filtered-body))) + (lambda (clause) + (let ((filtered-body + (sharing-mapcar + (lambda (sub-printer) + (preprocess-conditionals sub-printer args)) + (cdr clause)))) + (sharing-cons + clause + (preprocess-test (find-first-field-name filtered-body) + (car clause) + args) + filtered-body))) (cdr printer)))) (quote printer) (t (sharing-mapcar - #'(lambda (sub-printer) - (preprocess-conditionals sub-printer args)) + (lambda (sub-printer) + (preprocess-conditionals sub-printer args)) printer))))) ;;; Return a version of the disassembly-template PRINTER with @@ -1196,7 +1211,7 @@ ((eq (car printer) :choose) (pick-printer-choice (cdr printer) args)) (t - (sharing-mapcar #'(lambda (sub) (preprocess-chooses sub args)) + (sharing-mapcar (lambda (sub) (preprocess-chooses sub args)) printer)))) ;;;; some simple functions that help avoid consing when we're just @@ -1211,6 +1226,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 @@ -1226,7 +1242,7 @@ ((symbolp printer) (find printer args :key #'arg-name)) ((listp printer) - (every #'(lambda (x) (all-arg-refs-relevant-p x args)) + (every (lambda (x) (all-arg-refs-relevant-p x args)) printer)) (t t))) @@ -1292,13 +1308,13 @@ ((eq (car source) 'function) `(local-call-global-printer ,source)) ((eq (car source) :cond) - `(cond ,@(mapcar #'(lambda (clause) - `(,(compile-test (find-first-field-name - (cdr clause)) - (car clause) - funstate) - ,@(compile-printer-list (cdr clause) - funstate))) + `(cond ,@(mapcar (lambda (clause) + `(,(compile-test (find-first-field-name + (cdr clause)) + (car clause) + funstate) + ,@(compile-printer-list (cdr clause) + funstate))) (cdr source)))) ;; :IF, :UNLESS, and :WHEN are replaced by :COND during preprocessing (t @@ -1347,7 +1363,7 @@ `(equal ,(listify-fields val-form-1) ,(listify-fields val-form-2))) (t - `(and ,@(mapcar #'(lambda (v1 v2) `(= ,v1 ,v2)) + `(and ,@(mapcar (lambda (v1 v2) `(= ,v1 ,v2)) val-form-1 val-form-2)))))) (defun compile-test (subj test funstate) @@ -1381,8 +1397,8 @@ (arg2 (arg-or-lose (car body) funstate))) (unless (and (= (length (arg-fields arg1)) (length (arg-fields arg2))) - (every #'(lambda (bs1 bs2) - (= (byte-size bs1) (byte-size bs2))) + (every (lambda (bs1 bs2) + (= (byte-size bs1) (byte-size bs2))) (arg-fields arg1) (arg-fields arg2))) (pd-error "can't compare differently sized fields: ~ @@ -1390,10 +1406,10 @@ (compare-fields-form (gen-arg-forms arg1 :numeric funstate) (gen-arg-forms arg2 :numeric funstate)))) ((eq key :or) - `(or ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate)) + `(or ,@(mapcar (lambda (sub) (compile-test subj sub funstate)) body))) ((eq key :and) - `(and ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate)) + `(and ,@(mapcar (lambda (sub) (compile-test subj sub funstate)) body))) ((eq key :not) `(not ,(compile-test subj (car body) funstate))) @@ -1407,8 +1423,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)) @@ -1442,16 +1458,16 @@ (defun find-prefilter-fun (%name %format-name args cache) (declare (type (or symbol string) %name %format-name)) (let ((filtered-args (mapcar #'arg-name - (remove-if-not #'arg-prefilter args)))) + (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) - "-" - (string %format-name) - "-PREFILTER") + (string %name) + "-" + (string %format-name) + "-PREFILTER") :constraint filtered-args) (collect ((forms)) (dolist (arg args) @@ -1476,7 +1492,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,15 +1521,15 @@ (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)) - (error "~D bits is not a byte-multiple." bits)) + (error "~W bits is not a byte-multiple." bits)) bytes)) (defun sign-extend (int size) @@ -1546,10 +1562,78 @@ (write value :stream stream :radix t :base 16 :escape nil)) (defun read-signed-suffix (length dstate) - (declare (type (member 8 16 32) length) + (declare (type (member 8 16 32 64) length) (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) + ;; for user code to hang stuff off of, cleared each time before an + ;; instruction is processed + (inst-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. ;;; @@ -1558,3 +1642,12 @@ ;;; it's defined before it's used. -- WHN ca. 19990701 (defmacro dstate-get-prop (dstate name) `(getf (dstate-properties ,dstate) ,name)) + +;;; Push NAME on the list of instruction properties in DSTATE. +(defun dstate-put-inst-prop (dstate name) + (push name (dstate-inst-properties dstate))) + +;;; Return non-NIL if NAME is on the list of instruction properties in +;;; DSTATE. +(defun dstate-get-inst-prop (dstate name) + (member name (dstate-inst-properties dstate) :test #'eq))