X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdisassem.lisp;h=b58838cc83399390a9efc41a42ec23aa7f8fe825;hb=a1a2c079c7654defb618baad0dddcf0eaf2ce64f;hp=a7ec03bbbe9603b03e8f26c879afaed791f96541;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index a7ec03b..b58838c 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -10,9 +10,6 @@ ;;;; files for more information. (in-package "SB!DISASSEM") - -(file-comment - "$Header$") ;;; types and defaults @@ -61,7 +58,7 @@ #| (defmacro set-disassem-params (&rest args) #!+sb-doc - "Specify global disassembler params. Keyword arguments include: + "Specify global disassembler params. &KEY arguments include: :INSTRUCTION-ALIGNMENT number Minimum alignment of instructions, in bits. @@ -106,7 +103,7 @@ ;;;; cached functions -(defstruct function-cache +(defstruct (function-cache (:copier nil)) (printers nil :type list) (labellers nil :type list) (prefilters nil :type list)) @@ -224,7 +221,8 @@ length mask id printer - labeller prefilter control))) + labeller prefilter control)) + (:copier nil)) (name nil :type (or symbol string)) (format-name nil :type (or symbol string)) @@ -251,23 +249,25 @@ ;;;; an instruction space holds all known machine instructions in a form that ;;;; can be easily searched -(defstruct (inst-space (:conc-name ispace-)) +(defstruct (inst-space (:conc-name ispace-) + (:copier nil)) (valid-mask dchunk-zero :type dchunk) ; applies to *children* (choices nil :type list)) (def!method print-object ((ispace inst-space) stream) (print-unreadable-object (ispace stream :type t :identity t))) -(defstruct (inst-space-choice (:conc-name ischoice-)) +(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))) ;;;; 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 +;;;; how to compute them. The :CHECKER functions make sure that a given ;;;; argument is compatible with another argument for a given use. (defvar *arg-form-kinds* nil) -(defstruct arg-form-kind +(defstruct (arg-form-kind (:copier nil)) (names nil :type list) (producer (required-argument) :type function) (checker (required-argument) :type function)) @@ -309,7 +309,8 @@ (prefilter nil) (use-label nil)) -(defstruct (instruction-format (:conc-name format-)) +(defstruct (instruction-format (:conc-name format-) + (:copier nil)) (name nil) (args nil :type list) @@ -319,7 +320,9 @@ ;;; A FUNSTATE holds the state of any arguments used in a disassembly ;;; function. -(defstruct (funstate (:conc-name funstate-) (:constructor %make-funstate)) +(defstruct (funstate (:conc-name funstate-) + (:constructor %make-funstate) + (:copier nil)) (args nil :type list) (arg-temps nil :type list)) ; See below. @@ -354,7 +357,8 @@ ;;;; (notably functions), we sometimes use a VALSRC structure to keep track of ;;;; the source from which they were derived. -(defstruct (valsrc (:constructor %make-valsrc)) +(defstruct (valsrc (:constructor %make-valsrc) + (:copier nil)) (value nil) (source nil)) @@ -403,9 +407,7 @@ (eq (car form) 'function)) ;; a function def (let ((wrapper-name (symbolicate prefix "-" arg-name "-WRAPPER")) - (wrapper-args nil)) - (dotimes (i (length funargs)) - (push (gensym) wrapper-args)) + (wrapper-args (make-gensym-list (length funargs)))) (values `#',wrapper-name `(defun ,wrapper-name ,wrapper-args (funcall ,form ,@wrapper-args)))) @@ -632,57 +634,6 @@ arg ,args-var ',name))) ,args-var)))))))))) -;;; FIXME: old CMU CL version, doesn't work with SBCL bootstrapping -;;; scheme, kept around for reference until I get the new sbcl-0.6.4 -;;; version to work, then can be deleted -#| -(defun gen-format-def-form (header descrips &optional (evalp t)) - #!+sb-doc - "Generate a form to define an instruction format. See - DEFINE-INSTRUCTION-FORMAT for more info." - (when (atom header) - (setf header (list header))) - (destructuring-bind (name length &key default-printer include) header - (let ((args-var (gensym)) - (length-var (gensym)) - (all-wrapper-defs nil) - (arg-count 0)) - (collect ((arg-def-forms)) - (dolist (descrip descrips) - (let ((name (pop descrip))) - (multiple-value-bind (descrip wrapper-defs) - (munge-fun-refs - descrip evalp t (format nil "~:@(~A~)-~D" name arg-count)) - (arg-def-forms - (update-args-form args-var `',name descrip evalp length-var)) - (setf all-wrapper-defs - (nconc wrapper-defs all-wrapper-defs))) - (incf arg-count))) - `(progn - ,@all-wrapper-defs - (eval-when (:compile-toplevel :execute) - (let ((,length-var ,length) - (,args-var - ,(and include - `(copy-list - (format-args - (format-or-lose ,include)))))) - ,@(arg-def-forms) - (setf (gethash ',name *disassem-inst-formats*) - (make-instruction-format - :name ',name - :length (bits-to-bytes ,length-var) - :default-printer ,(maybe-quote evalp default-printer) - :args ,args-var)) - (eval - `(progn - ,@(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 ;;; final target system (defun modify-or-add-arg (arg-name @@ -810,9 +761,7 @@ ;; just use the same as the forms (setq vars nil)) (t - (setq vars nil) - (dotimes (i (length forms)) - (push (gensym) vars)))) + (setq vars (make-gensym-list (length forms))))) (set-arg-temps vars forms arg kind funstate))) (or vars forms))) @@ -856,8 +805,7 @@ #!+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 keyword argument). Keyword - arguments are: + 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. @@ -1026,7 +974,8 @@ (valsrc-value thing) thing)) -(defstruct (cached-function (:conc-name cached-fun-)) +(defstruct (cached-function (:conc-name cached-fun-) + (:copier nil)) (funstate nil :type (or null funstate)) (constraint nil :type list) (name nil :type (or null symbol)))