/[cmucl]/src/compiler/disassem.lisp
ViewVC logotype

Contents of /src/compiler/disassem.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.58 - (show annotations)
Tue Apr 20 17:57:46 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.57: +46 -46 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: DISASSEM -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/disassem.lisp,v 1.58 2010/04/20 17:57:46 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Machine independent disassembler for CMU Common Lisp
13 ;;;
14 ;;; Written by Miles Bader <miles@cogsci.ed.ac.uk>
15 ;;;
16
17 (in-package :disassem)
18 (intl:textdomain "cmucl")
19
20 (use-package :extensions)
21
22 (export '(;; for defining the instruction set
23 set-disassem-params
24 define-argument-type
25 define-instruction-format
26 install-inst-flavors
27
28 ;; macroexpanders
29 gen-preamble-form gen-clear-info-form
30 gen-arg-type-def-form gen-format-def-form
31 gen-printer-def-forms-def-form
32
33 ;; main user entry-points
34 disassemble
35 disassemble-memory
36 disassemble-function
37 disassemble-code-component
38 disassemble-assem-segment
39
40 ;; some variables to set
41 *opcode-column-width*
42 *note-column*
43
44 ;; slightly lower level entry-points
45 make-dstate
46 get-function-segments get-code-segments
47 label-segments disassemble-segments disassemble-segment
48 map-segment-instructions
49 segment-overflow
50 set-location-printing-range
51 add-offs-hook add-offs-note-hook add-offs-comment-hook
52 *default-dstate-hooks*
53 make-segment make-code-segment make-vector-segment make-memory-segment
54 make-offs-hook
55
56 ;; segment type
57 segment seg-sap-maker seg-length seg-virtual-location
58
59 ;; decoding a bit-pattern
60 sap-ref-dchunk
61 get-inst-space
62 find-inst
63
64 ;; getting at the dstate (usually from mach-dep code)
65 disassem-state dstate-cur-offs dstate-next-offs
66 dstate-segment dstate-segment-sap
67 dstate-get-prop
68 dstate-cur-addr dstate-next-addr
69
70 ;; random types
71 dchunk params instruction
72
73 ;;
74 read-suffix read-signed-suffix
75 sign-extend
76
77 ;; useful for printers
78 princ16
79
80 ;; making handy margin notes
81 note
82 note-code-constant
83 maybe-note-nil-indexed-symbol-slot-ref
84 maybe-note-nil-indexed-object
85 maybe-note-assembler-routine
86 maybe-note-static-function
87 maybe-note-single-storage-ref
88 maybe-note-associated-storage-ref
89 handle-break-args
90
91 ;; taking over and printing...
92 print-notes-and-newline
93 print-current-address
94 print-bytes print-words
95 prin1-short
96 prin1-quoted-short
97 ))
98
99 ;;; ----------------------------------------------------------------
100
101 (defvar *opcode-column-width* nil
102 "The width of the column in which instruction-names are printed.
103 NIL means use the default. A value of zero gives the effect of not
104 aligning the arguments at all.")
105 (defvar *note-column* 45
106 "The column in which end-of-line comments for notes are started.")
107
108 (defconstant default-opcode-column-width 6)
109 (defconstant default-location-column-width 8)
110 (defconstant label-column-width 7)
111
112 (deftype address () '(unsigned-byte 32))
113 (deftype alignment () '(integer 0 64))
114 (deftype offset () '(signed-byte 24))
115 (deftype length () '(unsigned-byte 24))
116
117 (deftype column () '(integer 0 1000))
118 (deftype text-width () '(integer 0 1000))
119
120 (defconstant max-filtered-value-index 32)
121 (deftype filtered-value-index ()
122 `(integer 0 ,max-filtered-value-index))
123 (deftype filtered-value-vector ()
124 `(simple-array t (,max-filtered-value-index)))
125
126 #+sparc
127 (declaim (special vm::*note-sethi-inst* vm::*pseudo-atomic-set*))
128
129 ;;; ----------------------------------------------------------------
130
131 (defmacro set-disassem-params (&rest args)
132 "Specify global disassembler params for C:*TARGET-BACKEND*.
133 Keyword arguments include:
134
135 :INSTRUCTION-ALIGNMENT number
136 Minimum alignment of instructions, in bits.
137
138 :ADDRESS-SIZE number
139 Size of a machine address, in bits.
140
141 :OPCODE-COLUMN-WIDTH
142 Width of the column used for printing the opcode portion of the
143 instruction, or NIL to use the default."
144 (gen-preamble-form args))
145
146 (defmacro define-argument-type (name &rest args)
147 "DEFINE-ARGUMENT-TYPE Name {Key Value}*
148 Define a disassembler argument type NAME (which can then be referenced in
149 another argument definition using the :TYPE keyword argument). Keyword
150 arguments are:
151
152 :SIGN-EXTEND boolean
153 If non-NIL, the raw value of this argument is sign-extended.
154
155 :TYPE arg-type-name
156 Inherit any properties of given argument-type.
157
158 :PREFILTER function
159 A function which is called (along with all other prefilters, in the
160 order that their arguments appear in the instruction- format) before
161 any printing is done, to filter the raw value. Any uses of READ-SUFFIX
162 must be done inside a prefilter.
163
164 :PRINTER function-string-or-vector
165 A function, string, or vector which is used to print an argument of
166 this type.
167
168 :USE-LABEL
169 If non-NIL, the value of an argument of this type is used as an
170 address, and if that address occurs inside the disassembled code, it is
171 replaced by a label. If this is a function, it is called to filter the
172 value."
173 (gen-arg-type-def-form name args))
174
175 (defmacro define-instruction-format (header &rest fields)
176 "DEFINE-INSTRUCTION-FORMAT (Name Length {Format-Key Value}*) Arg-Def*
177 Define an instruction format NAME for the disassembler's use. LENGTH is
178 the length of the format in bits.
179 Possible FORMAT-KEYs:
180
181 :INCLUDE other-format-name
182 Inherit all arguments and properties of the given format. Any
183 arguments defined in the current format definition will either modify
184 the copy of an existing argument (keeping in the same order with
185 respect to when pre-filter's are called), if it has the same name as
186 one, or be added to the end.
187 :DEFAULT-PRINTER printer-list
188 Use the given PRINTER-LIST as a format to print any instructions of
189 this format when they don't specify something else.
190
191 Each ARG-DEF defines one argument in the format, and is of the form
192 (Arg-Name {Arg-Key Value}*)
193
194 Possible ARG-KEYs (the values are evaulated unless otherwise specified):
195
196 :FIELDS byte-spec-list
197 The argument takes values from these fields in the instruction. If
198 the list is of length one, then the corresponding value is supplied by
199 itself; otherwise it is a list of the values. The list may be NIL.
200 :FIELD byte-spec
201 The same as :FIELDS (list byte-spec).
202
203 :VALUE value
204 If the argument only has one field, this is the value it should have,
205 otherwise it's a list of the values of the individual fields. This can
206 be overridden in an instruction-definition or a format definition
207 including this one by specifying another, or NIL to indicate that it's
208 variable.
209
210 :SIGN-EXTEND boolean
211 If non-NIL, the raw value of this argument is sign-extended,
212 immediately after being extracted from the instruction (before any
213 prefilters are run, for instance). If the argument has multiple
214 fields, they are all sign-extended.
215
216 :TYPE arg-type-name
217 Inherit any properties of the given argument-type.
218
219 :PREFILTER function
220 A function which is called (along with all other prefilters, in the
221 order that their arguments appear in the instruction-format) before
222 any printing is done, to filter the raw value. Any uses of READ-SUFFIX
223 must be done inside a prefilter.
224
225 :PRINTER function-string-or-vector
226 A function, string, or vector which is used to print this argument.
227
228 :USE-LABEL
229 If non-NIL, the value of this argument is used as an address, and if
230 that address occurs inside the disassembled code, it is replaced by a
231 label. If this is a function, it is called to filter the value."
232 (gen-format-def-form header fields))
233
234 ;;; ----------------------------------------------------------------
235
236 (declaim (inline bytes-to-bits)
237 (maybe-inline sign-extend aligned-p align tab tab0))
238
239 (defun bytes-to-bits (bytes)
240 (declare (type length bytes))
241 (* bytes vm:byte-bits))
242
243 (defun bits-to-bytes (bits)
244 (declare (type length bits))
245 (multiple-value-bind (bytes rbits)
246 (truncate bits vm:byte-bits)
247 (when (not (zerop rbits))
248 (error (intl:gettext "~d bits is not a byte-multiple") bits))
249 bytes))
250
251 (defun sign-extend (int size)
252 (declare (type integer int)
253 (type (integer 0 128) size))
254 (if (logbitp (1- size) int)
255 (dpb int (byte size 0) -1)
256 int))
257
258 (defun aligned-p (address size)
259 "Returns non-NIL if ADDRESS is aligned on a SIZE byte boundary."
260 (declare (type address address)
261 (type alignment size))
262 (zerop (logand (1- size) address)))
263
264 (defun align (address size)
265 "Return ADDRESS aligned *upward* to a SIZE byte boundary."
266 (declare (type address address)
267 (type alignment size))
268 (logandc1 (1- size) (+ (1- size) address)))
269
270 (defun tab (column stream)
271 (funcall (formatter "~v,1t") stream column)
272 nil)
273 (defun tab0 (column stream)
274 (funcall (formatter "~v,0t") stream column)
275 nil)
276
277 (defun princ16 (value stream)
278 (write value :stream stream :radix t :base 16 :escape nil))
279
280 ;;; ----------------------------------------------------------------
281
282 (defun self-evaluating-p (x)
283 (typecase x
284 (null t)
285 (keyword t)
286 (symbol (eq x t))
287 (cons nil)
288 (t t)))
289
290 ;;; ----------------------------------------------------------------
291 ;;; Some simple functions that help avoid consing when we're just
292 ;;; recursively filtering things that usually don't change.
293
294 (defun sharing-cons (old-cons car cdr)
295 "If CAR is eq to the car of OLD-CONS and CDR is eq to the CDR, return
296 OLD-CONS, otherwise return (cons CAR CDR)."
297 (if (and (eq car (car old-cons)) (eq cdr (cdr old-cons)))
298 old-cons
299 (cons car cdr)))
300
301 (defun sharing-mapcar (fun list)
302 "A simple (one list arg) mapcar that avoids consing up a new list
303 as long as the results of calling FUN on the elements of LIST are
304 eq to the original."
305 (and list
306 (sharing-cons list
307 (funcall fun (car list))
308 (sharing-mapcar fun (cdr list)))))
309
310 ;;; ----------------------------------------------------------------
311 ;;; A Dchunk contains the bits we look at to decode an
312 ;;; instruction.
313 ;;; I tried to keep this abstract so that if using integers > the machine
314 ;;; word size conses too much, it can be changed to use bit-vectors or
315 ;;; something.
316
317 (declaim (inline dchunk-or dchunk-and dchunk-clear dchunk-not
318 dchunk-make-mask dchunk-make-field
319 sap-ref-dchunk
320 dchunk-extract
321 dchunk=
322 dchunk-count-bits))
323
324 (defconstant dchunk-bits 32)
325
326 (deftype dchunk ()
327 `(unsigned-byte ,dchunk-bits))
328 (deftype dchunk-index ()
329 `(integer 0 ,dchunk-bits))
330
331 (defconstant dchunk-zero 0)
332 (defconstant dchunk-one #xFFFFFFFF)
333
334 (defmacro dchunk-copy (x)
335 `(the dchunk ,x))
336
337 (defun dchunk-or (to from)
338 (declare (type dchunk to from))
339 (the dchunk (logior to from)))
340 (defun dchunk-and (to from)
341 (declare (type dchunk to from))
342 (the dchunk (logand to from)))
343 (defun dchunk-clear (to from)
344 (declare (type dchunk to from))
345 (the dchunk (logandc2 to from)))
346 (defun dchunk-not (from)
347 (declare (type dchunk from))
348 (the dchunk (logand dchunk-one (lognot from))))
349
350 (defmacro dchunk-andf (to from)
351 `(setf ,to (dchunk-and ,to ,from)))
352 (defmacro dchunk-orf (to from)
353 `(setf ,to (dchunk-or ,to ,from)))
354 (defmacro dchunk-clearf (to from)
355 `(setf ,to (dchunk-clear ,to ,from)))
356
357 (defun dchunk-make-mask (pos)
358 (the dchunk (mask-field pos -1)))
359 (defun dchunk-make-field (pos value)
360 (the dchunk (dpb value pos 0)))
361
362 (defmacro make-dchunk (value)
363 `(the dchunk ,value))
364
365 (defun sap-ref-dchunk (sap byte-offset byte-order)
366 (declare (type system:system-area-pointer sap)
367 (type offset byte-offset)
368 (optimize (speed 3) (safety 0)))
369 (the dchunk
370 (if (eq byte-order :big-endian)
371 (+ (ash (system:sap-ref-8 sap byte-offset) 24)
372 (ash (system:sap-ref-8 sap (+ 1 byte-offset)) 16)
373 (ash (system:sap-ref-8 sap (+ 2 byte-offset)) 8)
374 (system:sap-ref-8 sap (+ 3 byte-offset)))
375 (+ (system:sap-ref-8 sap byte-offset)
376 (ash (system:sap-ref-8 sap (+ 1 byte-offset)) 8)
377 (ash (system:sap-ref-8 sap (+ 2 byte-offset)) 16)
378 (ash (system:sap-ref-8 sap (+ 3 byte-offset)) 24)))))
379
380 (defun correct-dchunk-bytespec-for-endianness (bs unit-bits byte-order)
381 (if (eq byte-order :big-endian)
382 (byte (byte-size bs) (+ (byte-position bs) (- dchunk-bits unit-bits)))
383 bs))
384
385 (defun dchunk-extract (from pos)
386 (declare (type dchunk from))
387 (the dchunk (ldb pos (the dchunk from))))
388
389 (defun dchunk-corrected-extract (from pos unit-bits byte-order)
390 (declare (type dchunk from))
391 (if (eq byte-order :big-endian)
392 (ldb (byte (byte-size pos)
393 (+ (byte-position pos) (- dchunk-bits unit-bits)))
394 (the dchunk from))
395 (ldb pos (the dchunk from))))
396
397 (defmacro dchunk-insertf (place pos value)
398 `(setf ,place (the dchunk (dpb ,value ,pos (the dchunk,place)))))
399
400 (defun dchunk= (x y)
401 (declare (type dchunk x y))
402 (= x y))
403 (defmacro dchunk-zerop (x)
404 `(dchunk= ,x dchunk-zero))
405
406 (defun dchunk-strict-superset-p (sup sub)
407 (and (zerop (logandc2 sub sup))
408 (not (zerop (logandc2 sup sub)))))
409
410 (defun dchunk-count-bits (x)
411 (declare (type dchunk x))
412 (logcount x))
413
414 ;;; ----------------------------------------------------------------
415
416 (defstruct (params (:print-function %print-params))
417 (instructions (make-hash-table :test #'eq) :type hash-table)
418 (inst-space nil :type (or null inst-space))
419 (instruction-alignment vm:word-bytes :type alignment)
420 (location-column-width default-location-column-width :type text-width)
421 (opcode-column-width default-opcode-column-width :type (or null text-width))
422 (backend (required-argument) :type c::backend) ; for convenience
423 )
424
425 (defun %print-params (params stream level)
426 (declare (ignore level))
427 (print-unreadable-object (params stream :type t)
428 (when (params-backend params)
429 (prin1 (c:backend-name (params-backend params)) stream))))
430
431 ;;; ----------------------------------------------------------------
432 ;;; Only used during compilation of the instructions for a backend
433
434 (defstruct (argument (:conc-name arg-))
435 (name nil :type symbol)
436 (fields nil :type list)
437
438 (value nil :type (or list integer))
439 (sign-extend-p nil :type (member t nil))
440
441 ;; position in a vector of prefiltered values
442 (position 0 :type fixnum)
443
444 ;; functions to use
445 (printer nil)
446 (prefilter nil)
447 (use-label nil)
448 )
449
450 (defstruct (instruction-format (:conc-name format-))
451 (name nil)
452 (args nil :type list)
453
454 (length 0 :type length) ; in bytes
455
456 (default-printer nil :type list)
457 )
458
459 ;;; ----------------------------------------------------------------
460 ;;;
461
462 (defstruct (instruction (:conc-name inst-)
463 (:print-function %print-instruction)
464 (:constructor
465 make-instruction (name
466 format-name
467 print-name
468 length
469 mask id
470 printer
471 labeller prefilter control)))
472 (name nil :type (or symbol string))
473 (format-name nil :type (or symbol string))
474
475 (mask dchunk-zero :type dchunk) ; bits in the inst that are constant
476 (id dchunk-zero :type dchunk) ; value of those constant bits
477
478 (length 0 :type length) ; in bytes
479
480 (print-name nil :type symbol)
481
482 ;; disassembly functions
483 (prefilter nil :type (or null function))
484 (labeller nil :type (or null function))
485 (printer (required-argument) :type (or null function))
486 (control nil :type (or null function))
487
488 ;; instructions that are the same as this instruction but with more
489 ;; constraints
490 (specializers nil :type list)
491 )
492
493 (defun %print-instruction (inst stream depth)
494 (declare (ignore depth))
495 (print-unreadable-object (inst stream :type t :identity t)
496 (format stream "~a(~a)" (inst-name inst) (inst-format-name inst))))
497
498 ;;; ----------------------------------------------------------------
499 ;;; provide more meaningful error messages during compilation
500
501 (defvar *current-instruction-flavor* nil)
502
503 (defun pd-error (fmt &rest args)
504 (if *current-instruction-flavor*
505 (error "~@<In printer-definition for ~s(~s): ~3i~:_~?~:>"
506 (car *current-instruction-flavor*)
507 (cdr *current-instruction-flavor*)
508 fmt args)
509 (apply #'error fmt args)))
510
511 ;;; ----------------------------------------------------------------
512 ;;; Since we can't include some values in compiled output as they are
513 ;;; (notably functions), we sometimes use a valsrc structure to keep track of
514 ;;; the source from which they were derived.
515
516 (defstruct (valsrc (:constructor %make-valsrc))
517 (value nil)
518 (source nil))
519
520 ;;; Returns a version of THING suitable for including in an evaluable
521 ;;; position in some form.
522 (defun source-form (thing)
523 (cond ((valsrc-p thing)
524 (valsrc-source thing))
525 ((functionp thing)
526 (pd-error
527 (intl:gettext "Can't dump functions, so function ref form must be quoted: ~s")
528 thing))
529 ((self-evaluating-p thing)
530 thing)
531 ((eq (car thing) 'function)
532 thing)
533 (t
534 `',thing)))
535
536 ;;; Returns anything but a valsrc structure.
537 (defun value-or-source (thing)
538 (if (valsrc-p thing)
539 (valsrc-value thing)
540 thing))
541
542 (defun make-valsrc (value source)
543 (cond ((equal value source)
544 source)
545 ((and (listp value) (eq (car value) 'function))
546 value)
547 (t
548 (%make-valsrc :value value :source source))))
549
550 ;;; ----------------------------------------------------------------
551 ;;; A funstate holds the state of any arguments used in a disassembly
552 ;;; function.
553
554 (defstruct (funstate (:conc-name funstate-) (:constructor %make-funstate))
555 (args nil :type list)
556 (arg-temps nil :type list) ; see below
557 )
558
559 (defun make-funstate (args)
560 ;; give the args a position
561 (let ((i 0))
562 (dolist (arg args)
563 (setf (arg-position arg) i)
564 (incf i)))
565 (%make-funstate :args args))
566
567 (defun arg-or-lose (name funstate)
568 (let ((arg (find name (funstate-args funstate) :key #'arg-name)))
569 (when (null arg)
570 (pd-error (intl:gettext "Unknown argument ~s") name))
571 arg))
572
573 (defun get-arg-temp (arg kind funstate)
574 (let ((this-arg-temps (assoc arg (funstate-arg-temps funstate))))
575 (if this-arg-temps
576 (let ((this-kind-temps
577 (assoc (canonicalize-arg-form-kind kind)
578 (cdr this-arg-temps))))
579 (values (cadr this-kind-temps) (cddr this-kind-temps)))
580 (values nil nil))))
581
582 (defun make-arg-temp-bindings (funstate)
583 ;; Everything is in reverse order, so we just use push, which results in
584 ;; everything being in the right order at the end.
585 (let ((bindings nil))
586 (dolist (ats (funstate-arg-temps funstate))
587 (dolist (atk (cdr ats))
588 (cond ((null (cadr atk)))
589 ((atom (cadr atk))
590 (push `(,(cadr atk) ,(cddr atk)) bindings))
591 (t
592 (mapc #'(lambda (var form)
593 (push `(,var ,form) bindings))
594 (cadr atk)
595 (cddr atk))))))
596 bindings))
597
598 (defun set-arg-temps (vars forms arg kind funstate)
599 (let ((this-arg-temps
600 (or (assoc arg (funstate-arg-temps funstate))
601 (car (push (cons arg nil) (funstate-arg-temps funstate)))))
602 (kind (canonicalize-arg-form-kind kind)))
603 (let ((this-kind-temps
604 (or (assoc kind (cdr this-arg-temps))
605 (car (push (cons kind nil) (cdr this-arg-temps))))))
606 (setf (cdr this-kind-temps) (cons vars forms)))))
607
608 (defun gen-arg-forms (arg kind funstate)
609 (multiple-value-bind (vars forms)
610 (get-arg-temp arg kind funstate)
611 (when (null forms)
612 (multiple-value-bind (new-forms single-value-p)
613 (funcall (find-arg-form-producer kind) arg funstate)
614 (setq forms new-forms)
615 (cond ((or single-value-p (atom forms))
616 (unless (symbolp forms)
617 (setq vars (gensym))))
618 ((every #'symbolp forms)
619 ;; just use the same as the forms
620 (setq vars nil))
621 (t
622 (setq vars nil)
623 (dotimes (i (length forms))
624 (push (gensym) vars))))
625 (set-arg-temps vars forms arg kind funstate)))
626 (or vars forms)))
627
628 (defun funstate-compatible-p (funstate args)
629 (every #'(lambda (this-arg-temps)
630 (let* ((old-arg (car this-arg-temps))
631 (new-arg (find (arg-name old-arg) args :key #'arg-name)))
632 (and new-arg
633 (every #'(lambda (this-kind-temps)
634 (funcall (find-arg-form-checker
635 (car this-kind-temps))
636 new-arg
637 old-arg))
638 (cdr this-arg-temps)))))
639 (funstate-arg-temps funstate)))
640
641 (defun maybe-listify (forms)
642 (cond ((atom forms)
643 forms)
644 ((/= (length forms) 1)
645 `(list ,@forms))
646 (t
647 (car forms))))
648
649 (defun arg-value-form (arg funstate
650 &optional
651 (kind :final)
652 (allow-multiple-p (not (eq kind :numeric))))
653 (let ((forms (gen-arg-forms arg kind funstate)))
654 (when (and (not allow-multiple-p)
655 (listp forms)
656 (/= (length forms) 1))
657 (pd-error (intl:gettext "~s must not have multiple values") arg))
658 (maybe-listify forms)))
659
660 ;;; ----------------------------------------------------------------
661 ;;; These are the kind of values we can compute for an argument, and
662 ;;; how to compute them. The :checker functions make sure that a given
663 ;;; argument is compatible with another argument for a given use.
664
665 (defvar *arg-form-kinds* nil)
666
667 (defstruct arg-form-kind
668 (names nil :type list)
669 (producer (required-argument) :type function)
670 (checker (required-argument) :type function)
671 )
672
673 (defun arg-form-kind-or-lose (kind)
674 (or (getf *arg-form-kinds* kind)
675 (pd-error (intl:gettext "Unknown arg-form kind ~s") kind)))
676
677 (defun find-arg-form-producer (kind)
678 (arg-form-kind-producer (arg-form-kind-or-lose kind)))
679 (defun find-arg-form-checker (kind)
680 (arg-form-kind-checker (arg-form-kind-or-lose kind)))
681
682 (defun canonicalize-arg-form-kind (kind)
683 (car (arg-form-kind-names (arg-form-kind-or-lose kind))))
684
685 (defmacro def-arg-form-kind ((&rest names) &rest inits)
686 `(let ((kind (make-arg-form-kind :names ',names ,@inits)))
687 ,@(mapcar #'(lambda (name)
688 `(setf (getf *arg-form-kinds* ',name) kind))
689 names)))
690
691 (def-arg-form-kind (:raw)
692 :producer #'(lambda (arg funstate)
693 (declare (ignore funstate))
694 (mapcar #'(lambda (bytespec)
695 `(the (unsigned-byte ,(byte-size bytespec))
696 (local-extract ',bytespec)))
697 (arg-fields arg)))
698 :checker #'(lambda (new-arg old-arg)
699 (equal (arg-fields new-arg)
700 (arg-fields old-arg))))
701
702 (def-arg-form-kind (:sign-extended :unfiltered)
703 :producer #'(lambda (arg funstate)
704 (let ((raw-forms (gen-arg-forms arg :raw funstate)))
705 (if (and (arg-sign-extend-p arg) (listp raw-forms))
706 (mapcar #'(lambda (form field)
707 `(the (signed-byte ,(byte-size field))
708 (sign-extend ,form
709 ,(byte-size field))))
710 raw-forms
711 (arg-fields arg))
712 raw-forms)))
713 :checker #'(lambda (new-arg old-arg)
714 (equal (arg-sign-extend-p new-arg)
715 (arg-sign-extend-p old-arg))))
716
717 (defun valsrc-equal (f1 f2)
718 (if (null f1)
719 (null f2)
720 (equal (value-or-source f1)
721 (value-or-source f2))))
722
723 (def-arg-form-kind (:filtering)
724 :producer #'(lambda (arg funstate)
725 (let ((sign-extended-forms
726 (gen-arg-forms arg :sign-extended funstate))
727 (pf (arg-prefilter arg)))
728 (if pf
729 (values
730 `(local-filter ,(maybe-listify sign-extended-forms)
731 ,(source-form pf))
732 t)
733 (values sign-extended-forms nil))))
734 :checker #'(lambda (new-arg old-arg)
735 (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
736
737 (def-arg-form-kind (:filtered :unadjusted)
738 :producer #'(lambda (arg funstate)
739 (let ((pf (arg-prefilter arg)))
740 (if pf
741 (values `(local-filtered-value ,(arg-position arg)) t)
742 (gen-arg-forms arg :sign-extended funstate))))
743 :checker #'(lambda (new-arg old-arg)
744 (let ((pf1 (arg-prefilter new-arg))
745 (pf2 (arg-prefilter old-arg)))
746 (if (null pf1)
747 (null pf2)
748 (= (arg-position new-arg)
749 (arg-position old-arg))))))
750
751 (def-arg-form-kind (:adjusted :numeric :unlabelled)
752 :producer #'(lambda (arg funstate)
753 (let ((filtered-forms (gen-arg-forms arg :filtered funstate))
754 (use-label (arg-use-label arg)))
755 (if (and use-label (not (eq use-label t)))
756 (list
757 `(adjust-label ,(maybe-listify filtered-forms)
758 ,(source-form use-label)))
759 filtered-forms)))
760 :checker #'(lambda (new-arg old-arg)
761 (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
762
763 (def-arg-form-kind (:labelled :final)
764 :producer #'(lambda (arg funstate)
765 (let ((adjusted-forms
766 (gen-arg-forms arg :adjusted funstate))
767 (use-label (arg-use-label arg)))
768 (if use-label
769 (let ((form (maybe-listify adjusted-forms)))
770 (if (and (not (eq use-label t))
771 (not (atom adjusted-forms))
772 (/= (Length adjusted-forms) 1))
773 (pd-error
774 (intl:gettext "Cannot label a multiple-field argument ~
775 unless using a function: ~s") arg)
776 `((lookup-label ,form))))
777 adjusted-forms)))
778 :checker #'(lambda (new-arg old-arg)
779 (let ((lf1 (arg-use-label new-arg))
780 (lf2 (arg-use-label old-arg)))
781 (if (null lf1) (null lf2) t))))
782
783 ;;; This is a bogus kind that's just used to ensure that printers are
784 ;;; compatible...
785 (def-arg-form-kind (:printed)
786 :producer #'(lambda (&rest noise)
787 (declare (ignore noise))
788 (pd-error (intl:gettext "Bogus! Can't use the :printed value of an arg!")))
789 :checker #'(lambda (new-arg old-arg)
790 (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
791
792 (defun remember-printer-use (arg funstate)
793 (set-arg-temps nil nil arg :printed funstate))
794
795 ;;; ----------------------------------------------------------------
796
797 (defun compare-fields-form (val-form-1 val-form-2)
798 (flet ((listify-fields (fields)
799 (cond ((symbolp fields) fields)
800 ((every #'constantp fields) `',fields)
801 (t `(list ,@fields)))))
802 (cond ((or (symbolp val-form-1) (symbolp val-form-2))
803 `(equal ,(listify-fields val-form-1)
804 ,(listify-fields val-form-2)))
805 (t
806 `(and ,@(mapcar #'(lambda (v1 v2) `(= ,v1 ,v2))
807 val-form-1 val-form-2))))))
808
809 (defun compile-test (subj test funstate)
810 (when (and (consp test) (symbolp (car test)) (not (keywordp (car test))))
811 (setf subj (car test)
812 test (cdr test)))
813 (let ((key (if (consp test) (car test) test))
814 (body (if (consp test) (cdr test) nil)))
815 (cond ((null key)
816 nil)
817 ((eq key t)
818 t)
819 ((eq key :constant)
820 (let* ((arg (arg-or-lose subj funstate))
821 (fields (arg-fields arg))
822 (consts body))
823 (when (not (= (length fields) (length consts)))
824 (pd-error (intl:gettext "number of constants doesn't match number of fields ~
825 in: (~s :constant~{ ~s~})")
826 subj body))
827 (compare-fields-form (gen-arg-forms arg :numeric funstate)
828 consts)))
829 ((eq key :positive)
830 `(> ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric)
831 0))
832 ((eq key :negative)
833 `(< ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric)
834 0))
835 ((eq key :same-as)
836 (let ((arg1 (arg-or-lose subj funstate))
837 (arg2 (arg-or-lose (car body) funstate)))
838 (unless (and (= (length (arg-fields arg1))
839 (length (arg-fields arg2)))
840 (every #'(lambda (bs1 bs2)
841 (= (byte-size bs1) (byte-size bs2)))
842 (arg-fields arg1)
843 (arg-fields arg2)))
844 (pd-error (intl:gettext "Can't compare differently sized fields: ~
845 (~s :same-as ~s)") subj (car body)))
846 (compare-fields-form (gen-arg-forms arg1 :numeric funstate)
847 (gen-arg-forms arg2 :numeric funstate))))
848 ((eq key :or)
849 `(or ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
850 body)))
851 ((eq key :and)
852 `(and ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
853 body)))
854 ((eq key :not)
855 `(not ,(compile-test subj (car body) funstate)))
856 ((and (consp key) (null body))
857 (compile-test subj key funstate))
858 (t
859 (pd-error (intl:gettext "Bogus test-form: ~s") test)))))
860
861 ;;; ----------------------------------------------------------------
862
863 (defun find-first-field-name (tree)
864 "Returns the first non-keyword symbol in a depth-first search of TREE."
865 (cond ((null tree)
866 nil)
867 ((and (symbolp tree) (not (keywordp tree)))
868 tree)
869 ((atom tree)
870 nil)
871 ((eq (car tree) 'quote)
872 nil)
873 (t
874 (or (find-first-field-name (car tree))
875 (find-first-field-name (cdr tree))))))
876
877 (defun string-or-qsym-p (thing)
878 (or (stringp thing)
879 (and (consp thing)
880 (eq (car thing) 'quote)
881 (or (stringp (cadr thing))
882 (symbolp (cadr thing))))))
883
884 (defun strip-quote (thing)
885 (if (and (consp thing) (eq (car thing) 'quote))
886 (cadr thing)
887 thing))
888
889 (defun compile-printer-list (sources funstate)
890 (unless (null sources)
891 ;; Coalesce adjacent symbols/strings, and convert to strings if possible,
892 ;; since they require less consing to write.
893 (do ((el (car sources) (car sources))
894 (names nil (cons (strip-quote el) names)))
895 ((not (string-or-qsym-p el))
896 (when names
897 ;; concatenate adjacent strings and symbols
898 (let ((string
899 (apply #'concatenate
900 'string
901 (mapcar #'string (nreverse names)))))
902 (push (if (some #'alpha-char-p string)
903 `',(make-symbol string) ; preserve casifying output
904 string)
905 sources))))
906 (pop sources))
907 (cons (compile-printer-body (car sources) funstate)
908 (compile-printer-list (cdr sources) funstate))))
909
910 (defun compile-print (arg-name funstate &optional printer)
911 (let* ((arg (arg-or-lose arg-name funstate))
912 (printer (or printer (arg-printer arg)))
913 (printer-val (value-or-source printer))
914 (printer-src (source-form printer)))
915 (remember-printer-use arg funstate)
916 (cond ((stringp printer-val)
917 `(local-format-arg ,(arg-value-form arg funstate) ,printer-val))
918 ((vectorp printer-val)
919 `(local-princ
920 (aref ,printer-src
921 ,(arg-value-form arg funstate :numeric))))
922 ((or (functionp printer-val)
923 (and (consp printer-val) (eq (car printer-val) 'function)))
924 `(local-call-arg-printer ,(arg-value-form arg funstate)
925 ,printer-src))
926 ((or (null printer-val) (eq printer-val t))
927 `(,(if (arg-use-label arg) 'local-princ16 'local-princ)
928 ,(arg-value-form arg funstate)))
929 (t
930 (pd-error (intl:gettext "Illegal printer: ~s") printer-src)))))
931
932 (defun compile-printer-body (source funstate)
933 (cond ((null source)
934 nil)
935 ((eq source :name)
936 `(local-print-name))
937 ((eq source :tab)
938 `(local-tab-to-arg-column))
939 ((keywordp source)
940 (pd-error (intl:gettext "Unknown printer element: ~s") source))
941 ((symbolp source)
942 (compile-print source funstate))
943 ((atom source)
944 `(local-princ ',source))
945 ((eq (car source) :using)
946 (unless (or (stringp (cadr source))
947 (and (listp (cadr source))
948 (eq (caadr source) 'function)))
949 (pd-error (intl:gettext "First arg to :USING must be a string or #'function")))
950 (compile-print (caddr source) funstate
951 (cons (eval (cadr source)) (cadr source))))
952 ((eq (car source) :plus-integer)
953 ;; prints the given field proceed with a + or a -
954 (let ((form
955 (arg-value-form (arg-or-lose (cadr source) funstate)
956 funstate
957 :numeric)))
958 `(progn
959 (when (>= ,form 0)
960 (local-write-char #\+))
961 (local-princ ,form))))
962 ((eq (car source) 'quote)
963 `(local-princ ,source))
964 ((eq (car source) 'function)
965 `(local-call-global-printer ,source))
966 ((eq (car source) :cond)
967 `(cond ,@(mapcar #'(lambda (clause)
968 `(,(compile-test (find-first-field-name
969 (cdr clause))
970 (car clause)
971 funstate)
972 ,@(compile-printer-list (cdr clause)
973 funstate)))
974 (cdr source))))
975 ;; :if, :unless, and :when are replaced by :cond during preprocessing
976 (t
977 `(progn ,@(compile-printer-list source funstate)))))
978
979 ;;; ----------------------------------------------------------------
980 ;;; Note that these things are compiled byte compiled to save space.
981
982 (defun make-printer-defun (source funstate function-name)
983 (let ((printer-form (compile-printer-list source funstate))
984 (bindings (make-arg-temp-bindings funstate)))
985 `(defun ,function-name (chunk inst stream dstate)
986 (declare (type dchunk chunk)
987 (type instruction inst)
988 (type stream stream)
989 (type disassem-state dstate)
990 #+small (optimize (speed 0) (safety 0) (debug 0)))
991
992 (macrolet ((local-format-arg (arg fmt)
993 `(funcall (formatter ,fmt) stream ,arg)))
994 (flet ((local-tab-to-arg-column ()
995 (tab (dstate-argument-column dstate) stream))
996 (local-print-name ()
997 (princ (inst-print-name inst) stream))
998 (local-write-char (ch)
999 (write-char ch stream))
1000 (local-princ (thing)
1001 (princ thing stream))
1002 (local-princ16 (thing)
1003 (princ16 thing stream))
1004 (local-call-arg-printer (arg printer)
1005 (funcall printer arg stream dstate))
1006 (local-call-global-printer (fun)
1007 (funcall fun chunk inst stream dstate))
1008 (local-filtered-value (offset)
1009 (declare (type filtered-value-index offset))
1010 (aref (dstate-filtered-values dstate) offset))
1011 (local-extract (bytespec)
1012 (dchunk-extract chunk bytespec))
1013 (lookup-label (lab)
1014 (or (gethash lab (dstate-label-hash dstate))
1015 lab))
1016 (adjust-label (val adjust-fun)
1017 (funcall adjust-fun val dstate)))
1018 (declare (ignorable #'local-tab-to-arg-column
1019 #'local-print-name
1020 #'local-princ #'local-princ16
1021 #'local-write-char
1022 #'local-call-arg-printer
1023 #'local-call-global-printer
1024 #'local-extract
1025 #'local-filtered-value
1026 #'lookup-label #'adjust-label)
1027 (inline local-tab-to-arg-column
1028 local-princ local-princ16
1029 local-call-arg-printer local-call-global-printer
1030 local-filtered-value local-extract
1031 lookup-label adjust-label))
1032 (let* ,bindings
1033 ,@printer-form))))))
1034
1035 ;;; ----------------------------------------------------------------
1036
1037 (defun all-arg-refs-relevent-p (printer args)
1038 (cond ((or (null printer) (keywordp printer) (eq printer t))
1039 t)
1040 ((symbolp printer)
1041 (find printer args :key #'arg-name))
1042 ((listp printer)
1043 (every #'(lambda (x) (all-arg-refs-relevent-p x args))
1044 printer))
1045 (t t)))
1046
1047 (defun pick-printer-choice (choices args)
1048 (dolist (choice choices
1049 (pd-error (intl:gettext "No suitable choice found in ~s") choices))
1050 (when (all-arg-refs-relevent-p choice args)
1051 (return choice))))
1052
1053 (defun preprocess-chooses (printer args)
1054 (cond ((atom printer)
1055 printer)
1056 ((eq (car printer) :choose)
1057 (pick-printer-choice (cdr printer) args))
1058 (t
1059 (sharing-mapcar #'(lambda (sub) (preprocess-chooses sub args))
1060 printer))))
1061
1062 ;;; ----------------------------------------------------------------
1063
1064 (defun preprocess-test (subj form args)
1065 (multiple-value-bind (subj test)
1066 (if (and (consp form) (symbolp (car form)) (not (keywordp (car form))))
1067 (values (car form) (cdr form))
1068 (values subj form))
1069 (let ((key (if (consp test) (car test) test))
1070 (body (if (consp test) (cdr test) nil)))
1071 (case key
1072 (:constant
1073 (if (null body)
1074 ;; if no supplied constant values, just any constant is ok, just
1075 ;; see if there's some constant value in the arg.
1076 (not
1077 (null
1078 (arg-value
1079 (or (find subj args :key #'arg-name)
1080 (pd-error (intl:gettext "Unknown argument ~s") subj)))))
1081 ;; otherwise, defer to run-time
1082 form))
1083 ((:or :and :not)
1084 (sharing-cons
1085 form
1086 subj
1087 (sharing-cons
1088 test
1089 key
1090 (sharing-mapcar
1091 #'(lambda (sub-test)
1092 (preprocess-test subj sub-test args))
1093 body))))
1094 (t form)))))
1095
1096 (defun preprocess-conditionals (printer args)
1097 (if (atom printer)
1098 printer
1099 (case (car printer)
1100 (:unless
1101 (preprocess-conditionals
1102 `(:cond ((:not ,(nth 1 printer)) ,@(nthcdr 2 printer)))
1103 args))
1104 (:when
1105 (preprocess-conditionals `(:cond (,(cdr printer))) args))
1106 (:if
1107 (preprocess-conditionals
1108 `(:cond (,(nth 1 printer) ,(nth 2 printer))
1109 (t ,(nth 3 printer)))
1110 args))
1111 (:cond
1112 (sharing-cons
1113 printer
1114 :cond
1115 (sharing-mapcar
1116 #'(lambda (clause)
1117 (let ((filtered-body
1118 (sharing-mapcar
1119 #'(lambda (sub-printer)
1120 (preprocess-conditionals sub-printer args))
1121 (cdr clause))))
1122 (sharing-cons
1123 clause
1124 (preprocess-test (find-first-field-name filtered-body)
1125 (car clause)
1126 args)
1127 filtered-body)))
1128 (cdr printer))))
1129 (quote printer)
1130 (t
1131 (sharing-mapcar
1132 #'(lambda (sub-printer)
1133 (preprocess-conditionals sub-printer args))
1134 printer)))))
1135
1136 (defun preprocess-printer (printer args)
1137 "Returns a version of the disassembly-template PRINTER with compile-time
1138 tests (e.g. :constant without a value), and any :CHOOSE operators resolved
1139 properly for the args ARGS. (:CHOOSE Sub*) simply returns the first Sub in
1140 which every field reference refers to a valid arg."
1141 (preprocess-conditionals (preprocess-chooses printer args) args))
1142
1143 ;;; ----------------------------------------------------------------
1144
1145 (defstruct (cached-function (:conc-name cached-fun-))
1146 (funstate nil :type (or null funstate))
1147 (constraint nil :type list)
1148 (name nil :type (or null symbol)))
1149
1150 (defun find-cached-function (cached-funs args constraint)
1151 (dolist (cached-fun cached-funs nil)
1152 (let ((funstate (cached-fun-funstate cached-fun)))
1153 (when (and (equal constraint (cached-fun-constraint cached-fun))
1154 (or (null funstate)
1155 (funstate-compatible-p funstate args)))
1156 (return cached-fun)))))
1157
1158 (defmacro with-cached-function ((name-var funstate-var cache cache-slot
1159 args &key constraint prefix)
1160 &body defun-maker-forms)
1161 (let ((cache-var (gensym))
1162 (constraint-var (gensym)))
1163 `(let* ((,constraint-var ,constraint)
1164 (,cache-var (find-cached-function (,cache-slot ,cache)
1165 ,args ,constraint-var)))
1166 (cond (,cache-var
1167 #+nil
1168 (Format t (intl:gettext "~&; Using cached function ~s~%")
1169 (cached-fun-name ,cache-var))
1170 (values (cached-fun-name ,cache-var) nil))
1171 (t
1172 (let* ((,name-var (gensym ,prefix))
1173 (,funstate-var (make-funstate ,args))
1174 (,cache-var
1175 (make-cached-function :name ,name-var
1176 :funstate ,funstate-var
1177 :constraint ,constraint-var)))
1178 #+nil
1179 (format t (intl:gettext "~&; Making new function ~s~%")
1180 (cached-fun-name ,cache-var))
1181 (values ,name-var
1182 `(progn
1183 ,(progn ,@defun-maker-forms)
1184 (eval-when (compile eval)
1185 (push ,,cache-var
1186 (,',cache-slot ',,cache)))))))))))
1187
1188 ;;; ----------------------------------------------------------------
1189
1190 (defstruct function-cache
1191 (printers nil :type list)
1192 (labellers nil :type list)
1193 (prefilters nil :type list))
1194
1195 (defun find-printer-fun (printer-source args cache)
1196 (if (null printer-source)
1197 (values nil nil)
1198 (let ((printer-source (preprocess-printer printer-source args)))
1199 (with-cached-function
1200 (name funstate cache function-cache-printers args
1201 :constraint printer-source
1202 :prefix "PRINTER")
1203 (make-printer-defun printer-source funstate name)))))
1204
1205 (defun find-labeller-fun (args cache)
1206 (let ((labelled-fields
1207 (mapcar #'arg-name (remove-if-not #'arg-use-label args))))
1208 (if (null labelled-fields)
1209 (values nil nil)
1210 (with-cached-function
1211 (name funstate cache function-cache-labellers args
1212 :prefix "LABELLER"
1213 :constraint labelled-fields)
1214 (let ((labels-form 'labels))
1215 (dolist (arg args)
1216 (when (arg-use-label arg)
1217 (setf labels-form
1218 `(let ((labels ,labels-form)
1219 (addr
1220 ,(arg-value-form arg funstate :adjusted nil)))
1221 (if (assoc addr labels :test #'eq)
1222 labels
1223 (cons (cons addr nil) labels))))))
1224 `(defun ,name (chunk labels dstate)
1225 (declare (type list labels)
1226 (type dchunk chunk)
1227 (type disassem-state dstate)
1228 #+small
1229 (optimize (speed 0) (safety 0) (debug 0)))
1230 (flet ((local-filtered-value (offset)
1231 (declare (type filtered-value-index offset))
1232 (aref (dstate-filtered-values dstate) offset))
1233 (local-extract (bytespec)
1234 (dchunk-extract chunk bytespec))
1235 (adjust-label (val adjust-fun)
1236 (funcall adjust-fun val dstate)))
1237 (declare (ignorable #'local-filtered-value #'local-extract
1238 #'adjust-label)
1239 (inline local-filtered-value local-extract
1240 adjust-label))
1241 (let* ,(make-arg-temp-bindings funstate)
1242 ,labels-form))))))))
1243
1244 (defun find-prefilter-fun (args cache)
1245 (let ((filtered-args
1246 (mapcar #'arg-name (remove-if-not #'arg-prefilter args))))
1247 (if (null filtered-args)
1248 (values nil nil)
1249 (with-cached-function
1250 (name funstate cache function-cache-prefilters args
1251 :prefix "PREFILTER"
1252 :constraint filtered-args)
1253 (collect ((forms))
1254 (dolist (arg args)
1255 (let ((pf (arg-prefilter arg)))
1256 (when pf
1257 (forms
1258 `(setf (local-filtered-value ,(arg-position arg))
1259 ,(maybe-listify
1260 (gen-arg-forms arg :filtering funstate)))))
1261 ))
1262 `(defun ,name (chunk dstate)
1263 (declare (type dchunk chunk)
1264 (type disassem-state dstate)
1265 #+small
1266 (optimize (speed 0) (safety 0) (debug 0)))
1267 (flet (((setf local-filtered-value) (value offset)
1268 (declare (type filtered-value-index offset))
1269 (setf (aref (dstate-filtered-values dstate) offset)
1270 value))
1271 (local-filter (value filter)
1272 (funcall filter value dstate))
1273 (local-extract (bytespec)
1274 (dchunk-extract chunk bytespec)))
1275 (declare (ignorable #'local-filter #'local-extract)
1276 (inline (setf local-filtered-value)
1277 local-filter local-extract))
1278 ;; use them for side-effects only
1279 (let* ,(make-arg-temp-bindings funstate)
1280 ,@(forms)))))))))
1281
1282 ;;; ----------------------------------------------------------------
1283
1284 (defun set-arg-from-type (arg type-name table)
1285 (let ((type-arg (find type-name table :key #'arg-name)))
1286 (when (null type-arg)
1287 (pd-error (intl:gettext "Unknown argument type: ~s") type-name))
1288 (setf (arg-printer arg) (arg-printer type-arg))
1289 (setf (arg-prefilter arg) (arg-prefilter type-arg))
1290 (setf (arg-sign-extend-p arg) (arg-sign-extend-p type-arg))
1291 (setf (arg-use-label arg) (arg-use-label type-arg))))
1292
1293 (defun modify-or-add-arg (arg-name
1294 args
1295 type-table
1296 &key
1297 (value nil value-p)
1298 (type nil type-p)
1299 (prefilter nil prefilter-p)
1300 (printer nil printer-p)
1301 (sign-extend nil sign-extend-p)
1302 (use-label nil use-label-p)
1303 (field nil field-p)
1304 (fields nil fields-p)
1305 format-length)
1306 (let* ((arg-pos (position arg-name args :key #'arg-name))
1307 (arg
1308 (if (null arg-pos)
1309 (let ((arg (make-argument :name arg-name)))
1310 (if (null args)
1311 (setf args (list arg))
1312 (push arg (cdr (last args))))
1313 arg)
1314 (setf (nth arg-pos args) (copy-argument (nth arg-pos args))))))
1315 (when (and field-p (not fields-p))
1316 (setf fields (list field))
1317 (setf fields-p t))
1318 (when type-p
1319 (set-arg-from-type arg type type-table))
1320 (when value-p
1321 (setf (arg-value arg) value))
1322 (when prefilter-p
1323 (setf (arg-prefilter arg) prefilter))
1324 (when sign-extend-p
1325 (setf (arg-sign-extend-p arg) sign-extend))
1326 (when printer-p
1327 (setf (arg-printer arg) printer))
1328 (when use-label-p
1329 (setf (arg-use-label arg) use-label))
1330 (when fields-p
1331 (when (null format-length)
1332 (error
1333 (intl:gettext "~@<In arg ~s: ~3i~:_~
1334 Can't specify fields except using DEFINE-INSTRUCTION-FORMAT.~:>")
1335 arg-name))
1336 (setf (arg-fields arg)
1337 (mapcar #'(lambda (bytespec)
1338 (when (> (+ (byte-position bytespec)
1339 (byte-size bytespec))
1340 format-length)
1341 (error (intl:gettext "~@<In arg ~s: ~3i~:_~
1342 Field ~s doesn't fit in an ~
1343 instruction-format ~d bits wide.~:>")
1344 arg-name
1345 bytespec
1346 format-length))
1347 (correct-dchunk-bytespec-for-endianness
1348 bytespec
1349 format-length
1350 (c:backend-byte-order c:*target-backend*)))
1351 fields))
1352 )
1353 args))
1354
1355 ;;; ----------------------------------------------------------------
1356 ;;; Compile time info that we stash in the package of the machine backend
1357
1358 (defun format-table-name ()
1359 (intern "*DISASSEMBLER-INSTRUCTION-FORMATS*"))
1360 (defun arg-type-table-name ()
1361 (intern "*DISASSEMBLER-ARG-TYPES*"))
1362 (defun function-cache-name ()
1363 (intern "*DISASSEMBLER-CACHED-FUNCTIONS*"))
1364
1365 ;;; ----------------------------------------------------------------
1366
1367 (defparameter *arg-function-params*
1368 '((:printer . (value stream dstate))
1369 (:use-label . (value dstate))
1370 (:prefilter . (value dstate))))
1371
1372 ;;; detect things that obviously don't need wrapping, like variable-refs &
1373 ;;; #'function
1374 (defun doesnt-need-wrapping-p (form)
1375 (or (symbolp form)
1376 (and (listp form)
1377 (eq (car form) 'function)
1378 (symbolp (cadr form)))))
1379
1380 (defun make-wrapper (form arg-name funargs prefix)
1381 (if (and (listp form)
1382 (eq (car form) 'function))
1383 ;; a function def
1384 (let ((wrapper-name (symbolicate prefix "-" arg-name "-WRAPPER"))
1385 (wrapper-args nil))
1386 (dotimes (i (length funargs))
1387 (push (gensym) wrapper-args))
1388 (values `#',wrapper-name
1389 `(defun ,wrapper-name ,wrapper-args
1390 (funcall ,form ,@wrapper-args))))
1391 ;; something else
1392 (let ((wrapper-name (symbolicate "*" prefix "-" arg-name "-WRAPPER*")))
1393 (values wrapper-name `(defparameter ,wrapper-name ,form)))))
1394
1395 (defun munge-fun-refs (params evalp &optional wrap-defs-p (prefix ""))
1396 (let ((params (copy-list params)))
1397 (do ((tail params (cdr tail))
1398 (wrapper-defs nil))
1399 ((null tail)
1400 (values params (nreverse wrapper-defs)))
1401 (let ((fun-arg (assoc (car tail) *arg-function-params*)))
1402 (when fun-arg
1403 (let* ((fun-form (cadr tail))
1404 (quoted-fun-form `',fun-form))
1405 (when (and wrap-defs-p (not (doesnt-need-wrapping-p fun-form)))
1406 (multiple-value-bind (access-form wrapper-def-form)
1407 (make-wrapper fun-form (car fun-arg) (cdr fun-arg) prefix)
1408 (setf quoted-fun-form `',access-form)
1409 (push wrapper-def-form wrapper-defs)))
1410 (if evalp
1411 (setf (cadr tail)
1412 `(make-valsrc ,fun-form ,quoted-fun-form))
1413 (setf (cadr tail)
1414 fun-form))))))))
1415
1416 ;;; ----------------------------------------------------------------
1417
1418 (defun gen-preamble-form (args)
1419 "Generate a form to specify global disassembler params. See the
1420 documentation for SET-DISASSEM-PARAMS for more info."
1421 (destructuring-bind
1422 (&key instruction-alignment
1423 address-size
1424 (opcode-column-width nil opcode-column-width-p))
1425 args
1426 `(progn
1427 (eval-when (compile eval)
1428 ;; these are not in the params because they only exist at compile time
1429 (defparameter ,(format-table-name) (make-hash-table))
1430 (defparameter ,(arg-type-table-name) nil)
1431 (defparameter ,(function-cache-name) (make-function-cache)))
1432 (let ((params
1433 (or (c:backend-disassem-params c:*target-backend*)
1434 (setf (c:backend-disassem-params c:*target-backend*)
1435 (make-params :backend c::*target-backend*)))))
1436 (declare (ignorable params))
1437 ,(when instruction-alignment
1438 `(setf (params-instruction-alignment params)
1439 (bits-to-bytes ,instruction-alignment)))
1440 ,(when address-size
1441 `(setf (params-location-column-width params)
1442 (* 2 ,address-size)))
1443 ,(when opcode-column-width-p
1444 `(setf (params-opcode-column-width params) ,opcode-column-width))
1445 'disassem-params))))
1446
1447 (defun gen-clear-info-form ()
1448 `(eval-when (compile eval)
1449 (setf ,(format-table-name) nil)
1450 (setf ,(arg-type-table-name) nil)))
1451
1452 (defun update-args-form (var name-form descrip-forms evalp
1453 &optional format-length-form)
1454 `(setf ,var
1455 ,(if evalp
1456 `(modify-or-add-arg ,name-form
1457 ,var
1458 ,(arg-type-table-name)
1459 ,@(and format-length-form
1460 `(:format-length
1461 ,format-length-form))
1462 ,@descrip-forms)
1463 `(apply #'modify-or-add-arg
1464 ,name-form
1465 ,var
1466 ,(arg-type-table-name);
1467 ,@(and format-length-form
1468 `(:format-length ,format-length-form))
1469 ',descrip-forms))))
1470
1471 (defun gen-arg-type-def-form (name args &optional (evalp t))
1472 "Generate a form to define a disassembler argument type. See
1473 DEFINE-ARGUMENT-TYPE for more info."
1474 (multiple-value-bind (args wrapper-defs)
1475 (munge-fun-refs args evalp t name)
1476 `(progn
1477 ,@wrapper-defs
1478 (eval-when (compile eval)
1479 ,(update-args-form (arg-type-table-name) `',name args evalp))
1480 ',name)))
1481
1482 (defun maybe-quote (evalp form)
1483 (if (or evalp (self-evaluating-p form)) form `',form))
1484
1485 (defun maybe-quote-list (evalp list)
1486 (if evalp
1487 list
1488 (mapcar #'(lambda (el) (maybe-quote nil el)) list)))
1489
1490 (defun gen-arg-access-macro-def-form (arg args format-name)
1491 (let* ((funstate (make-funstate args))
1492 (arg-val-form (arg-value-form arg funstate :adjusted))
1493 (bindings (make-arg-temp-bindings funstate)))
1494 `(defmacro ,(symbolicate format-name "-" (arg-name arg)) (chunk dstate)
1495 `(let ((chunk ,chunk) (dstate ,dstate))
1496 (declare (ignorable chunk dstate))
1497 (flet ((local-filtered-value (offset)
1498 (declare (type filtered-value-index offset))
1499 (aref (dstate-filtered-values dstate) offset))
1500 (local-extract (bytespec)
1501 (dchunk-extract chunk bytespec)))
1502 (declare (ignorable #'local-filtered-value #'local-extract)
1503 (inline local-filtered-value local-extract))
1504 (let* ,',bindings
1505 ,',arg-val-form))))))
1506
1507 (defun gen-format-def-form (header descrips &optional (evalp t))
1508 "Generate a form to define an instruction format. See
1509 DEFINE-INSTRUCTION-FORMAT for more info."
1510 (when (atom header)
1511 (setf header (list header)))
1512 (destructuring-bind (name length &key default-printer include)
1513 header
1514 (let ((args-var (gensym))
1515 (length-var (gensym))
1516 (all-wrapper-defs nil)
1517 (arg-count 0))
1518 (collect ((arg-def-forms))
1519 (dolist (descrip descrips)
1520 (let ((name (pop descrip)))
1521 (multiple-value-bind (descrip wrapper-defs)
1522 (munge-fun-refs
1523 descrip evalp t (format nil "~:@(~a~)-~d" name arg-count))
1524 (arg-def-forms
1525 (update-args-form args-var `',name descrip evalp length-var))
1526 (setf all-wrapper-defs
1527 (nconc wrapper-defs all-wrapper-defs)))
1528 (incf arg-count)))
1529 `(progn
1530 ,@all-wrapper-defs
1531 (eval-when (compile eval)
1532 (let ((,length-var ,length)
1533 (,args-var
1534 ,(and include
1535 `(copy-list
1536 (format-args
1537 (format-or-lose ,include
1538 ,(format-table-name)))))))
1539 ,@(arg-def-forms)
1540 (setf (gethash ',name ,(format-table-name))
1541 (make-instruction-format
1542 :name ',name
1543 :length (bits-to-bytes ,length-var)
1544 :default-printer ,(maybe-quote evalp default-printer)
1545 :args ,args-var))
1546 (eval
1547 `(progn
1548 ,@(mapcar #'(lambda (arg)
1549 (when (arg-fields arg)
1550 (gen-arg-access-macro-def-form
1551 arg ,args-var ',name)))
1552 ,args-var)))
1553 )))))))
1554
1555 ;;; ----------------------------------------------------------------
1556
1557 (defun compute-mask-id (args)
1558 (let ((mask dchunk-zero)
1559 (id dchunk-zero))
1560 (dolist (arg args (values mask id))
1561 (let ((av (arg-value arg)))
1562 (when av
1563 (do ((fields (arg-fields arg) (cdr fields))
1564 (values (if (atom av) (list av) av) (cdr values)))
1565 ((null fields))
1566 (let ((field-mask (dchunk-make-mask (car fields))))
1567 (when (/= (dchunk-and mask field-mask) dchunk-zero)
1568 (pd-error (intl:gettext "Field ~s in arg ~s overlaps some other field")
1569 (car fields)
1570 (arg-name arg)))
1571 (dchunk-insertf id (car fields) (car values))
1572 (dchunk-orf mask field-mask))))))))
1573
1574 (defun install-inst-flavors (name flavors)
1575 (setf (gethash name
1576 (params-instructions
1577 (c:backend-disassem-params c:*target-backend*)))
1578 flavors))
1579
1580 (defun format-or-lose (name table)
1581 (or (gethash name table)
1582 (pd-error (intl:gettext "Unknown instruction format ~s") name)))
1583
1584 (defun filter-overrides (overrides evalp)
1585 (mapcar #'(lambda (override)
1586 (list* (car override) (cadr override)
1587 (munge-fun-refs (cddr override) evalp)))
1588 overrides))
1589
1590 (defun gen-args-def-form (overrides format-form &optional (evalp t))
1591 (let ((args-var (gensym)))
1592 `(let ((,args-var (copy-list (format-args ,format-form))))
1593 ,@(mapcar #'(lambda (override)
1594 (update-args-form args-var
1595 `',(car override)
1596 (and (cdr override)
1597 (cons :value (cdr override)))
1598 evalp))
1599 overrides)
1600 ,args-var)))
1601
1602 (defun gen-printer-def-forms-def-form (name def &optional (evalp t))
1603 (destructuring-bind (format-name (&rest field-defs)
1604 &optional (printer-form :default)
1605 &key
1606 ((:print-name print-name-form) `',name)
1607 control)
1608 def
1609 (let ((format-var (gensym))
1610 (field-defs (filter-overrides field-defs evalp)))
1611 `(let* ((*current-instruction-flavor* ',(cons name format-name))
1612 (,format-var (format-or-lose ',format-name ,(format-table-name)))
1613 (args ,(gen-args-def-form field-defs format-var evalp))
1614 (funcache ,(function-cache-name)))
1615 #+small (declare (optimize (speed 0) (safety 0) (debug 0)))
1616 (multiple-value-bind (printer-fun printer-defun)
1617 (find-printer-fun ,(if (eq printer-form :default)
1618 `(format-default-printer ,format-var)
1619 (maybe-quote evalp printer-form))
1620 args funcache)
1621 (multiple-value-bind (labeller-fun labeller-defun)
1622 (find-labeller-fun args funcache)
1623 (multiple-value-bind (prefilter-fun prefilter-defun)
1624 (find-prefilter-fun args funcache)
1625 (multiple-value-bind (mask id)
1626 (compute-mask-id args)
1627 (values
1628 `(make-instruction ',',name
1629 ',',format-name
1630 ,',print-name-form
1631 ,(format-length ,format-var)
1632 ,mask
1633 ,id
1634 ,(and printer-fun `#',printer-fun)
1635 ,(and labeller-fun `#',labeller-fun)
1636 ,(and prefilter-fun `#',prefilter-fun)
1637 ,',control)
1638 `(progn
1639 ,@(and printer-defun (list printer-defun))
1640 ,@(and labeller-defun (list labeller-defun))
1641 ,@(and prefilter-defun (list prefilter-defun))))
1642 ))))))))
1643
1644
1645 ;;; ----------------------------------------------------------------
1646 ;;; combining instructions where one specializes another
1647
1648 (defun inst-specializes-p (special general)
1649 "Returns non-NIL if the instruction SPECIAL is a more specific version of
1650 GENERAL (i.e., the same instruction, but with more constraints)."
1651 (declare (type instruction special general))
1652 (let ((smask (inst-mask special))
1653 (gmask (inst-mask general)))
1654 (and (dchunk= (inst-id general)
1655 (dchunk-and (inst-id special) gmask))
1656 (dchunk-strict-superset-p smask gmask))))
1657
1658 ;;; a bit arbitrary, but should work ok...
1659 (defun specializer-rank (inst)
1660 "Returns an integer corresponding to the specifivity of the instruction INST."
1661 (declare (type instruction inst))
1662 (* (dchunk-count-bits (inst-mask inst)) 4))
1663
1664 (defun order-specializers (insts)
1665 "Order the list of instructions INSTS with more specific (more constant
1666 bits, or same-as argument constains) ones first. Returns the ordered list."
1667 (declare (type list insts))
1668 (sort insts
1669 #'(lambda (i1 i2)
1670 (> (specializer-rank i1) (specializer-rank i2)))))
1671
1672 (defun specialization-error (insts)
1673 (error (intl:gettext "Instructions either aren't related or conflict in some way:~% ~s") insts))
1674
1675 (defun try-specializing (insts)
1676 "Given a list of instructions INSTS, Sees if one of these instructions is a
1677 more general form of all the others, in which case they are put into its
1678 specializers list, and it is returned. Otherwise an error is signaled."
1679 (declare (type list insts))
1680 (let ((masters (copy-list insts)))
1681 (dolist (possible-master insts)
1682 (dolist (possible-specializer insts)
1683 (unless (or (eq possible-specializer possible-master)
1684 (inst-specializes-p possible-specializer possible-master))
1685 (setf masters (delete possible-master masters))
1686 (return) ; exit the inner loop
1687 )))
1688 (cond ((null masters)
1689 (specialization-error insts))
1690 ((cdr masters)
1691 (error (intl:gettext "Multiple specializing masters: ~s") masters))
1692 (t
1693 (let ((master (car masters)))
1694 (setf (inst-specializers master)
1695 (order-specializers (remove master insts)))
1696 master)))))
1697
1698 ;;; ----------------------------------------------------------------
1699 ;;; choosing an instruction
1700
1701 (declaim (inline inst-matches-p choose-inst-specialization))
1702
1703 (defun inst-matches-p (inst chunk)
1704 "Returns non-NIL if all constant-bits in INST match CHUNK."
1705 (declare (type instruction inst)
1706 (type dchunk chunk))
1707 (dchunk= (dchunk-and (inst-mask inst) chunk) (inst-id inst)))
1708
1709 (defun choose-inst-specialization (inst chunk)
1710 "Given an instruction object, INST, and a bit-pattern, CHUNK, picks the
1711 most specific instruction on INST's specializer list who's constraints are
1712 met by CHUNK. If none do, then INST is returned."
1713 (declare (type instruction inst)
1714 (type dchunk chunk))
1715 (or (dolist (spec (inst-specializers inst) nil)
1716 (declare (type instruction spec))
1717 (when (inst-matches-p spec chunk)
1718 (return spec)))
1719 inst))
1720
1721 ;;; ----------------------------------------------------------------
1722 ;;; an instruction space holds all known machine instructions in a form that
1723 ;;; can be easily searched
1724
1725 (defstruct (inst-space (:conc-name ispace-) (:print-function %print-ispace))
1726 (valid-mask dchunk-zero :type dchunk) ; applies to *children*
1727 (choices nil :type list)
1728 )
1729
1730 (defun %print-ispace (ispace stream level)
1731 (declare (ignore level))
1732 (print-unreadable-object (ispace stream :type t :identity t)))
1733
1734 (defstruct (inst-space-choice (:conc-name ischoice-))
1735 (common-id dchunk-zero :type dchunk) ; applies to *parent's* mask
1736 (subspace (required-argument) :type (or inst-space instruction))
1737 )
1738
1739 ;;; ----------------------------------------------------------------
1740 ;;; searching for an instruction in instruction space
1741
1742 (defun find-inst (chunk inst-space)
1743 "Returns the instruction object within INST-SPACE corresponding to the
1744 bit-pattern CHUNK, or NIL if there isn't one."
1745 (declare (type dchunk chunk)
1746 (type (or null inst-space instruction) inst-space))
1747 (etypecase inst-space
1748 (null nil)
1749 (instruction
1750 (if (inst-matches-p inst-space chunk)
1751 (choose-inst-specialization inst-space chunk)
1752 nil))
1753 (inst-space
1754 (let* ((mask (ispace-valid-mask inst-space))
1755 (id (dchunk-and mask chunk)))
1756 (declare (type dchunk id mask))
1757 (dolist (choice (ispace-choices inst-space))
1758 (declare (type inst-space-choice choice))
1759 (when (dchunk= id (ischoice-common-id choice))
1760 (return (find-inst chunk (ischoice-subspace choice)))))))))
1761
1762 ;;; ----------------------------------------------------------------
1763 ;;; building the instruction space
1764
1765 (defun build-inst-space (insts &optional (initial-mask dchunk-one))
1766 "Returns an instruction-space object corresponding to the list of
1767 instructions INSTS. If the optional parameter INITIAL-MASK is supplied, only
1768 bits it has set are used."
1769 ;; This is done by finding any set of bits that's common to
1770 ;; all instructions, building an instruction-space node that selects on those
1771 ;; bits, and recursively handle sets of instructions with a common value for
1772 ;; these bits (which, since there should be fewer instructions than in INSTS,
1773 ;; should have some additional set of bits to select on, etc). If there
1774 ;; are no common bits, or all instructions have the same value within those
1775 ;; bits, TRY-SPECIALIZING is called, which handles the cases of many
1776 ;; variations on a single instruction.
1777 (declare (type list insts)
1778 (type dchunk initial-mask))
1779 (cond ((null insts)
1780 nil)
1781 ((null (cdr insts))
1782 (car insts))
1783 (t
1784 (let ((vmask (dchunk-copy initial-mask)))
1785 (dolist (inst insts)
1786 (dchunk-andf vmask (inst-mask inst)))
1787 (if (dchunk-zerop vmask)
1788 (try-specializing insts)
1789 (let ((buckets nil))
1790 (dolist (inst insts)
1791 (let* ((common-id (dchunk-and (inst-id inst) vmask))
1792 (bucket (assoc common-id buckets :test #'dchunk=)))
1793 (cond ((null bucket)
1794 (push (list common-id inst) buckets))
1795 (t
1796 (push inst (cdr bucket))))))
1797 (let ((submask (dchunk-clear initial-mask vmask)))
1798 (if (= (length buckets) 1)
1799 (try-specializing insts)
1800 (make-inst-space
1801 :valid-mask vmask
1802 :choices (mapcar #'(lambda (bucket)
1803 (make-inst-space-choice
1804 :subspace (build-inst-space
1805 (cdr bucket)
1806 submask)
1807 :common-id (car bucket)))
1808 buckets))))))))))
1809
1810 ;;; ----------------------------------------------------------------
1811 ;;; an inst-space printer for debugging purposes
1812
1813 (defun print-masked-binary (num mask word-size &optional (show word-size))
1814 (do ((bit (1- word-size) (1- bit)))
1815 ((< bit 0))
1816 (write-char (cond ((logbitp bit mask)
1817 (if (logbitp bit num) #\1 #\0))
1818 ((< bit show) #\x)
1819 (t #\space)))
1820 (when (and (zerop (mod bit 8))
1821 (/= bit 0))
1822 ;; Print a vertical bar separating octets to make reading
1823 ;; easier. But use a space if we haven't shown anything yet.
1824 ;; (Preserves spacing.)
1825 (write-char (if (< bit show) #\| #\space)))))
1826
1827 (defun print-inst-bits (inst)
1828 (print-masked-binary (inst-id inst)
1829 (inst-mask inst)
1830 dchunk-bits
1831 (bytes-to-bits (inst-length inst))))
1832
1833 (defun print-inst-space (inst-space &optional (indent 0))
1834 "Prints a nicely formatted version of INST-SPACE."
1835 (etypecase inst-space
1836 (null)
1837 (instruction
1838 (format t "~vt[~a(~a)~48t" indent
1839 (inst-name inst-space)
1840 (inst-format-name inst-space))
1841 (print-inst-bits inst-space)
1842 (dolist (inst (inst-specializers inst-space))
1843 (format t "~%~vt:~a~48t" indent (inst-name inst))
1844 (print-inst-bits inst))
1845 (write-char #\])
1846 (terpri))
1847 (inst-space
1848 (format t "~vt---- ~8,'0x ----~%"
1849 indent
1850 (ispace-valid-mask inst-space))
1851 (map nil
1852 #'(lambda (choice)
1853 (format t "~vt~8,'0x ==>~%"
1854 (+ 2 indent)
1855 (ischoice-common-id choice))
1856 (print-inst-space (ischoice-subspace choice)
1857 (+ 4 indent)))
1858 (ispace-choices inst-space)))))
1859
1860 (defun print-backend-inst-space (&optional (backend c:*target-backend*))
1861 "Print the inst space for the specified backend"
1862 (let ((ext:*gc-verbose* nil))
1863 (print-inst-space (get-inst-space (c:backend-disassem-params backend)))))
1864
1865 ;;;; ----------------------------------------------------------------
1866 ;;;; the actual disassembly part
1867 ;;;; ----------------------------------------------------------------
1868
1869 ;;; Code object layout:
1870 ;;; header-word
1871 ;;; code-size (starting from first inst, in words)
1872 ;;; entry-points (points to first function header)
1873 ;;; debug-info
1874 ;;; trace-table-offset (starting from first inst, in bytes)
1875 ;;; constant1
1876 ;;; constant2
1877 ;;; ...
1878 ;;; <padding to dual-word boundry>
1879 ;;; start of instructions
1880 ;;; ...
1881 ;;; function-headers and lra's buried in here randomly
1882 ;;; ...
1883 ;;; start of trace-table
1884 ;;; <padding to dual-word boundry>
1885 ;;;
1886 ;;; Function header layout (dual word aligned):
1887 ;;; header-word
1888 ;;; self pointer
1889 ;;; next pointer (next function header)
1890 ;;; name
1891 ;;; arglist
1892 ;;; type
1893 ;;;
1894 ;;; LRA layout (dual word aligned):
1895 ;;; header-word
1896
1897 (declaim (inline words-to-bytes bytes-to-words))
1898
1899 (eval-when (eval load compile) ; used in a defconstant
1900 (defun words-to-bytes (num)
1901 "Converts a word-offset NUM to a byte-offset."
1902 (declare (type offset num))
1903 (ash num vm:word-shift))
1904 )
1905
1906 (defun bytes-to-words (num)
1907 "Converts a byte-offset NUM to a word-offset."
1908 (declare (type offset num))
1909 (ash num (- vm:word-shift)))
1910
1911 (defconstant lra-size (words-to-bytes 1))
1912
1913 ;;; ----------------------------------------------------------------
1914 ;;;
1915
1916 (defstruct offs-hook
1917 (offset 0 :type offset)
1918 (function (required-argument) :type function)
1919 (before-address nil :type (member t nil)))
1920
1921 (defstruct (segment (:conc-name seg-)
1922 (:print-function %print-segment)
1923 (:constructor %make-segment))
1924 (sap-maker (required-argument) :type (function () system:system-area-pointer))
1925 (length 0 :type length)
1926 (virtual-location 0 :type address)
1927 (storage-info nil :type (or null storage-info))
1928 (code nil :type (or null kernel:code-component))
1929 (hooks nil :type list)
1930 )
1931
1932 (defun %print-segment (seg stream level)
1933 (declare (ignore level))
1934 (print-unreadable-object (seg stream :type t)
1935 (let ((addr (system:sap-int (funcall (seg-sap-maker seg)))))
1936 (format stream "#x~x[~d]~:[ (#x~x)~;~*~]~@[ in ~s~]"
1937 addr
1938 (seg-length seg)
1939 (= (seg-virtual-location seg) addr)
1940 (seg-virtual-location seg)
1941 (seg-code seg)))))
1942
1943 ;;; ----------------------------------------------------------------
1944
1945 ;;; All state during disassembly. We store some seemingly redundant
1946 ;;; information so that we can allow garbage collect during disassembly and
1947 ;;; not get tripped up by a code block being moved...
1948 (defstruct (disassem-state (:conc-name dstate-)
1949 (:print-function %print-dstate)
1950 (:constructor %make-dstate))
1951 (cur-offs 0 :type offset) ; offset of current pos in segment
1952 (next-offs 0 :type offset) ; offset of next position
1953
1954 (segment-sap (required-argument) :type system:system-area-pointer)
1955 ; a sap pointing to our segment
1956 (segment nil :type (or null segment)) ; the current segment
1957
1958 (alignment vm:word-bytes :type alignment) ; what to align to in most cases
1959 (byte-order :little-endian
1960 :type (member :big-endian :little-endian))
1961
1962 (properties nil :type list) ; for user code to hang stuff off of
1963 (filtered-values (make-array max-filtered-value-index)
1964 :type filtered-value-vector)
1965
1966 (addr-print-len nil :type ; used for prettifying printing
1967 (or null (integer 0 20)))
1968 (argument-column 0 :type column)
1969 (output-state :beginning ; to make output look nicer
1970 :type (member :beginning
1971 :block-boundary
1972 nil))
1973
1974 (labels nil :type list) ; alist of (address . label-number)
1975 (label-hash (make-hash-table) ; same thing in a different form
1976 :type hash-table)
1977
1978 (fun-hooks nil :type list) ; list of function
1979
1980 ;; these next two are popped as they are used
1981 (cur-labels nil :type list) ; alist of (address . label-number)
1982 (cur-offs-hooks nil :type list) ; list of offs-hook
1983
1984 (notes nil :type list) ; for the current location
1985
1986 (current-valid-locations nil ; currently active source variables
1987 :type (or null (vector bit)))
1988
1989 (params (required-argument) :type params) ; a handy pointer ...
1990 )
1991
1992 (defun %print-dstate (dstate stream level)
1993 (declare (ignore level))
1994 (print-unreadable-object (dstate stream :type t)
1995 (format stream "+~d~@[ in ~s~]" (dstate-cur-offs dstate) (dstate-segment dstate))))
1996
1997 (defmacro dstate-get-prop (dstate name)
1998 "Get the value of the property called NAME in DSTATE. Also setf'able."
1999 `(getf (dstate-properties ,dstate) ,name))
2000
2001 (defun dstate-cur-addr (dstate)
2002 "Returns the absolute address of the current instruction in DSTATE."
2003 (the address (+ (seg-virtual-location (dstate-segment dstate))
2004 (dstate-cur-offs dstate))))
2005
2006 (defun dstate-next-addr (dstate)
2007 "Returns the absolute address of the next instruction in DSTATE."
2008 (the address (+ (seg-virtual-location (dstate-segment dstate))
2009 (dstate-next-offs dstate))))
2010
2011 ;;; ----------------------------------------------------------------
2012 ;;; function ops
2013
2014 (defun fun-self (fun)
2015 (declare (type compiled-function fun))
2016 (kernel:%function-self fun))
2017
2018 (defun fun-code (fun)
2019 (declare (type compiled-function fun))
2020 (kernel:function-code-header (fun-self fun)))
2021
2022 (defun fun-next (fun)
2023 (declare (type compiled-function fun))
2024 (kernel:%function-next fun))
2025
2026 (defun fun-address (function)
2027 (declare (type compiled-function function))
2028 (ecase (kernel:get-type function)
2029 (#.vm:function-header-type
2030 (- (kernel:get-lisp-obj-address function) vm:function-pointer-type))
2031 (#.vm:closure-header-type
2032 (fun-address (kernel:%closure-function function)))
2033 (#.vm:funcallable-instance-header-type
2034 (fun-address (kernel:funcallable-instance-function function)))))
2035
2036 (defun fun-insts-offset (function)
2037 "Offset of FUNCTION from the start of its code-component's instruction area."
2038 (declare (type compiled-function function))
2039 (- (fun-address function)
2040 (system:sap-int (kernel:code-instructions (fun-code function)))))
2041
2042 (defun fun-offset (function)
2043 "Offset of FUNCTION from the start of its code-component."
2044 (declare (type compiled-function function))
2045 (words-to-bytes (kernel:get-closure-length function)))
2046
2047 ;;; ----------------------------------------------------------------
2048 ;;; Operations on code-components (which hold the instructions for
2049 ;;; one or more functions).
2050
2051 (defun code-inst-area-length (code-component)
2052 "Returns the length of the instruction area in CODE-COMPONENT."
2053 (declare (type kernel:code-component code-component))
2054 (kernel:code-header-ref code-component vm:code-trace-table-offset-slot))
2055
2056 (defun code-inst-area-address (code-component)
2057 "Returns the address of the instruction area in CODE-COMPONENT."
2058 (declare (type kernel:code-component code-component))
2059 (system:sap-int (kernel:code-instructions code-component)))
2060
2061 (defun code-first-function (code-component)
2062 "Returns the first function in CODE-COMPONENT."
2063 (declare (type kernel:code-component code-component))
2064 (kernel:code-header-ref code-component vm:code-trace-table-offset-slot))
2065
2066 (defun segment-offs-to-code-offs (offset segment)
2067 (system:without-gcing
2068 (let* ((seg-base-addr (system:sap-int (funcall (seg-sap-maker segment))))
2069 (code-addr
2070 (logandc1 vm:lowtag-mask
2071 (kernel:get-lisp-obj-address (seg-code segment))))
2072 (addr (+ offset seg-base-addr)))
2073 (declare (type address seg-base-addr code-addr addr))
2074 (- addr code-addr))))
2075
2076 (defun code-offs-to-segment-offs (offset segment)
2077 (system:without-gcing
2078 (let* ((seg-base-addr (system:sap-int (funcall (seg-sap-maker segment))))
2079 (code-addr
2080 (logandc1 vm:lowtag-mask
2081 (kernel:get-lisp-obj-address (seg-code segment))))
2082 (addr (+ offset code-addr)))
2083 (declare (type address seg-base-addr code-addr addr))
2084 (- addr seg-base-addr))))
2085
2086 (defun code-insts-offs-to-segment-offs (offset segment)
2087 (system:without-gcing
2088 (let* ((seg-base-addr (system:sap-int (funcall (seg-sap-maker segment))))
2089 (code-insts-addr
2090 (system:sap-int (kernel:code-instructions (seg-code segment))))
2091 (addr (+ offset code-insts-addr)))
2092 (declare (type address seg-base-addr code-insts-addr addr))
2093 (- addr seg-base-addr))))
2094
2095 ;;; ----------------------------------------------------------------
2096
2097 (defun lra-hook (chunk stream dstate)
2098 (declare (ignore stream))
2099 (declare (type dchunk chunk)
2100 (ignore chunk)
2101 (type disassem-state dstate))
2102 (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate))
2103 (dstate-cur-offs dstate))
2104 (* 2 vm:word-bytes))
2105 ;; check type
2106 (= (system:sap-ref-8 (dstate-segment-sap dstate)
2107 (if (eq (dstate-byte-order dstate)
2108 :little-endian)
2109 (dstate-cur-offs dstate)
2110 (+ (dstate-cur-offs dstate)
2111 (1- lra-size))))
2112 vm:return-pc-header-type))
2113 (note (format nil (intl:gettext "Possible ~A header word") '.lra) dstate))
2114 nil)
2115
2116 (defun fun-header-hook (stream dstate)
2117 "Print the function-header (entry-point) pseudo-instruction at the current
2118 location in DSTATE to STREAM."
2119 (declare (type (or null stream) stream)
2120 (type disassem-state dstate))
2121 (unless (null stream)
2122 (let* ((seg (dstate-segment dstate))
2123 (code (seg-code seg))
2124 (woffs
2125 (bytes-to-words
2126 (segment-offs-to-code-offs (dstate-cur-offs dstate) seg)))
2127 (name
2128 (kernel:code-header-ref code (+ woffs vm:function-name-slot)))
2129 (args
2130 (kernel:code-header-ref code (+ woffs vm:function-arglist-slot)))
2131 (type
2132 (kernel:code-header-ref code (+ woffs vm:function-type-slot))))
2133 (format stream ".~a ~s~:a" 'entry name args)
2134 (note #'(lambda (stream)
2135 (format stream "~:s" type)) ; use format to print NIL as ()
2136 dstate)))
2137 (incf (dstate-next-offs dstate)
2138 (words-to-bytes vm:function-code-offset)))
2139
2140 ;;; ----------------------------------------------------------------
2141
2142 (defun alignment-hook (chunk stream dstate)
2143 (declare (type dchunk chunk)
2144 (ignore chunk)
2145 (type (or null stream) stream)
2146 (type disassem-state dstate))
2147 (let ((location
2148 (+ (seg-virtual-location (dstate-segment dstate))
2149 (dstate-cur-offs dstate)))
2150 (alignment (dstate-alignment dstate)))
2151 (unless (aligned-p location alignment)
2152 (when stream
2153 (format stream "~a~vt~d~%" '.align
2154 (dstate-argument-column dstate)
2155 alignment))
2156 (incf(dstate-next-offs dstate)
2157 (- (align location alignment) location)))
2158 nil))
2159
2160 (defun rewind-current-segment (dstate segment)
2161 (declare (type disassem-state dstate)
2162 (type segment segment))
2163 (setf (dstate-segment dstate) segment)
2164 (setf (dstate-cur-offs-hooks dstate)
2165 (stable-sort (nreverse (copy-list (seg-hooks segment)))
2166 #'(lambda (oh1 oh2)
2167 (or (< (offs-hook-offset oh1) (offs-hook-offset oh2))
2168 (and (= (offs-hook-offset oh1)
2169 (offs-hook-offset oh2))
2170 (offs-hook-before-address oh1)
2171 (not (offs-hook-before-address oh2)))))))
2172 (setf (dstate-cur-offs dstate) 0)
2173 (setf (dstate-cur-labels dstate) (dstate-labels dstate)))
2174
2175 (defun do-offs-hooks (before-address stream dstate)
2176 (declare (type (or null stream) stream)
2177 (type disassem-state dstate))
2178 (let ((cur-offs (dstate-cur-offs dstate)))
2179 (setf (dstate-next-offs dstate) cur-offs)
2180 (loop
2181 (let ((next-hook (car (dstate-cur-offs-hooks dstate))))
2182 (when (null next-hook)
2183 (return))
2184 (let ((hook-offs (offs-hook-offset next-hook)))
2185 (when (or (> hook-offs cur-offs)
2186 (and (= hook-offs cur-offs)
2187 before-address
2188 (not (offs-hook-before-address next-hook))))
2189 (return))
2190 (unless (< hook-offs cur-offs)
2191 (funcall (offs-hook-function next-hook) stream dstate))
2192 (pop (dstate-cur-offs-hooks dstate))
2193 (unless (= (dstate-next-offs dstate) cur-offs)
2194 (return)))))))
2195
2196 (defun do-fun-hooks (chunk stream dstate)
2197 (let ((hooks (dstate-fun-hooks dstate))
2198 (cur-offs (dstate-cur-offs dstate)))
2199 (setf (dstate-next-offs dstate) cur-offs)
2200 (dolist (hook hooks nil)
2201 (let ((prefix-p (funcall hook chunk stream dstate)))
2202 (unless (= (dstate-next-offs dstate) cur-offs)
2203 (return prefix-p))))))
2204
2205 (defun handle-bogus-instruction (stream dstate)
2206 (let ((alignment (dstate-alignment dstate)))
2207 (unless (null stream)
2208 (multiple-value-bind (words bytes)
2209 (truncate alignment vm:word-bytes)
2210 (when (> words 0)
2211 (print-words words stream dstate))
2212 (when (> bytes 0)
2213 (print-bytes bytes stream dstate))))
2214 (incf (dstate-next-offs dstate) alignment)))
2215
2216 (defun map-segment-instructions (function segment dstate &optional stream)
2217 "Iterate through the instructions in SEGMENT, calling FUNCTION
2218 for each instruction, with arguments of CHUNK, STREAM, and DSTATE."
2219 (declare (type function function)
2220 (type segment segment)
2221 (type disassem-state dstate)
2222 (type (or null stream) stream))
2223
2224 (let ((ispace (get-inst-space (dstate-params dstate)))
2225 (prefix-p nil)) ; just processed a prefix inst
2226
2227 (rewind-current-segment dstate segment)
2228
2229 (loop
2230 (when (>= (dstate-cur-offs dstate)
2231 (seg-length (dstate-segment dstate)))
2232 ;; done!
2233 (return))
2234
2235 (setf (dstate-next-offs dstate) (dstate-cur-offs dstate))
2236
2237 (do-offs-hooks t stream dstate)
2238 (unless (or prefix-p (null stream))
2239 (print-current-address stream dstate))
2240 (do-offs-hooks nil stream dstate)
2241
2242 (unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
2243 (system:without-gcing
2244 (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment)))
2245
2246 (let ((chunk
2247 (sap-ref-dchunk (dstate-segment-sap dstate)
2248 (dstate-cur-offs dstate)
2249 (dstate-byte-order dstate))))
2250 (let ((fun-prefix-p (do-fun-hooks chunk stream dstate)))
2251 (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
2252 (setf prefix-p fun-prefix-p)
2253 (let ((inst (find-inst chunk ispace)))
2254 (cond ((null inst)
2255 (handle-bogus-instruction stream dstate))
2256 (t
2257 (setf (dstate-next-offs dstate)
2258 (+ (dstate-cur-offs dstate)
2259 (inst-length inst)))
2260
2261 (let ((prefilter (inst-prefilter inst))
2262 (control (inst-control inst)))
2263 (when prefilter
2264 (funcall prefilter chunk dstate))
2265
2266 (funcall function chunk inst)
2267
2268 (setf prefix-p (null (inst-printer inst)))
2269
2270 (when control
2271 (funcall control chunk inst stream dstate))))))
2272 )))))
2273
2274 (setf (dstate-cur-offs dstate) (dstate-next-offs dstate))
2275
2276 (unless (null stream)
2277 (unless prefix-p
2278 (print-notes-and-newline stream dstate))
2279 (setf (dstate-output-state dstate) nil)))))
2280
2281 ;;; ----------------------------------------------------------------
2282
2283 (defun add-segment-labels (segment dstate)
2284 "Make an initial non-printing disassembly pass through DSTATE, noting any
2285 addresses that are referenced by instructions in this segment."
2286 ;; add labels at the beginning with a label-number of nil; we'll notice
2287 ;; later and fill them in (and sort them)
2288 (declare (type disassem-state dstate))
2289 (let ((labels (dstate-labels dstate)))
2290 (map-segment-instructions
2291 #'(lambda (chunk inst)
2292 (declare (type dchunk chunk) (type instruction inst))
2293 (let ((labeller (inst-labeller inst)))
2294 (when labeller
2295 (setf labels (funcall labeller chunk labels dstate)))))
2296 segment
2297 dstate)
2298 (setf (dstate-labels dstate) labels)
2299 ;; erase any notes that got there by accident
2300 (setf (dstate-notes dstate) nil)))
2301
2302 (defun number-labels (dstate)
2303 "If any labels in DSTATE have been added since the last call to this
2304 function, give them label-numbers, enter them in the hash-table, and make
2305 sure the label list is in sorted order."
2306 (let ((labels (dstate-labels dstate)))
2307 (when (and labels (null (cdar labels)))
2308 ;; at least one label left un-numbered
2309 (setf labels (sort labels #'< :key #'car))
2310 (let ((max -1)
2311 (label-hash (dstate-label-hash dstate)))
2312 (dolist (label labels)
2313 (when (not (null (cdr label)))
2314 (setf max (max max (cdr label)))))
2315 (dolist (label labels)
2316 (when (null (cdr label))
2317 (incf max)
2318 (setf (cdr label) max)
2319 (setf (gethash (car label) label-hash)
2320 (format nil "L~d" max)))))
2321 (setf (dstate-labels dstate) labels))))
2322
2323 ;;; ----------------------------------------------------------------
2324
2325 (defun get-inst-space (params)
2326 "Get the instruction-space from PARAMS, creating it if necessary."
2327 (declare (type params params))
2328 (let ((ispace (params-inst-space params)))
2329 (when (null ispace)
2330 (let ((insts nil))
2331 (maphash #'(lambda (name inst-flavs)
2332 (declare (ignore name))
2333 (dolist (flav inst-flavs)
2334 (push flav insts)))
2335 (params-instructions params))
2336 (setf ispace (build-inst-space insts)))
2337 (setf (params-inst-space params) ispace))
2338 ispace))
2339
2340 ;;; ----------------------------------------------------------------
2341 ;;; add global hooks
2342
2343 (defun add-offs-hook (segment addr hook)
2344 (let ((entry (cons addr hook)))
2345 (if (null (seg-hooks segment))
2346 (setf (seg-hooks segment) (list entry))
2347 (push entry (cdr (last (seg-hooks segment)))))))
2348
2349 (defun add-offs-note-hook (segment addr note)
2350 (add-offs-hook segment
2351 addr
2352 #'(lambda (stream dstate)
2353 (declare (type (or null stream) stream)
2354 (type disassem-state dstate))
2355 (when stream
2356 (note note dstate)))))
2357
2358 (defun add-offs-comment-hook (segment addr comment)
2359 (add-offs-hook segment
2360 addr
2361 #'(lambda (stream dstate)
2362 (declare (type (or null stream) stream)
2363 (ignore dstate))
2364 (when stream
2365 (write-string ";;; " stream)
2366 (etypecase comment
2367 (string
2368 (write-string comment stream))
2369 (function
2370 (funcall comment stream)))
2371 (terpri stream)))))
2372
2373 (defun add-fun-hook (dstate function)
2374 (push function (dstate-fun-hooks dstate)))
2375
2376 ;;; ----------------------------------------------------------------
2377
2378 (defun set-location-printing-range (dstate from length)
2379 (setf (dstate-addr-print-len dstate)
2380 ;; 4 bits per hex digit
2381 (ceiling (integer-length (logxor from (+ from length))) 4)))
2382
2383 (defun print-current-address (stream dstate)
2384 "Print the current address in DSTATE to STREAM, plus any labels that
2385 correspond to it, and leave the cursor in the instruction column."
2386 (declare (type stream stream)
2387 (type disassem-state dstate))
2388 (let* ((location
2389 (+ (seg-virtual-location (dstate-segment dstate))
2390 (dstate-cur-offs dstate)))
2391 (location-column-width
2392 (params-location-column-width (dstate-params dstate)))
2393 (plen (dstate-addr-print-len dstate)))
2394
2395 (when (null plen)
2396 (setf plen location-column-width)
2397 (set-location-printing-range dstate
2398 (seg-virtual-location (dstate-segment dstate))
2399 (seg-length (dstate-segment dstate))))
2400 (when (eq (dstate-output-state dstate) :beginning)
2401 (setf plen location-column-width))
2402
2403 (fresh-line stream)
2404
2405 ;; print the location
2406 ;; [this is equivalent to (format stream "~v,'0x:" plen printed-value), but
2407 ;; usually avoids any consing]
2408 (tab0 (- location-column-width plen) stream)
2409 (let* ((printed-bits (* 4 plen))
2410 (printed-value (ldb (byte printed-bits 0) location))
2411 (leading-zeros
2412 (truncate (- printed-bits (integer-length printed-value)) 4)))
2413 (dotimes (i leading-zeros)
2414 (write-char #\0 stream))
2415 (unless (zerop printed-value)
2416 (write printed-value :stream stream :base 16 :radix nil))
2417 (write-char #\: stream))
2418
2419 ;; print any labels
2420 (loop
2421 (let* ((next-label (car (dstate-cur-labels dstate)))
2422 (label-location (car next-label)))
2423 (when (or (null label-location) (> label-location location))
2424 (return))
2425 (unless (< label-location location)
2426 (format stream " L~d:" (cdr next-label)))
2427 (pop (dstate-cur-labels dstate))))
2428
2429 ;; move to the instruction column
2430 (tab0 (+ location-column-width 1 label-column-width) stream)
2431 ))
2432
2433 ;;; ----------------------------------------------------------------
2434
2435 (defmacro with-print-restrictions (&rest body)
2436 `(let ((*print-pretty* t)
2437 (*print-lines* 2)
2438 (*print-length* 5)
2439 (*print-level* 5))
2440 ,@body))
2441
2442 (defun print-notes-and-newline (stream dstate)
2443 "Print a newline to STREAM, inserting any pending notes in DSTATE as
2444 end-of-line comments. If there is more than one note, a separate line
2445 will be used for each one."
2446 (declare (type stream stream)
2447 (type disassem-state dstate))
2448 (with-print-restrictions
2449 (dolist (note (dstate-notes dstate))
2450 (format stream "~vt" *note-column*)
2451 (pprint-logical-block (stream nil :per-line-prefix "; ")
2452 (etypecase note
2453 (string
2454 (write-string note stream))
2455 (function
2456 (funcall note stream))))
2457 (terpri stream))
2458 (fresh-line stream)
2459 (setf (dstate-notes dstate) nil)))
2460
2461 (defun print-bytes (num stream dstate)
2462 "Disassemble NUM bytes to STREAM as simple `BYTE' instructions"
2463 (declare (type offset num)
2464 (type stream stream)
2465 (type disassem-state dstate))
2466 (format stream "~a~vt" 'BYTE (dstate-argument-column dstate))
2467 (let ((sap (dstate-segment-sap dstate))
2468 (start-offs (dstate-cur-offs dstate)))
2469 (dotimes (offs num)
2470 (unless (zerop offs)
2471 (write-string ", " stream))
2472 (format stream "#x~2,'0x" (system:sap-ref-8 sap (+ offs start-offs))))))
2473
2474 (defun print-words (num stream dstate)
2475 "Disassemble NUM machine-words to STREAM as simple `WORD' instructions"
2476 (declare (type offset num)
2477 (type stream stream)
2478 (type disassem-state dstate))
2479 (format stream "~a~vt" 'WORD (dstate-argument-column dstate))
2480 (let ((sap (dstate-segment-sap dstate))
2481 (start-offs (dstate-cur-offs dstate))
2482 (byte-order (dstate-byte-order dstate)))
2483 (dotimes (word-offs num)
2484 (unless (zerop word-offs)
2485 (write-string ", " stream))
2486 (let ((word 0) (bit-shift 0))
2487 (dotimes (byte-offs vm:word-bytes)
2488 (let ((byte
2489 (system:sap-ref-8
2490 sap
2491 (+ start-offs (* word-offs vm:word-bytes) byte-offs))))
2492 (setf word
2493 (if (eq byte-order :big-endian)
2494 (+ (ash word vm:byte-bits) byte)
2495 (+ word (ash byte bit-shift))))
2496 (incf bit-shift vm:byte-bits)))
2497 (format stream "#x~v,'0x" (ash vm:word-bits -2) word)))))
2498
2499 ;;; ----------------------------------------------------------------
2500
2501 (defvar *default-dstate-hooks* (list #'lra-hook))
2502
2503 (defun make-dstate (params &optional (fun-hooks *default-dstate-hooks*))
2504 "Make a disassembler-state object."
2505 (declare (type params params))
2506 (let ((sap
2507 ;; a random address
2508 (system:vector-sap (coerce #() '(vector (unsigned-byte 8)))))
2509 (alignment
2510 (params-instruction-alignment params))
2511 (arg-column
2512 (+ (or *opcode-column-width* (params-opcode-column-width params) 0)
2513 (params-location-column-width params)
2514 1
2515 label-column-width)))
2516
2517 (when (> alignment 1)
2518 (push #'alignment-hook fun-hooks))
2519
2520 (%make-dstate :segment-sap sap
2521 :params params
2522 :fun-hooks fun-hooks
2523 :argument-column arg-column
2524 :alignment alignment
2525 :byte-order (c:backend-byte-order (params-backend params)))))
2526
2527 (defun add-fun-header-hooks (segment)
2528 (declare (type segment segment))
2529 (do ((fun (kernel:code-header-ref (seg-code segment)
2530 vm:code-entry-points-slot)
2531 (fun-next fun))
2532 (length (seg-length segment)))
2533 ((null fun))
2534