1.0.29.34: hopefully thread-safe SB-PROFILE
[sbcl.git] / src / compiler / disassem.lisp
1 ;;;; machine-independent disassembler
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!DISASSEM")
13 \f
14 ;;; types and defaults
15
16 (def!constant label-column-width 7)
17
18 (deftype text-width () '(integer 0 1000))
19 (deftype alignment () '(integer 0 64))
20 (deftype offset () '(signed-byte 24))
21 (deftype address () '(unsigned-byte #.sb!vm:n-word-bits))
22 (deftype disassem-length () '(unsigned-byte 24))
23 (deftype column () '(integer 0 1000))
24
25 (def!constant max-filtered-value-index 32)
26 (deftype filtered-value-index ()
27   `(integer 0 ,max-filtered-value-index))
28 (deftype filtered-value-vector ()
29   `(simple-array t (,max-filtered-value-index)))
30 \f
31 ;;;; disassembly parameters
32
33 ;;; instructions
34 (defvar *disassem-insts* (make-hash-table :test 'eq))
35 (declaim (type hash-table *disassem-insts*))
36
37 (defvar *disassem-inst-space* nil)
38
39 ;;; minimum alignment of instructions, in bytes
40 (defvar *disassem-inst-alignment-bytes* sb!vm:n-word-bytes)
41 (declaim (type alignment *disassem-inst-alignment-bytes*))
42
43 (defvar *disassem-location-column-width* 8)
44 (declaim (type text-width *disassem-location-column-width*))
45
46 ;;; the width of the column in which instruction-names are printed. A
47 ;;; value of zero gives the effect of not aligning the arguments at
48 ;;; all.
49 (defvar *disassem-opcode-column-width* 6)
50 (declaim (type text-width *disassem-opcode-column-width*))
51
52 ;;; the width of the column in which instruction-bytes are printed. A
53 ;;; value of zero disables the printing of instruction bytes.
54 (defvar *disassem-inst-column-width* 16
55   #!+sb-doc
56   "The width of instruction bytes.")
57 (declaim (type text-width *disassem-inst-column-width*))
58
59
60 (defvar *disassem-note-column* (+ 45 *disassem-inst-column-width*)
61   #!+sb-doc
62   "The column in which end-of-line comments for notes are started.")
63
64 ;;; the old CMU CL code to set the CMU CL disassembly parameters
65 #|
66 (defmacro set-disassem-params (&rest args)
67   #!+sb-doc
68   "Specify global disassembler params. &KEY arguments include:
69
70   :INSTRUCTION-ALIGNMENT number
71       Minimum alignment of instructions, in bits.
72
73   :ADDRESS-SIZE number
74       Size of a machine address, in bits.
75
76   :OPCODE-COLUMN-WIDTH
77       Width of the column used for printing the opcode portion of the
78       instruction, or NIL to use the default."
79   (gen-preamble-form args))
80
81 (defun gen-preamble-form (args)
82   #!+sb-doc
83   "Generate a form to specify global disassembler params. See the
84   documentation for SET-DISASSEM-PARAMS for more info."
85   (destructuring-bind
86       (&key instruction-alignment
87             address-size
88             (opcode-column-width nil opcode-column-width-p))
89       args
90     `(progn
91        (eval-when (:compile-toplevel :execute)
92          ;; these are not in the params because they only exist at compile time
93          (defparameter ,(format-table-name) (make-hash-table))
94          (defparameter ,(arg-type-table-name) nil)
95          (defparameter ,(fun-cache-name) (make-fun-cache)))
96        (let ((params
97               (or sb!c:*backend-disassem-params*
98                   (setf sb!c:*backend-disassem-params* (make-params)))))
99          (declare (ignorable params))
100          ,(when instruction-alignment
101             `(setf (params-instruction-alignment params)
102                    (bits-to-bytes ,instruction-alignment)))
103          ,(when address-size
104             `(setf (params-location-column-width params)
105                    (* 2 ,address-size)))
106          ,(when opcode-column-width-p
107             `(setf (params-opcode-column-width params) ,opcode-column-width))
108          'disassem-params))))
109 |#
110 \f
111 ;;;; cached functions
112 ;;;;
113 ;;;; FIXME: Is it important to cache these? For performance? Or why?
114 ;;;; If performance: *Really*? How fast does disassembly need to be??
115 ;;;; So: Could we just punt this?
116
117 (defstruct (fun-cache (:copier nil))
118   (printers nil :type list)
119   (labellers nil :type list)
120   (prefilters nil :type list))
121
122 (defvar *disassem-fun-cache* (make-fun-cache))
123 (declaim (type fun-cache *disassem-fun-cache*))
124 \f
125 ;;;; A DCHUNK contains the bits we look at to decode an
126 ;;;; instruction.
127 ;;;; I tried to keep this abstract so that if using integers > the machine
128 ;;;; word size conses too much, it can be changed to use bit-vectors or
129 ;;;; something.
130 ;;;;
131 ;;;; KLUDGE: It's not clear that using bit-vectors would be any more efficient.
132 ;;;; Perhaps the abstraction could go away. -- WHN 19991124
133
134 #!-sb-fluid
135 (declaim (inline dchunk-or dchunk-and dchunk-clear dchunk-not
136                  dchunk-make-mask dchunk-make-field
137                  sap-ref-dchunk
138                  dchunk-extract
139                  dchunk=
140                  dchunk-count-bits))
141
142 (def!constant dchunk-bits #.sb!vm:n-word-bits)
143
144 (deftype dchunk ()
145   `(unsigned-byte ,dchunk-bits))
146 (deftype dchunk-index ()
147   `(integer 0 ,dchunk-bits))
148
149 (def!constant dchunk-zero 0)
150 (def!constant dchunk-one #.(1- (expt 2 sb!vm:n-word-bits)))
151
152 (defun dchunk-extract (from pos)
153   (declare (type dchunk from))
154   (the dchunk (ldb pos (the dchunk from))))
155
156 (defmacro dchunk-copy (x)
157   `(the dchunk ,x))
158
159 (defun dchunk-or (to from)
160   (declare (type dchunk to from))
161   (the dchunk (logior to from)))
162 (defun dchunk-and (to from)
163   (declare (type dchunk to from))
164   (the dchunk (logand to from)))
165 (defun dchunk-clear (to from)
166   (declare (type dchunk to from))
167   (the dchunk (logandc2 to from)))
168 (defun dchunk-not (from)
169   (declare (type dchunk from))
170   (the dchunk (logand dchunk-one (lognot from))))
171
172 (defmacro dchunk-andf (to from)
173   `(setf ,to (dchunk-and ,to ,from)))
174 (defmacro dchunk-orf (to from)
175   `(setf ,to (dchunk-or ,to ,from)))
176 (defmacro dchunk-clearf (to from)
177   `(setf ,to (dchunk-clear ,to ,from)))
178
179 (defun dchunk-make-mask (pos)
180   (the dchunk (mask-field pos -1)))
181 (defun dchunk-make-field (pos value)
182   (the dchunk (dpb value pos 0)))
183
184 (defmacro make-dchunk (value)
185   `(the dchunk ,value))
186
187 (defun sap-ref-dchunk (sap byte-offset byte-order)
188   (declare (type sb!sys:system-area-pointer sap)
189            (type offset byte-offset)
190            (optimize (speed 3) (safety 0)))
191   (the dchunk
192        (ecase dchunk-bits
193          (32 (if (eq byte-order :big-endian)
194                  (+ (ash (sb!sys:sap-ref-8 sap byte-offset) 24)
195                     (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 16)
196                     (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 8)
197                     (sb!sys:sap-ref-8 sap (+ 3 byte-offset)))
198                  (+ (sb!sys:sap-ref-8 sap byte-offset)
199                     (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 8)
200                     (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 16)
201                     (ash (sb!sys:sap-ref-8 sap (+ 3 byte-offset)) 24))))
202          (64 (if (eq byte-order :big-endian)
203                  (+ (ash (sb!sys:sap-ref-8 sap byte-offset) 56)
204                     (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 48)
205                     (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 40)
206                     (ash (sb!sys:sap-ref-8 sap (+ 3 byte-offset)) 32)
207                     (ash (sb!sys:sap-ref-8 sap (+ 4 byte-offset)) 24)
208                     (ash (sb!sys:sap-ref-8 sap (+ 5 byte-offset)) 16)
209                     (ash (sb!sys:sap-ref-8 sap (+ 6 byte-offset)) 8)
210                     (sb!sys:sap-ref-8 sap (+ 7 byte-offset)))
211                  (+ (sb!sys:sap-ref-8 sap byte-offset)
212                     (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 8)
213                     (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 16)
214                     (ash (sb!sys:sap-ref-8 sap (+ 3 byte-offset)) 24)
215                     (ash (sb!sys:sap-ref-8 sap (+ 4 byte-offset)) 32)
216                     (ash (sb!sys:sap-ref-8 sap (+ 5 byte-offset)) 40)
217                     (ash (sb!sys:sap-ref-8 sap (+ 6 byte-offset)) 48)
218                     (ash (sb!sys:sap-ref-8 sap (+ 7 byte-offset)) 56)))))))
219
220 (defun dchunk-corrected-extract (from pos unit-bits byte-order)
221   (declare (type dchunk from))
222   (if (eq byte-order :big-endian)
223       (ldb (byte (byte-size pos)
224                  (+ (byte-position pos) (- dchunk-bits unit-bits)))
225            (the dchunk from))
226       (ldb pos (the dchunk from))))
227
228 (defmacro dchunk-insertf (place pos value)
229   `(setf ,place (the dchunk (dpb ,value ,pos (the dchunk,place)))))
230
231 (defun dchunk= (x y)
232   (declare (type dchunk x y))
233   (= x y))
234 (defmacro dchunk-zerop (x)
235   `(dchunk= ,x dchunk-zero))
236
237 (defun dchunk-strict-superset-p (sup sub)
238   (and (zerop (logandc2 sub sup))
239        (not (zerop (logandc2 sup sub)))))
240
241 (defun dchunk-count-bits (x)
242   (declare (type dchunk x))
243   (logcount x))
244 \f
245 (defstruct (instruction (:conc-name inst-)
246                         (:constructor
247                          make-instruction (name
248                                            format-name
249                                            print-name
250                                            length
251                                            mask id
252                                            printer
253                                            labeller prefilter control))
254                         (:copier nil))
255   (name nil :type (or symbol string))
256   (format-name nil :type (or symbol string))
257
258   (mask dchunk-zero :type dchunk)       ; bits in the inst that are constant
259   (id dchunk-zero :type dchunk)         ; value of those constant bits
260
261   (length 0 :type disassem-length)               ; in bytes
262
263   (print-name nil :type symbol)
264
265   ;; disassembly functions
266   (prefilter nil :type (or null function))
267   (labeller nil :type (or null function))
268   (printer (missing-arg) :type (or null function))
269   (control nil :type (or null function))
270
271   ;; instructions that are the same as this instruction but with more
272   ;; constraints
273   (specializers nil :type list))
274 (def!method print-object ((inst instruction) stream)
275   (print-unreadable-object (inst stream :type t :identity t)
276     (format stream "~A(~A)" (inst-name inst) (inst-format-name inst))))
277 \f
278 ;;;; an instruction space holds all known machine instructions in a
279 ;;;; form that can be easily searched
280
281 (defstruct (inst-space (:conc-name ispace-)
282                        (:copier nil))
283   (valid-mask dchunk-zero :type dchunk) ; applies to *children*
284   (choices nil :type list))
285 (def!method print-object ((ispace inst-space) stream)
286   (print-unreadable-object (ispace stream :type t :identity t)))
287
288 ;;; now that we've defined the structure, we can declaim the type of
289 ;;; the variable:
290 (declaim (type (or null inst-space) *disassem-inst-space*))
291
292 (defstruct (inst-space-choice (:conc-name ischoice-)
293                               (:copier nil))
294   (common-id dchunk-zero :type dchunk)  ; applies to *parent's* mask
295   (subspace (missing-arg) :type (or inst-space instruction)))
296 \f
297 ;;;; These are the kind of values we can compute for an argument, and
298 ;;;; how to compute them. The :CHECKER functions make sure that a given
299 ;;;; argument is compatible with another argument for a given use.
300
301 (defvar *arg-form-kinds* nil)
302
303 (defstruct (arg-form-kind (:copier nil))
304   (names nil :type list)
305   (producer (missing-arg) :type function)
306   (checker (missing-arg) :type function))
307
308 (defun arg-form-kind-or-lose (kind)
309   (or (getf *arg-form-kinds* kind)
310       (pd-error "unknown arg-form kind ~S" kind)))
311
312 (defun find-arg-form-producer (kind)
313   (arg-form-kind-producer (arg-form-kind-or-lose kind)))
314 (defun find-arg-form-checker (kind)
315   (arg-form-kind-checker (arg-form-kind-or-lose kind)))
316
317 (defun canonicalize-arg-form-kind (kind)
318   (car (arg-form-kind-names (arg-form-kind-or-lose kind))))
319 \f
320 ;;;; only used during compilation of the instructions for a backend
321 ;;;;
322 ;;;; FIXME: If only used then, isn't there some way we could do
323 ;;;; EVAL-WHEN tricks to keep this stuff from appearing in the target
324 ;;;; system?
325
326 (defvar *disassem-inst-formats* (make-hash-table))
327 (defvar *disassem-arg-types* nil)
328 (defvar *disassem-fun-cache* (make-fun-cache))
329
330 (defstruct (arg (:copier nil)
331                 (:predicate nil))
332   (name nil :type symbol)
333   (fields nil :type list)
334
335   (value nil :type (or list integer))
336   (sign-extend-p nil :type (member t nil))
337
338   ;; position in a vector of prefiltered values
339   (position 0 :type fixnum)
340
341   ;; functions to use
342   (printer nil)
343   (prefilter nil)
344   (use-label nil))
345
346 (defstruct (instruction-format (:conc-name format-)
347                                (:copier nil))
348   (name nil)
349   (args nil :type list)
350
351   (length 0 :type disassem-length)               ; in bytes
352
353   (default-printer nil :type list))
354 \f
355 ;;; A FUNSTATE holds the state of any arguments used in a disassembly
356 ;;; function.
357 (defstruct (funstate (:conc-name funstate-)
358                      (:constructor %make-funstate)
359                      (:copier nil))
360   (args nil :type list)
361   (arg-temps nil :type list))           ; See below.
362
363 (defun make-funstate (args)
364   ;; give the args a position
365   (let ((i 0))
366     (dolist (arg args)
367       (setf (arg-position arg) i)
368       (incf i)))
369   (%make-funstate :args args))
370
371 (defun funstate-compatible-p (funstate args)
372   (every (lambda (this-arg-temps)
373            (let* ((old-arg (car this-arg-temps))
374                   (new-arg (find (arg-name old-arg) args :key #'arg-name)))
375              (and new-arg
376                   (= (arg-position old-arg) (arg-position new-arg))
377                   (every (lambda (this-kind-temps)
378                            (funcall (find-arg-form-checker
379                                      (car this-kind-temps))
380                                     new-arg
381                                     old-arg))
382                          (cdr this-arg-temps)))))
383          (funstate-arg-temps funstate)))
384
385 (defun arg-or-lose (name funstate)
386   (let ((arg (find name (funstate-args funstate) :key #'arg-name)))
387     (when (null arg)
388       (pd-error "unknown argument ~S" name))
389     arg))
390 \f
391 ;;;; Since we can't include some values in compiled output as they are
392 ;;;; (notably functions), we sometimes use a VALSRC structure to keep
393 ;;;; track of the source from which they were derived.
394
395 (defstruct (valsrc (:constructor %make-valsrc)
396                    (:copier nil))
397   (value nil)
398   (source nil))
399
400 (defun make-valsrc (value source)
401   (cond ((equal value source)
402          source)
403         ((and (listp value) (eq (car value) 'function))
404          value)
405         (t
406          (%make-valsrc :value value :source source))))
407
408 ;;; machinery to provide more meaningful error messages during compilation
409 (defvar *current-instruction-flavor* nil)
410 (defun pd-error (fmt &rest args)
411   (if *current-instruction-flavor*
412       (error "~@<in printer-definition for ~S(~S): ~3I~:_~?~:>"
413              (car *current-instruction-flavor*)
414              (cdr *current-instruction-flavor*)
415              fmt args)
416       (apply #'error fmt args)))
417
418 ;;; FIXME:
419 ;;;  1. This should become a utility in SB!INT.
420 ;;;  2. Arrays and structures and maybe other things are
421 ;;;     self-evaluating too.
422 (defun self-evaluating-p (x)
423   (typecase x
424     (null t)
425     (keyword t)
426     (symbol (eq x t))
427     (cons nil)
428     (t t)))
429
430 (defun maybe-quote (evalp form)
431   (if (or evalp (self-evaluating-p form)) form `',form))
432
433 ;;; Detect things that obviously don't need wrapping, like
434 ;;; variable-refs and #'function.
435 (defun doesnt-need-wrapping-p (form)
436   (or (symbolp form)
437       (and (listp form)
438            (eq (car form) 'function)
439            (symbolp (cadr form)))))
440
441 (defun make-wrapper (form arg-name funargs prefix)
442   (if (and (listp form)
443            (eq (car form) 'function))
444       ;; a function def
445       (let ((wrapper-name (symbolicate prefix "-" arg-name "-WRAPPER"))
446             (wrapper-args (make-gensym-list (length funargs))))
447         (values `#',wrapper-name
448                 `(defun ,wrapper-name ,wrapper-args
449                    (funcall ,form ,@wrapper-args))))
450       ;; something else
451       (let ((wrapper-name (symbolicate "*" prefix "-" arg-name "-WRAPPER*")))
452         (values wrapper-name `(defparameter ,wrapper-name ,form)))))
453
454 (defun filter-overrides (overrides evalp)
455   (mapcar (lambda (override)
456             (list* (car override) (cadr override)
457                    (munge-fun-refs (cddr override) evalp)))
458           overrides))
459
460 (defparameter *arg-fun-params*
461   '((:printer . (value stream dstate))
462     (:use-label . (value dstate))
463     (:prefilter . (value dstate))))
464
465 (defun munge-fun-refs (params evalp &optional wrap-defs-p (prefix ""))
466   (let ((params (copy-list params)))
467     (do ((tail params (cdr tail))
468          (wrapper-defs nil))
469         ((null tail)
470          (values params (nreverse wrapper-defs)))
471       (let ((fun-arg (assoc (car tail) *arg-fun-params*)))
472         (when fun-arg
473           (let* ((fun-form (cadr tail))
474                  (quoted-fun-form `',fun-form))
475             (when (and wrap-defs-p (not (doesnt-need-wrapping-p fun-form)))
476               (multiple-value-bind (access-form wrapper-def-form)
477                   (make-wrapper fun-form (car fun-arg) (cdr fun-arg) prefix)
478                 (setf quoted-fun-form `',access-form)
479                 (push wrapper-def-form wrapper-defs)))
480             (if evalp
481                 (setf (cadr tail)
482                       `(make-valsrc ,fun-form ,quoted-fun-form))
483                 (setf (cadr tail)
484                       fun-form))))))))
485
486 (defun gen-args-def-form (overrides format-form &optional (evalp t))
487   (let ((args-var (gensym)))
488     `(let ((,args-var (copy-list (format-args ,format-form))))
489        ,@(mapcar (lambda (override)
490                    (update-args-form args-var
491                                      `',(car override)
492                                      (and (cdr override)
493                                           (cons :value (cdr override)))
494                                      evalp))
495                  overrides)
496        ,args-var)))
497
498 (defun gen-printer-def-forms-def-form (base-name
499                                        uniquified-name
500                                        def
501                                        &optional
502                                        (evalp t))
503   (declare (type symbol base-name))
504   (declare (type (or symbol string) uniquified-name))
505   (destructuring-bind
506       (format-name
507        (&rest field-defs)
508        &optional (printer-form :default)
509        &key ((:print-name print-name-form) `',base-name) control)
510       def
511     (let ((format-var (gensym))
512           (field-defs (filter-overrides field-defs evalp)))
513       `(let* ((*current-instruction-flavor* ',(cons base-name format-name))
514               (,format-var (format-or-lose ',format-name))
515               (args ,(gen-args-def-form field-defs format-var evalp))
516               (funcache *disassem-fun-cache*))
517          (multiple-value-bind (printer-fun printer-defun)
518              (find-printer-fun ',uniquified-name
519                                ',format-name
520                                ,(if (eq printer-form :default)
521                                      `(format-default-printer ,format-var)
522                                      (maybe-quote evalp printer-form))
523                                args funcache)
524            (multiple-value-bind (labeller-fun labeller-defun)
525                (find-labeller-fun ',uniquified-name args funcache)
526              (multiple-value-bind (prefilter-fun prefilter-defun)
527                  (find-prefilter-fun ',uniquified-name
528                                      ',format-name
529                                      args
530                                      funcache)
531                (multiple-value-bind (mask id)
532                    (compute-mask-id args)
533                  (values
534                   `(make-instruction ',',base-name
535                                      ',',format-name
536                                      ,',print-name-form
537                                      ,(format-length ,format-var)
538                                      ,mask
539                                      ,id
540                                      ,(and printer-fun `#',printer-fun)
541                                      ,(and labeller-fun `#',labeller-fun)
542                                      ,(and prefilter-fun `#',prefilter-fun)
543                                      ,',control)
544                   `(progn
545                      ,@(and printer-defun (list printer-defun))
546                      ,@(and labeller-defun (list labeller-defun))
547                      ,@(and prefilter-defun (list prefilter-defun))))
548                  ))))))))
549
550 (defun update-args-form (var name-form descrip-forms evalp
551                              &optional format-length-form)
552   `(setf ,var
553          ,(if evalp
554               `(modify-or-add-arg ,name-form
555                                   ,var
556                                   *disassem-arg-types*
557                                   ,@(and format-length-form
558                                          `(:format-length
559                                             ,format-length-form))
560                                   ,@descrip-forms)
561               `(apply #'modify-or-add-arg
562                       ,name-form
563                       ,var
564                       *disassem-arg-types*
565                       ,@(and format-length-form
566                              `(:format-length ,format-length-form))
567                       ',descrip-forms))))
568
569 (defun format-or-lose (name)
570   (or (gethash name *disassem-inst-formats*)
571       (pd-error "unknown instruction format ~S" name)))
572
573 ;;; FIXME: needed only at build-the-system time, not in running system
574 (defmacro define-instruction-format (header &rest fields)
575   #!+sb-doc
576   "DEFINE-INSTRUCTION-FORMAT (Name Length {Format-Key Value}*) Arg-Def*
577   Define an instruction format NAME for the disassembler's use. LENGTH is
578   the length of the format in bits.
579   Possible FORMAT-KEYs:
580
581   :INCLUDE other-format-name
582       Inherit all arguments and properties of the given format. Any
583       arguments defined in the current format definition will either modify
584       the copy of an existing argument (keeping in the same order with
585       respect to when pre-filter's are called), if it has the same name as
586       one, or be added to the end.
587   :DEFAULT-PRINTER printer-list
588       Use the given PRINTER-LIST as a format to print any instructions of
589       this format when they don't specify something else.
590
591   Each ARG-DEF defines one argument in the format, and is of the form
592     (Arg-Name {Arg-Key Value}*)
593
594   Possible ARG-KEYs (the values are evaluated unless otherwise specified):
595
596   :FIELDS byte-spec-list
597       The argument takes values from these fields in the instruction. If
598       the list is of length one, then the corresponding value is supplied by
599       itself; otherwise it is a list of the values. The list may be NIL.
600   :FIELD byte-spec
601       The same as :FIELDS (list byte-spec).
602
603   :VALUE value
604       If the argument only has one field, this is the value it should have,
605       otherwise it's a list of the values of the individual fields. This can
606       be overridden in an instruction-definition or a format definition
607       including this one by specifying another, or NIL to indicate that it's
608       variable.
609
610   :SIGN-EXTEND boolean
611       If non-NIL, the raw value of this argument is sign-extended,
612       immediately after being extracted from the instruction (before any
613       prefilters are run, for instance). If the argument has multiple
614       fields, they are all sign-extended.
615
616   :TYPE arg-type-name
617       Inherit any properties of the given argument type.
618
619   :PREFILTER function
620       A function which is called (along with all other prefilters, in the
621       order that their arguments appear in the instruction-format) before
622       any printing is done, to filter the raw value. Any uses of READ-SUFFIX
623       must be done inside a prefilter.
624
625   :PRINTER function-string-or-vector
626       A function, string, or vector which is used to print this argument.
627
628   :USE-LABEL
629       If non-NIL, the value of this argument is used as an address, and if
630       that address occurs inside the disassembled code, it is replaced by a
631       label. If this is a function, it is called to filter the value."
632   (gen-format-def-form header fields))
633
634 ;;; FIXME: needed only at build-the-system time, not in running system
635 (defun gen-format-def-form (header descrips &optional (evalp t))
636   #!+sb-doc
637   "Generate a form to define an instruction format. See
638   DEFINE-INSTRUCTION-FORMAT for more info."
639   (when (atom header)
640     (setf header (list header)))
641   (destructuring-bind (name length &key default-printer include) header
642     (let ((args-var (gensym))
643           (length-var (gensym))
644           (all-wrapper-defs nil)
645           (arg-count 0))
646       (collect ((arg-def-forms))
647         (dolist (descrip descrips)
648           (let ((name (pop descrip)))
649             (multiple-value-bind (descrip wrapper-defs)
650                 (munge-fun-refs
651                  descrip evalp t (format nil "~:@(~A~)-~D" name arg-count))
652               (arg-def-forms
653                (update-args-form args-var `',name descrip evalp length-var))
654               (setf all-wrapper-defs
655                     (nconc wrapper-defs all-wrapper-defs)))
656             (incf arg-count)))
657         `(progn
658            ,@all-wrapper-defs
659            (eval-when (:compile-toplevel :execute)
660              (let ((,length-var ,length)
661                    (,args-var
662                     ,(and include
663                           `(copy-list
664                             (format-args
665                              (format-or-lose ,include))))))
666                ,@(arg-def-forms)
667                (setf (gethash ',name *disassem-inst-formats*)
668                      (make-instruction-format
669                       :name ',name
670                       :length (bits-to-bytes ,length-var)
671                       :default-printer ,(maybe-quote evalp default-printer)
672                       :args ,args-var))
673                (eval
674                 `(progn
675                    ,@(mapcar (lambda (arg)
676                                (when (arg-fields arg)
677                                  (gen-arg-access-macro-def-form
678                                   arg ,args-var ',name)))
679                              ,args-var))))))))))
680
681 ;;; FIXME: probably needed only at build-the-system time, not in
682 ;;; final target system
683 (defun modify-or-add-arg (arg-name
684                           args
685                           type-table
686                           &key
687                           (value nil value-p)
688                           (type nil type-p)
689                           (prefilter nil prefilter-p)
690                           (printer nil printer-p)
691                           (sign-extend nil sign-extend-p)
692                           (use-label nil use-label-p)
693                           (field nil field-p)
694                           (fields nil fields-p)
695                           format-length)
696   (let* ((arg-pos (position arg-name args :key #'arg-name))
697          (arg
698           (if (null arg-pos)
699               (let ((arg (make-arg :name arg-name)))
700                 (if (null args)
701                     (setf args (list arg))
702                     (push arg (cdr (last args))))
703                 arg)
704               (setf (nth arg-pos args)
705                     (copy-structure (nth arg-pos args))))))
706     (when (and field-p (not fields-p))
707       (setf fields (list field))
708       (setf fields-p t))
709     (when type-p
710       (set-arg-from-type arg type type-table))
711     (when value-p
712       (setf (arg-value arg) value))
713     (when prefilter-p
714       (setf (arg-prefilter arg) prefilter))
715     (when sign-extend-p
716       (setf (arg-sign-extend-p arg) sign-extend))
717     (when printer-p
718       (setf (arg-printer arg) printer))
719     (when use-label-p
720       (setf (arg-use-label arg) use-label))
721     (when fields-p
722       (when (null format-length)
723         (error
724          "~@<in arg ~S: ~3I~:_~
725           can't specify fields except using DEFINE-INSTRUCTION-FORMAT~:>"
726          arg-name))
727       (setf (arg-fields arg)
728             (mapcar (lambda (bytespec)
729                       (when (> (+ (byte-position bytespec)
730                                   (byte-size bytespec))
731                                format-length)
732                         (error "~@<in arg ~S: ~3I~:_~
733                                      The field ~S doesn't fit in an ~
734                                      instruction-format ~W bits wide.~:>"
735                                arg-name
736                                bytespec
737                                format-length))
738                       (correct-dchunk-bytespec-for-endianness
739                        bytespec
740                        format-length
741                        sb!c:*backend-byte-order*))
742                     fields)))
743     args))
744
745 (defun gen-arg-access-macro-def-form (arg args format-name)
746   (let* ((funstate (make-funstate args))
747          (arg-val-form (arg-value-form arg funstate :adjusted))
748          (bindings (make-arg-temp-bindings funstate)))
749     `(sb!xc:defmacro ,(symbolicate format-name "-" (arg-name arg))
750          (chunk dstate)
751        `(let ((chunk ,chunk) (dstate ,dstate))
752           (declare (ignorable chunk dstate))
753           (flet ((local-filtered-value (offset)
754                    (declare (type filtered-value-index offset))
755                    (aref (dstate-filtered-values dstate) offset))
756                  (local-extract (bytespec)
757                    (dchunk-extract chunk bytespec)))
758             (declare (ignorable #'local-filtered-value #'local-extract)
759                      (inline local-filtered-value local-extract))
760             (let* ,',bindings
761               ,',arg-val-form))))))
762
763 (defun arg-value-form (arg funstate
764                        &optional
765                        (kind :final)
766                        (allow-multiple-p (not (eq kind :numeric))))
767   (let ((forms (gen-arg-forms arg kind funstate)))
768     (when (and (not allow-multiple-p)
769                (listp forms)
770                (/= (length forms) 1))
771       (pd-error "~S must not have multiple values." arg))
772     (maybe-listify forms)))
773
774 (defun correct-dchunk-bytespec-for-endianness (bs unit-bits byte-order)
775   (if (eq byte-order :big-endian)
776       (byte (byte-size bs) (+ (byte-position bs) (- dchunk-bits unit-bits)))
777       bs))
778
779 (defun make-arg-temp-bindings (funstate)
780   ;; (Everything is in reverse order, so we just use PUSH, which
781   ;; results in everything being in the right order at the end.)
782   (let ((bindings nil))
783     (dolist (ats (funstate-arg-temps funstate))
784       (dolist (atk (cdr ats))
785         (cond ((null (cadr atk)))
786               ((atom (cadr atk))
787                (push `(,(cadr atk) ,(cddr atk)) bindings))
788               (t
789                (mapc (lambda (var form)
790                        (push `(,var ,form) bindings))
791                      (cadr atk)
792                      (cddr atk))))))
793     bindings))
794
795 (defun gen-arg-forms (arg kind funstate)
796   (multiple-value-bind (vars forms)
797       (get-arg-temp arg kind funstate)
798     (when (null forms)
799       (multiple-value-bind (new-forms single-value-p)
800           (funcall (find-arg-form-producer kind) arg funstate)
801         (setq forms new-forms)
802         (cond ((or single-value-p (atom forms))
803                (unless (symbolp forms)
804                  (setq vars (gensym))))
805               ((every #'symbolp forms)
806                ;; just use the same as the forms
807                (setq vars nil))
808               (t
809                (setq vars (make-gensym-list (length forms)))))
810         (set-arg-temps vars forms arg kind funstate)))
811     (or vars forms)))
812
813 (defun maybe-listify (forms)
814   (cond ((atom forms)
815          forms)
816         ((/= (length forms) 1)
817          `(list ,@forms))
818         (t
819          (car forms))))
820 \f
821 (defun set-arg-from-type (arg type-name table)
822   (let ((type-arg (find type-name table :key #'arg-name)))
823     (when (null type-arg)
824       (pd-error "unknown argument type: ~S" type-name))
825     (setf (arg-printer arg) (arg-printer type-arg))
826     (setf (arg-prefilter arg) (arg-prefilter type-arg))
827     (setf (arg-sign-extend-p arg) (arg-sign-extend-p type-arg))
828     (setf (arg-use-label arg) (arg-use-label type-arg))))
829
830 (defun get-arg-temp (arg kind funstate)
831   (let ((this-arg-temps (assoc arg (funstate-arg-temps funstate))))
832     (if this-arg-temps
833         (let ((this-kind-temps
834                (assoc (canonicalize-arg-form-kind kind)
835                       (cdr this-arg-temps))))
836           (values (cadr this-kind-temps) (cddr this-kind-temps)))
837         (values nil nil))))
838
839 (defun set-arg-temps (vars forms arg kind funstate)
840   (let ((this-arg-temps
841          (or (assoc arg (funstate-arg-temps funstate))
842              (car (push (cons arg nil) (funstate-arg-temps funstate)))))
843         (kind (canonicalize-arg-form-kind kind)))
844     (let ((this-kind-temps
845            (or (assoc kind (cdr this-arg-temps))
846                (car (push (cons kind nil) (cdr this-arg-temps))))))
847       (setf (cdr this-kind-temps) (cons vars forms)))))
848 \f
849 ;;; DEFINE-ARG-TYPE Name {Key Value}*
850 ;;;
851 ;;; Define a disassembler argument type NAME (which can then be referenced in
852 ;;; another argument definition using the :TYPE argument). &KEY args are:
853 ;;;
854 ;;;  :SIGN-EXTEND boolean
855 ;;;     If non-NIL, the raw value of this argument is sign-extended.
856 ;;;
857 ;;;  :TYPE arg-type-name
858 ;;;     Inherit any properties of given arg-type.
859 ;;;
860 ;;; :PREFILTER function
861 ;;;     A function which is called (along with all other prefilters,
862 ;;;     in the order that their arguments appear in the instruction-
863 ;;;     format) before any printing is done, to filter the raw value.
864 ;;;     Any uses of READ-SUFFIX must be done inside a prefilter.
865 ;;;
866 ;;; :PRINTER function-string-or-vector
867 ;;;     A function, string, or vector which is used to print an argument of
868 ;;;     this type.
869 ;;;
870 ;;; :USE-LABEL
871 ;;;     If non-NIL, the value of an argument of this type is used as
872 ;;;     an address, and if that address occurs inside the disassembled
873 ;;;     code, it is replaced by a label. If this is a function, it is
874 ;;;     called to filter the value.
875 (defmacro define-arg-type (name &rest args)
876   (gen-arg-type-def-form name args))
877
878 ;;; Generate a form to define a disassembler argument type. See
879 ;;; DEFINE-ARG-TYPE for more information.
880 (defun gen-arg-type-def-form (name args &optional (evalp t))
881   (multiple-value-bind (args wrapper-defs)
882       (munge-fun-refs args evalp t name)
883     `(progn
884        ,@wrapper-defs
885        (eval-when (:compile-toplevel :execute)
886          ,(update-args-form '*disassem-arg-types* `',name args evalp))
887        ',name)))
888 \f
889 (defmacro def-arg-form-kind ((&rest names) &rest inits)
890   `(let ((kind (make-arg-form-kind :names ',names ,@inits)))
891      ,@(mapcar (lambda (name)
892                  `(setf (getf *arg-form-kinds* ',name) kind))
893                names)))
894
895 (def-arg-form-kind (:raw)
896   :producer (lambda (arg funstate)
897               (declare (ignore funstate))
898               (mapcar (lambda (bytespec)
899                         `(the (unsigned-byte ,(byte-size bytespec))
900                            (local-extract ',bytespec)))
901                       (arg-fields arg)))
902   :checker (lambda (new-arg old-arg)
903              (equal (arg-fields new-arg)
904                     (arg-fields old-arg))))
905
906 (def-arg-form-kind (:sign-extended :unfiltered)
907   :producer (lambda (arg funstate)
908               (let ((raw-forms (gen-arg-forms arg :raw funstate)))
909                 (if (and (arg-sign-extend-p arg) (listp raw-forms))
910                     (mapcar (lambda (form field)
911                               `(the (signed-byte ,(byte-size field))
912                                  (sign-extend ,form
913                                               ,(byte-size field))))
914                             raw-forms
915                             (arg-fields arg))
916                     raw-forms)))
917   :checker (lambda (new-arg old-arg)
918              (equal (arg-sign-extend-p new-arg)
919                     (arg-sign-extend-p old-arg))))
920
921 (defun valsrc-equal (f1 f2)
922   (if (null f1)
923       (null f2)
924       (equal (value-or-source f1)
925              (value-or-source f2))))
926
927 (def-arg-form-kind (:filtering)
928   :producer (lambda (arg funstate)
929               (let ((sign-extended-forms
930                      (gen-arg-forms arg :sign-extended funstate))
931                     (pf (arg-prefilter arg)))
932                 (if pf
933                     (values
934                      `(local-filter ,(maybe-listify sign-extended-forms)
935                                     ,(source-form pf))
936                      t)
937                     (values sign-extended-forms nil))))
938   :checker (lambda (new-arg old-arg)
939              (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
940
941 (def-arg-form-kind (:filtered :unadjusted)
942   :producer (lambda (arg funstate)
943               (let ((pf (arg-prefilter arg)))
944                 (if pf
945                     (values `(local-filtered-value ,(arg-position arg)) t)
946                     (gen-arg-forms arg :sign-extended funstate))))
947   :checker (lambda (new-arg old-arg)
948              (let ((pf1 (arg-prefilter new-arg))
949                    (pf2 (arg-prefilter old-arg)))
950                (if (null pf1)
951                    (null pf2)
952                    (= (arg-position new-arg)
953                       (arg-position old-arg))))))
954
955 (def-arg-form-kind (:adjusted :numeric :unlabelled)
956   :producer (lambda (arg funstate)
957               (let ((filtered-forms (gen-arg-forms arg :filtered funstate))
958                     (use-label (arg-use-label arg)))
959                 (if (and use-label (not (eq use-label t)))
960                     (list
961                      `(adjust-label ,(maybe-listify filtered-forms)
962                                     ,(source-form use-label)))
963                     filtered-forms)))
964   :checker (lambda (new-arg old-arg)
965              (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
966
967 (def-arg-form-kind (:labelled :final)
968   :producer (lambda (arg funstate)
969               (let ((adjusted-forms
970                      (gen-arg-forms arg :adjusted funstate))
971                     (use-label (arg-use-label arg)))
972                 (if use-label
973                     (let ((form (maybe-listify adjusted-forms)))
974                       (if (and (not (eq use-label t))
975                                (not (atom adjusted-forms))
976                                (/= (length adjusted-forms) 1))
977                           (pd-error
978                            "cannot label a multiple-field argument ~
979                               unless using a function: ~S" arg)
980                           `((lookup-label ,form))))
981                     adjusted-forms)))
982   :checker (lambda (new-arg old-arg)
983              (let ((lf1 (arg-use-label new-arg))
984                    (lf2 (arg-use-label old-arg)))
985                (if (null lf1) (null lf2) t))))
986
987 ;;; This is a bogus kind that's just used to ensure that printers are
988 ;;; compatible...
989 (def-arg-form-kind (:printed)
990   :producer (lambda (&rest noise)
991               (declare (ignore noise))
992               (pd-error "bogus! can't use the :printed value of an arg!"))
993   :checker (lambda (new-arg old-arg)
994              (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
995
996 (defun remember-printer-use (arg funstate)
997   (set-arg-temps nil nil arg :printed funstate))
998 \f
999 ;;; Returns a version of THING suitable for including in an evaluable
1000 ;;; position in some form.
1001 (defun source-form (thing)
1002   (cond ((valsrc-p thing)
1003          (valsrc-source thing))
1004         ((functionp thing)
1005          (pd-error
1006           "can't dump functions, so function ref form must be quoted: ~S"
1007           thing))
1008         ((self-evaluating-p thing)
1009          thing)
1010         ((eq (car thing) 'function)
1011          thing)
1012         (t
1013          `',thing)))
1014
1015 ;;; Return anything but a VALSRC structure.
1016 (defun value-or-source (thing)
1017   (if (valsrc-p thing)
1018       (valsrc-value thing)
1019       thing))
1020 \f
1021 (defstruct (cached-fun (:conc-name cached-fun-)
1022                        (:copier nil))
1023   (funstate nil :type (or null funstate))
1024   (constraint nil :type list)
1025   (name nil :type (or null symbol)))
1026
1027 (defun find-cached-fun (cached-funs args constraint)
1028   (dolist (cached-fun cached-funs nil)
1029     (let ((funstate (cached-fun-funstate cached-fun)))
1030       (when (and (equal constraint (cached-fun-constraint cached-fun))
1031                  (or (null funstate)
1032                      (funstate-compatible-p funstate args)))
1033         (return cached-fun)))))
1034
1035 (defmacro !with-cached-fun ((name-var
1036                              funstate-var
1037                              cache
1038                              cache-slot
1039                              args
1040                              &key
1041                              constraint
1042                              (stem (missing-arg)))
1043                             &body defun-maker-forms)
1044   (let ((cache-var (gensym))
1045         (constraint-var (gensym)))
1046     `(let* ((,constraint-var ,constraint)
1047             (,cache-var (find-cached-fun (,cache-slot ,cache)
1048                                          ,args ,constraint-var)))
1049        (cond (,cache-var
1050               (values (cached-fun-name ,cache-var) nil))
1051              (t
1052               (let* ((,name-var (symbolicate "CACHED-FUN--" ,stem))
1053                      (,funstate-var (make-funstate ,args))
1054                      (,cache-var
1055                       (make-cached-fun :name ,name-var
1056                                        :funstate ,funstate-var
1057                                        :constraint ,constraint-var)))
1058                 (values ,name-var
1059                         `(progn
1060                            ,(progn ,@defun-maker-forms)
1061                            (eval-when (:compile-toplevel :execute)
1062                              (push ,,cache-var
1063                                    (,',cache-slot ',,cache)))))))))))
1064 \f
1065 (defun find-printer-fun (%name %format-name printer-source args cache)
1066   (declare (type (or string symbol) %name))
1067   (if (null printer-source)
1068       (values nil nil)
1069       (let ((printer-source (preprocess-printer printer-source args)))
1070         (!with-cached-fun
1071            (name funstate cache fun-cache-printers args
1072                  :constraint printer-source
1073                  :stem (concatenate 'string
1074                                     (string %name)
1075                                     "-"
1076                                     (symbol-name %format-name)
1077                                     "-PRINTER"))
1078          (make-printer-defun printer-source funstate name)))))
1079 \f
1080 (defun make-printer-defun (source funstate fun-name)
1081   (let ((printer-form (compile-printer-list source funstate))
1082         (bindings (make-arg-temp-bindings funstate)))
1083     `(defun ,fun-name (chunk inst stream dstate)
1084        (declare (type dchunk chunk)
1085                 (type instruction inst)
1086                 (type stream stream)
1087                 (type disassem-state dstate))
1088        (macrolet ((local-format-arg (arg fmt)
1089                     `(funcall (formatter ,fmt) stream ,arg)))
1090          (flet ((local-tab-to-arg-column ()
1091                   (tab (dstate-argument-column dstate) stream))
1092                 (local-print-name ()
1093                   (princ (inst-print-name inst) stream))
1094                 (local-write-char (ch)
1095                   (write-char ch stream))
1096                 (local-princ (thing)
1097                   (princ thing stream))
1098                 (local-princ16 (thing)
1099                   (princ16 thing stream))
1100                 (local-call-arg-printer (arg printer)
1101                   (funcall printer arg stream dstate))
1102                 (local-call-global-printer (fun)
1103                   (funcall fun chunk inst stream dstate))
1104                 (local-filtered-value (offset)
1105                   (declare (type filtered-value-index offset))
1106                   (aref (dstate-filtered-values dstate) offset))
1107                 (local-extract (bytespec)
1108                   (dchunk-extract chunk bytespec))
1109                 (lookup-label (lab)
1110                   (or (gethash lab (dstate-label-hash dstate))
1111                       lab))
1112                 (adjust-label (val adjust-fun)
1113                   (funcall adjust-fun val dstate)))
1114            (declare (ignorable #'local-tab-to-arg-column
1115                                #'local-print-name
1116                                #'local-princ #'local-princ16
1117                                #'local-write-char
1118                                #'local-call-arg-printer
1119                                #'local-call-global-printer
1120                                #'local-extract
1121                                #'local-filtered-value
1122                                #'lookup-label #'adjust-label)
1123                     (inline local-tab-to-arg-column
1124                             local-princ local-princ16
1125                             local-call-arg-printer local-call-global-printer
1126                             local-filtered-value local-extract
1127                             lookup-label adjust-label))
1128            (let* ,bindings
1129              ,@printer-form))))))
1130 \f
1131 (defun preprocess-test (subj form args)
1132   (multiple-value-bind (subj test)
1133       (if (and (consp form) (symbolp (car form)) (not (keywordp (car form))))
1134           (values (car form) (cdr form))
1135           (values subj form))
1136     (let ((key (if (consp test) (car test) test))
1137           (body (if (consp test) (cdr test) nil)))
1138       (case key
1139         (:constant
1140          (if (null body)
1141              ;; If no supplied constant values, just any constant is ok,
1142              ;; just see whether there's some constant value in the arg.
1143              (not
1144               (null
1145                (arg-value
1146                 (or (find subj args :key #'arg-name)
1147                     (pd-error "unknown argument ~S" subj)))))
1148              ;; Otherwise, defer to run-time.
1149              form))
1150         ((:or :and :not)
1151          (sharing-cons
1152           form
1153           subj
1154           (sharing-cons
1155            test
1156            key
1157            (sharing-mapcar
1158             (lambda (sub-test)
1159               (preprocess-test subj sub-test args))
1160             body))))
1161         (t form)))))
1162
1163 (defun preprocess-conditionals (printer args)
1164   (if (atom printer)
1165       printer
1166       (case (car printer)
1167         (:unless
1168          (preprocess-conditionals
1169           `(:cond ((:not ,(nth 1 printer)) ,@(nthcdr 2 printer)))
1170           args))
1171         (:when
1172          (preprocess-conditionals `(:cond (,(cdr printer))) args))
1173         (:if
1174          (preprocess-conditionals
1175           `(:cond (,(nth 1 printer) ,(nth 2 printer))
1176                   (t ,(nth 3 printer)))
1177           args))
1178         (:cond
1179          (sharing-cons
1180           printer
1181           :cond
1182           (sharing-mapcar
1183            (lambda (clause)
1184              (let ((filtered-body
1185                     (sharing-mapcar
1186                      (lambda (sub-printer)
1187                        (preprocess-conditionals sub-printer args))
1188                      (cdr clause))))
1189                (sharing-cons
1190                 clause
1191                 (preprocess-test (find-first-field-name filtered-body)
1192                                  (car clause)
1193                                  args)
1194                 filtered-body)))
1195            (cdr printer))))
1196         (quote printer)
1197         (t
1198          (sharing-mapcar
1199           (lambda (sub-printer)
1200             (preprocess-conditionals sub-printer args))
1201           printer)))))
1202
1203 ;;; Return a version of the disassembly-template PRINTER with
1204 ;;; compile-time tests (e.g. :constant without a value), and any
1205 ;;; :CHOOSE operators resolved properly for the args ARGS.
1206 ;;;
1207 ;;; (:CHOOSE Sub*) simply returns the first Sub in which every field
1208 ;;; reference refers to a valid arg.
1209 (defun preprocess-printer (printer args)
1210   (preprocess-conditionals (preprocess-chooses printer args) args))
1211 \f
1212 ;;; Return the first non-keyword symbol in a depth-first search of TREE.
1213 (defun find-first-field-name (tree)
1214   (cond ((null tree)
1215          nil)
1216         ((and (symbolp tree) (not (keywordp tree)))
1217          tree)
1218         ((atom tree)
1219          nil)
1220         ((eq (car tree) 'quote)
1221          nil)
1222         (t
1223          (or (find-first-field-name (car tree))
1224              (find-first-field-name (cdr tree))))))
1225
1226 (defun preprocess-chooses (printer args)
1227   (cond ((atom printer)
1228          printer)
1229         ((eq (car printer) :choose)
1230          (pick-printer-choice (cdr printer) args))
1231         (t
1232          (sharing-mapcar (lambda (sub) (preprocess-chooses sub args))
1233                          printer))))
1234 \f
1235 ;;;; some simple functions that help avoid consing when we're just
1236 ;;;; recursively filtering things that usually don't change
1237
1238 (defun sharing-cons (old-cons car cdr)
1239   #!+sb-doc
1240   "If CAR is eq to the car of OLD-CONS and CDR is eq to the CDR, return
1241   OLD-CONS, otherwise return (cons CAR CDR)."
1242   (if (and (eq car (car old-cons)) (eq cdr (cdr old-cons)))
1243       old-cons
1244       (cons car cdr)))
1245
1246 (defun sharing-mapcar (fun list)
1247   (declare (type function fun))
1248   #!+sb-doc
1249   "A simple (one list arg) mapcar that avoids consing up a new list
1250   as long as the results of calling FUN on the elements of LIST are
1251   eq to the original."
1252   (and list
1253        (sharing-cons list
1254                      (funcall fun (car list))
1255                      (sharing-mapcar fun (cdr list)))))
1256 \f
1257 (defun all-arg-refs-relevant-p (printer args)
1258   (cond ((or (null printer) (keywordp printer) (eq printer t))
1259          t)
1260         ((symbolp printer)
1261          (find printer args :key #'arg-name))
1262         ((listp printer)
1263          (every (lambda (x) (all-arg-refs-relevant-p x args))
1264                 printer))
1265         (t t)))
1266
1267 (defun pick-printer-choice (choices args)
1268   (dolist (choice choices
1269            (pd-error "no suitable choice found in ~S" choices))
1270     (when (all-arg-refs-relevant-p choice args)
1271       (return choice))))
1272
1273 (defun compile-printer-list (sources funstate)
1274   (unless (null sources)
1275     ;; Coalesce adjacent symbols/strings, and convert to strings if possible,
1276     ;; since they require less consing to write.
1277     (do ((el (car sources) (car sources))
1278          (names nil (cons (strip-quote el) names)))
1279         ((not (string-or-qsym-p el))
1280          (when names
1281            ;; concatenate adjacent strings and symbols
1282            (let ((string
1283                   (apply #'concatenate
1284                          'string
1285                          (mapcar #'string (nreverse names)))))
1286              (push (if (some #'alpha-char-p string)
1287                        `',(make-symbol string) ; Preserve casifying output.
1288                        string)
1289                    sources))))
1290       (pop sources))
1291     (cons (compile-printer-body (car sources) funstate)
1292           (compile-printer-list (cdr sources) funstate))))
1293
1294 (defun compile-printer-body (source funstate)
1295   (cond ((null source)
1296          nil)
1297         ((eq source :name)
1298          `(local-print-name))
1299         ((eq source :tab)
1300          `(local-tab-to-arg-column))
1301         ((keywordp source)
1302          (pd-error "unknown printer element: ~S" source))
1303         ((symbolp source)
1304          (compile-print source funstate))
1305         ((atom source)
1306          `(local-princ ',source))
1307         ((eq (car source) :using)
1308          (unless (or (stringp (cadr source))
1309                      (and (listp (cadr source))
1310                           (eq (caadr source) 'function)))
1311            (pd-error "The first arg to :USING must be a string or #'function."))
1312          (compile-print (caddr source) funstate
1313                         (cons (eval (cadr source)) (cadr source))))
1314         ((eq (car source) :plus-integer)
1315          ;; prints the given field proceed with a + or a -
1316          (let ((form
1317                 (arg-value-form (arg-or-lose (cadr source) funstate)
1318                                 funstate
1319                                 :numeric)))
1320            `(progn
1321               (when (>= ,form 0)
1322                 (local-write-char #\+))
1323               (local-princ ,form))))
1324         ((eq (car source) 'quote)
1325          `(local-princ ,source))
1326         ((eq (car source) 'function)
1327          `(local-call-global-printer ,source))
1328         ((eq (car source) :cond)
1329          `(cond ,@(mapcar (lambda (clause)
1330                             `(,(compile-test (find-first-field-name
1331                                               (cdr clause))
1332                                              (car clause)
1333                                              funstate)
1334                               ,@(compile-printer-list (cdr clause)
1335                                                       funstate)))
1336                           (cdr source))))
1337         ;; :IF, :UNLESS, and :WHEN are replaced by :COND during preprocessing
1338         (t
1339          `(progn ,@(compile-printer-list source funstate)))))
1340
1341 (defun compile-print (arg-name funstate &optional printer)
1342   (let* ((arg (arg-or-lose arg-name funstate))
1343          (printer (or printer (arg-printer arg)))
1344          (printer-val (value-or-source printer))
1345          (printer-src (source-form printer)))
1346     (remember-printer-use arg funstate)
1347     (cond ((stringp printer-val)
1348            `(local-format-arg ,(arg-value-form arg funstate) ,printer-val))
1349           ((vectorp printer-val)
1350            `(local-princ
1351              (aref ,printer-src
1352                    ,(arg-value-form arg funstate :numeric))))
1353           ((or (functionp printer-val)
1354                (and (consp printer-val) (eq (car printer-val) 'function)))
1355            `(local-call-arg-printer ,(arg-value-form arg funstate)
1356                                     ,printer-src))
1357           ((or (null printer-val) (eq printer-val t))
1358            `(,(if (arg-use-label arg) 'local-princ16 'local-princ)
1359              ,(arg-value-form arg funstate)))
1360           (t
1361            (pd-error "illegal printer: ~S" printer-src)))))
1362
1363 (defun string-or-qsym-p (thing)
1364   (or (stringp thing)
1365       (and (consp thing)
1366            (eq (car thing) 'quote)
1367            (or (stringp (cadr thing))
1368                (symbolp (cadr thing))))))
1369
1370 (defun strip-quote (thing)
1371   (if (and (consp thing) (eq (car thing) 'quote))
1372       (cadr thing)
1373       thing))
1374 \f
1375 (defun compare-fields-form (val-form-1 val-form-2)
1376   (flet ((listify-fields (fields)
1377            (cond ((symbolp fields) fields)
1378                  ((every #'constantp fields) `',fields)
1379                  (t `(list ,@fields)))))
1380     (cond ((or (symbolp val-form-1) (symbolp val-form-2))
1381            `(equal ,(listify-fields val-form-1)
1382                    ,(listify-fields val-form-2)))
1383           (t
1384            `(and ,@(mapcar (lambda (v1 v2) `(= ,v1 ,v2))
1385                            val-form-1 val-form-2))))))
1386
1387 (defun compile-test (subj test funstate)
1388   (when (and (consp test) (symbolp (car test)) (not (keywordp (car test))))
1389     (setf subj (car test)
1390           test (cdr test)))
1391   (let ((key (if (consp test) (car test) test))
1392         (body (if (consp test) (cdr test) nil)))
1393     (cond ((null key)
1394            nil)
1395           ((eq key t)
1396            t)
1397           ((eq key :constant)
1398            (let* ((arg (arg-or-lose subj funstate))
1399                   (fields (arg-fields arg))
1400                   (consts body))
1401              (when (not (= (length fields) (length consts)))
1402                (pd-error "The number of constants doesn't match number of ~
1403                           fields in: (~S :constant~{ ~S~})"
1404                          subj body))
1405              (compare-fields-form (gen-arg-forms arg :numeric funstate)
1406                                   consts)))
1407           ((eq key :positive)
1408            `(> ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric)
1409                0))
1410           ((eq key :negative)
1411            `(< ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric)
1412                0))
1413           ((eq key :same-as)
1414            (let ((arg1 (arg-or-lose subj funstate))
1415                  (arg2 (arg-or-lose (car body) funstate)))
1416              (unless (and (= (length (arg-fields arg1))
1417                              (length (arg-fields arg2)))
1418                           (every (lambda (bs1 bs2)
1419                                    (= (byte-size bs1) (byte-size bs2)))
1420                                  (arg-fields arg1)
1421                                  (arg-fields arg2)))
1422                (pd-error "can't compare differently sized fields: ~
1423                           (~S :same-as ~S)" subj (car body)))
1424              (compare-fields-form (gen-arg-forms arg1 :numeric funstate)
1425                                   (gen-arg-forms arg2 :numeric funstate))))
1426           ((eq key :or)
1427            `(or ,@(mapcar (lambda (sub) (compile-test subj sub funstate))
1428                           body)))
1429           ((eq key :and)
1430            `(and ,@(mapcar (lambda (sub) (compile-test subj sub funstate))
1431                            body)))
1432           ((eq key :not)
1433            `(not ,(compile-test subj (car body) funstate)))
1434           ((and (consp key) (null body))
1435            (compile-test subj key funstate))
1436           (t
1437            (pd-error "bogus test-form: ~S" test)))))
1438 \f
1439 (defun find-labeller-fun (%name args cache)
1440   (let ((labelled-fields
1441          (mapcar #'arg-name (remove-if-not #'arg-use-label args))))
1442     (if (null labelled-fields)
1443         (values nil nil)
1444         (!with-cached-fun
1445             (name funstate cache fun-cache-labellers args
1446              :stem (concatenate 'string "LABELLER-" (string %name))
1447              :constraint labelled-fields)
1448           (let ((labels-form 'labels))
1449             (dolist (arg args)
1450               (when (arg-use-label arg)
1451                 (setf labels-form
1452                       `(let ((labels ,labels-form)
1453                              (addr
1454                               ,(arg-value-form arg funstate :adjusted nil)))
1455                          (if (assoc addr labels :test #'eq)
1456                              labels
1457                              (cons (cons addr nil) labels))))))
1458             `(defun ,name (chunk labels dstate)
1459                (declare (type list labels)
1460                         (type dchunk chunk)
1461                         (type disassem-state dstate))
1462                (flet ((local-filtered-value (offset)
1463                         (declare (type filtered-value-index offset))
1464                         (aref (dstate-filtered-values dstate) offset))
1465                       (local-extract (bytespec)
1466                         (dchunk-extract chunk bytespec))
1467                       (adjust-label (val adjust-fun)
1468                         (funcall adjust-fun val dstate)))
1469                  (declare (ignorable #'local-filtered-value #'local-extract
1470                                      #'adjust-label)
1471                           (inline local-filtered-value local-extract
1472                                   adjust-label))
1473                  (let* ,(make-arg-temp-bindings funstate)
1474                    ,labels-form))))))))
1475
1476 (defun find-prefilter-fun (%name %format-name args cache)
1477   (declare (type (or symbol string) %name %format-name))
1478   (let ((filtered-args (mapcar #'arg-name
1479                                (remove-if-not #'arg-prefilter args))))
1480     (if (null filtered-args)
1481         (values nil nil)
1482         (!with-cached-fun
1483             (name funstate cache fun-cache-prefilters args
1484              :stem (concatenate 'string
1485                                 (string %name)
1486                                 "-"
1487                                 (string %format-name)
1488                                 "-PREFILTER")
1489              :constraint filtered-args)
1490           (collect ((forms))
1491             (dolist (arg args)
1492               (let ((pf (arg-prefilter arg)))
1493                 (when pf
1494                   (forms
1495                    `(setf (local-filtered-value ,(arg-position arg))
1496                           ,(maybe-listify
1497                             (gen-arg-forms arg :filtering funstate)))))
1498                 ))
1499             `(defun ,name (chunk dstate)
1500                (declare (type dchunk chunk)
1501                         (type disassem-state dstate))
1502                (flet (((setf local-filtered-value) (value offset)
1503                        (declare (type filtered-value-index offset))
1504                        (setf (aref (dstate-filtered-values dstate) offset)
1505                              value))
1506                       (local-filter (value filter)
1507                                     (funcall filter value dstate))
1508                       (local-extract (bytespec)
1509                                      (dchunk-extract chunk bytespec)))
1510                 (declare (ignorable #'local-filter #'local-extract)
1511                          (inline (setf local-filtered-value)
1512                                  local-filter local-extract))
1513                 ;; Use them for side effects only.
1514                 (let* ,(make-arg-temp-bindings funstate)
1515                   ,@(forms)))))))))
1516 \f
1517 (defun compute-mask-id (args)
1518   (let ((mask dchunk-zero)
1519         (id dchunk-zero))
1520     (dolist (arg args (values mask id))
1521       (let ((av (arg-value arg)))
1522         (when av
1523           (do ((fields (arg-fields arg) (cdr fields))
1524                (values (if (atom av) (list av) av) (cdr values)))
1525               ((null fields))
1526             (let ((field-mask (dchunk-make-mask (car fields))))
1527               (when (/= (dchunk-and mask field-mask) dchunk-zero)
1528                 (pd-error "The field ~S in arg ~S overlaps some other field."
1529                           (car fields)
1530                           (arg-name arg)))
1531               (dchunk-insertf id (car fields) (car values))
1532               (dchunk-orf mask field-mask))))))))
1533
1534 (defun install-inst-flavors (name flavors)
1535   (setf (gethash name *disassem-insts*)
1536         flavors))
1537 \f
1538 #!-sb-fluid (declaim (inline bytes-to-bits))
1539 (declaim (maybe-inline sign-extend aligned-p align tab tab0))
1540
1541 (defun bytes-to-bits (bytes)
1542   (declare (type disassem-length bytes))
1543   (* bytes sb!vm:n-byte-bits))
1544
1545 (defun bits-to-bytes (bits)
1546   (declare (type disassem-length bits))
1547   (multiple-value-bind (bytes rbits)
1548       (truncate bits sb!vm:n-byte-bits)
1549     (when (not (zerop rbits))
1550       (error "~W bits is not a byte-multiple." bits))
1551     bytes))
1552
1553 (defun sign-extend (int size)
1554   (declare (type integer int)
1555            (type (integer 0 128) size))
1556   (if (logbitp (1- size) int)
1557       (dpb int (byte size 0) -1)
1558       int))
1559
1560 ;;; Is ADDRESS aligned on a SIZE byte boundary?
1561 (defun aligned-p (address size)
1562   (declare (type address address)
1563            (type alignment size))
1564   (zerop (logand (1- size) address)))
1565
1566 ;;; Return ADDRESS aligned *upward* to a SIZE byte boundary.
1567 (defun align (address size)
1568   (declare (type address address)
1569            (type alignment size))
1570   (logandc1 (1- size) (+ (1- size) address)))
1571
1572 (defun tab (column stream)
1573   (funcall (formatter "~V,1t") stream column)
1574   nil)
1575 (defun tab0 (column stream)
1576   (funcall (formatter "~V,0t") stream column)
1577   nil)
1578
1579 (defun princ16 (value stream)
1580   (write value :stream stream :radix t :base 16 :escape nil))
1581 \f
1582 (defun read-signed-suffix (length dstate)
1583   (declare (type (member 8 16 32 64) length)
1584            (type disassem-state dstate)
1585            (optimize (speed 3) (safety 0)))
1586   (sign-extend (read-suffix length dstate) length))
1587 \f
1588 ;;; All state during disassembly. We store some seemingly redundant
1589 ;;; information so that we can allow garbage collect during disassembly and
1590 ;;; not get tripped up by a code block being moved...
1591 (defstruct (disassem-state (:conc-name dstate-)
1592                            (:constructor %make-dstate)
1593                            (:copier nil))
1594   ;; offset of current pos in segment
1595   (cur-offs 0 :type offset)
1596   ;; offset of next position
1597   (next-offs 0 :type offset)
1598   ;; a sap pointing to our segment
1599   (segment-sap (missing-arg) :type sb!sys:system-area-pointer)
1600   ;; the current segment
1601   (segment nil :type (or null segment))
1602   ;; what to align to in most cases
1603   (alignment sb!vm:n-word-bytes :type alignment)
1604   (byte-order :little-endian
1605               :type (member :big-endian :little-endian))
1606   ;; for user code to hang stuff off of
1607   (properties nil :type list)
1608   ;; for user code to hang stuff off of, cleared each time before an
1609   ;; instruction is processed
1610   (inst-properties nil :type list)
1611   (filtered-values (make-array max-filtered-value-index)
1612                    :type filtered-value-vector)
1613   ;; used for prettifying printing
1614   (addr-print-len nil :type (or null (integer 0 20)))
1615   (argument-column 0 :type column)
1616   ;; to make output look nicer
1617   (output-state :beginning
1618                 :type (member :beginning
1619                               :block-boundary
1620                               nil))
1621
1622   ;; alist of (address . label-number)
1623   (labels nil :type list)
1624   ;; same as LABELS slot data, but in a different form
1625   (label-hash (make-hash-table) :type hash-table)
1626   ;; list of function
1627   (fun-hooks nil :type list)
1628
1629   ;; alist of (address . label-number), popped as it's used
1630   (cur-labels nil :type list)
1631   ;; OFFS-HOOKs, popped as they're used
1632   (cur-offs-hooks nil :type list)
1633
1634   ;; for the current location
1635   (notes nil :type list)
1636
1637   ;; currently active source variables
1638   (current-valid-locations nil :type (or null (vector bit))))
1639 (def!method print-object ((dstate disassem-state) stream)
1640   (print-unreadable-object (dstate stream :type t)
1641     (format stream
1642             "+~W~@[ in ~S~]"
1643             (dstate-cur-offs dstate)
1644             (dstate-segment dstate))))
1645
1646 ;;; Return the absolute address of the current instruction in DSTATE.
1647 (defun dstate-cur-addr (dstate)
1648   (the address (+ (seg-virtual-location (dstate-segment dstate))
1649                   (dstate-cur-offs dstate))))
1650
1651 ;;; Return the absolute address of the next instruction in DSTATE.
1652 (defun dstate-next-addr (dstate)
1653   (the address (+ (seg-virtual-location (dstate-segment dstate))
1654                   (dstate-next-offs dstate))))
1655
1656 ;;; Get the value of the property called NAME in DSTATE. Also SETF'able.
1657 ;;;
1658 ;;; KLUDGE: The associated run-time machinery for this is in
1659 ;;; target-disassem.lisp (much later). This is here just to make sure
1660 ;;; it's defined before it's used. -- WHN ca. 19990701
1661 (defmacro dstate-get-prop (dstate name)
1662   `(getf (dstate-properties ,dstate) ,name))
1663
1664 ;;; Push NAME on the list of instruction properties in DSTATE.
1665 (defun dstate-put-inst-prop (dstate name)
1666   (push name (dstate-inst-properties dstate)))
1667
1668 ;;; Return non-NIL if NAME is on the list of instruction properties in
1669 ;;; DSTATE.
1670 (defun dstate-get-inst-prop (dstate name)
1671   (member name (dstate-inst-properties dstate) :test #'eq))