0.8.12.16:
[sbcl.git] / src / compiler / x86-64 / insts.lisp
1 ;;;; that part of the description of the x86 instruction set (for
2 ;;;; 80386 and above) which can live on the cross-compilation host
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
12
13 (in-package "SB!VM")
14 ;;; FIXME: SB!DISASSEM: prefixes are used so widely in this file that
15 ;;; I wonder whether the separation of the disassembler from the
16 ;;; virtual machine is valid or adds value.
17
18 ;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS.
19 (setf sb!disassem:*disassem-inst-alignment-bytes* 1)
20
21 ;;; this type is used mostly in disassembly and represents legacy
22 ;;; registers only.  r8-15 are handled separately
23 (deftype reg () '(unsigned-byte 3))
24
25 ;;; default word size for the chip: if the operand size !=:dword
26 ;;; we need to output #x66 (or REX) prefix
27 (def!constant +default-operand-size+ :dword)
28 \f
29 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
30
31 (defun offset-next (value dstate)
32   (declare (type integer value)
33            (type sb!disassem:disassem-state dstate))
34   (+ (sb!disassem:dstate-next-addr dstate) value))
35
36 (defparameter *default-address-size*
37   ;; Again, this is the chip default, not the SBCL backend preference
38   ;; which must be set with prefixes if it's different.  It's :dword;
39   ;; this is not negotiable
40   :dword)
41
42 (defparameter *byte-reg-names*
43   #(al cl dl bl ah ch dh bh))
44 (defparameter *word-reg-names*
45   #(ax cx dx bx sp bp si di))
46 (defparameter *dword-reg-names*
47   #(eax ecx edx ebx esp ebp esi edi))
48 (defparameter *qword-reg-names*
49   #(rax rcx rdx rbx rsp rbp rsi rdi r8 r9 r10 r11 r12 r13 r14 r15))
50
51 (defun print-reg-with-width (value width stream dstate)
52   (declare (ignore dstate))
53   (princ (aref (ecase width
54                  (:byte *byte-reg-names*)
55                  (:word *word-reg-names*)
56                  (:dword *dword-reg-names*)
57                  (:qword *qword-reg-names*))
58                value)
59          stream)
60   ;; XXX plus should do some source-var notes
61   )
62
63 (defun print-reg (value stream dstate)
64   (declare (type reg value)
65            (type stream stream)
66            (type sb!disassem:disassem-state dstate))
67   (print-reg-with-width value
68                         (sb!disassem:dstate-get-prop dstate 'width)
69                         stream
70                         dstate))
71
72 (defun print-word-reg (value stream dstate)
73   (declare (type reg value)
74            (type stream stream)
75            (type sb!disassem:disassem-state dstate))
76   (print-reg-with-width value
77                         (or (sb!disassem:dstate-get-prop dstate 'word-width)
78                             +default-operand-size+)
79                         stream
80                         dstate))
81
82 (defun print-byte-reg (value stream dstate)
83   (declare (type reg value)
84            (type stream stream)
85            (type sb!disassem:disassem-state dstate))
86   (print-reg-with-width value :byte stream dstate))
87
88 (defun print-addr-reg (value stream dstate)
89   (declare (type reg value)
90            (type stream stream)
91            (type sb!disassem:disassem-state dstate))
92   (print-reg-with-width value *default-address-size* stream dstate))
93
94 (defun print-reg/mem (value stream dstate)
95   (declare (type (or list reg) value)
96            (type stream stream)
97            (type sb!disassem:disassem-state dstate))
98   (if (typep value 'reg)
99       (print-reg value stream dstate)
100       (print-mem-access value stream nil dstate)))
101
102 ;; Same as print-reg/mem, but prints an explicit size indicator for
103 ;; memory references.
104 (defun print-sized-reg/mem (value stream dstate)
105   (declare (type (or list reg) value)
106            (type stream stream)
107            (type sb!disassem:disassem-state dstate))
108   (if (typep value 'reg)
109       (print-reg value stream dstate)
110       (print-mem-access value stream t dstate)))
111
112 (defun print-byte-reg/mem (value stream dstate)
113   (declare (type (or list reg) value)
114            (type stream stream)
115            (type sb!disassem:disassem-state dstate))
116   (if (typep value 'reg)
117       (print-byte-reg value stream dstate)
118       (print-mem-access value stream t dstate)))
119
120 (defun print-word-reg/mem (value stream dstate)
121   (declare (type (or list reg) value)
122            (type stream stream)
123            (type sb!disassem:disassem-state dstate))
124   (if (typep value 'reg)
125       (print-word-reg value stream dstate)
126       (print-mem-access value stream nil dstate)))
127
128 (defun print-label (value stream dstate)
129   (declare (ignore dstate))
130   (sb!disassem:princ16 value stream))
131
132 ;;; Returns either an integer, meaning a register, or a list of
133 ;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
134 ;;; may be missing or nil to indicate that it's not used or has the
135 ;;; obvious default value (e.g., 1 for the index-scale).
136 (defun prefilter-reg/mem (value dstate)
137   (declare (type list value)
138            (type sb!disassem:disassem-state dstate))
139   (let ((mod (car value))
140         (r/m (cadr value)))
141     (declare (type (unsigned-byte 2) mod)
142              (type (unsigned-byte 3) r/m))
143     (cond ((= mod #b11)
144            ;; registers
145            r/m)
146           ((= r/m #b100)
147            ;; sib byte
148            (let ((sib (sb!disassem:read-suffix 8 dstate)))
149              (declare (type (unsigned-byte 8) sib))
150              (let ((base-reg (ldb (byte 3 0) sib))
151                    (index-reg (ldb (byte 3 3) sib))
152                    (index-scale (ldb (byte 2 6) sib)))
153                (declare (type (unsigned-byte 3) base-reg index-reg)
154                         (type (unsigned-byte 2) index-scale))
155                (let* ((offset
156                        (case mod
157                          (#b00
158                           (if (= base-reg #b101)
159                               (sb!disassem:read-signed-suffix 32 dstate)
160                               nil))
161                          (#b01
162                           (sb!disassem:read-signed-suffix 8 dstate))
163                          (#b10
164                           (sb!disassem:read-signed-suffix 32 dstate)))))
165                  (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
166                        offset
167                        (if (= index-reg #b100) nil index-reg)
168                        (ash 1 index-scale))))))
169           ((and (= mod #b00) (= r/m #b101))
170            (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
171           ((= mod #b00)
172            (list r/m))
173           ((= mod #b01)
174            (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
175           (t                            ; (= mod #b10)
176            (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
177
178
179 ;;; This is a sort of bogus prefilter that just stores the info globally for
180 ;;; other people to use; it probably never gets printed.
181 (defun prefilter-width (value dstate)
182   (setf (sb!disassem:dstate-get-prop dstate 'width)
183         (if (zerop value)
184             :byte
185             (let ((word-width
186                    ;; set by a prefix instruction
187                    (or (sb!disassem:dstate-get-prop dstate 'word-width)
188                        +default-operand-size+)))
189               (when (not (eql word-width +default-operand-size+))
190                 ;; Reset it.
191                 (setf (sb!disassem:dstate-get-prop dstate 'word-width)
192                       +default-operand-size+))
193               word-width))))
194
195 (defun read-address (value dstate)
196   (declare (ignore value))              ; always nil anyway
197   (sb!disassem:read-suffix (width-bits *default-address-size*) dstate))
198
199 (defun width-bits (width)
200   (ecase width
201     (:byte 8)
202     (:word 16)
203     (:dword 32)
204     (:float 32)
205     (:double 64)))
206
207 ) ; EVAL-WHEN
208 \f
209 ;;;; disassembler argument types
210
211 (sb!disassem:define-arg-type displacement
212   :sign-extend t
213   :use-label #'offset-next
214   :printer (lambda (value stream dstate)
215              (sb!disassem:maybe-note-assembler-routine value nil dstate)
216              (print-label value stream dstate)))
217
218 (sb!disassem:define-arg-type accum
219   :printer (lambda (value stream dstate)
220              (declare (ignore value)
221                       (type stream stream)
222                       (type sb!disassem:disassem-state dstate))
223              (print-reg 0 stream dstate)))
224
225 (sb!disassem:define-arg-type word-accum
226   :printer (lambda (value stream dstate)
227              (declare (ignore value)
228                       (type stream stream)
229                       (type sb!disassem:disassem-state dstate))
230              (print-word-reg 0 stream dstate)))
231
232 (sb!disassem:define-arg-type reg
233   :printer #'print-reg)
234
235 (sb!disassem:define-arg-type addr-reg
236   :printer #'print-addr-reg)
237
238 (sb!disassem:define-arg-type word-reg
239   :printer #'print-word-reg)
240
241 (sb!disassem:define-arg-type imm-addr
242   :prefilter #'read-address
243   :printer #'print-label)
244
245 (sb!disassem:define-arg-type imm-data
246   :prefilter (lambda (value dstate)
247                (declare (ignore value)) ; always nil anyway
248                (sb!disassem:read-suffix
249                 (width-bits (sb!disassem:dstate-get-prop dstate 'width))
250                 dstate)))
251
252 (sb!disassem:define-arg-type signed-imm-data
253   :prefilter (lambda (value dstate)
254                (declare (ignore value)) ; always nil anyway
255                (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
256                  (sb!disassem:read-signed-suffix (width-bits width) dstate))))
257
258 (sb!disassem:define-arg-type signed-imm-byte
259   :prefilter (lambda (value dstate)
260                (declare (ignore value)) ; always nil anyway
261                (sb!disassem:read-signed-suffix 8 dstate)))
262
263 (sb!disassem:define-arg-type signed-imm-dword
264   :prefilter (lambda (value dstate)
265                (declare (ignore value)) ; always nil anyway
266                (sb!disassem:read-signed-suffix 32 dstate)))
267
268 (sb!disassem:define-arg-type imm-word
269   :prefilter (lambda (value dstate)
270                (declare (ignore value)) ; always nil anyway
271                (let ((width
272                       (or (sb!disassem:dstate-get-prop dstate 'word-width)
273                           +default-operand-size+)))
274                  (sb!disassem:read-suffix (width-bits width) dstate))))
275
276 ;;; needed for the ret imm16 instruction
277 (sb!disassem:define-arg-type imm-word-16
278   :prefilter (lambda (value dstate)
279                (declare (ignore value)) ; always nil anyway
280                (sb!disassem:read-suffix 16 dstate)))
281
282 (sb!disassem:define-arg-type reg/mem
283   :prefilter #'prefilter-reg/mem
284   :printer #'print-reg/mem)
285 (sb!disassem:define-arg-type sized-reg/mem
286   ;; Same as reg/mem, but prints an explicit size indicator for
287   ;; memory references.
288   :prefilter #'prefilter-reg/mem
289   :printer #'print-sized-reg/mem)
290 (sb!disassem:define-arg-type byte-reg/mem
291   :prefilter #'prefilter-reg/mem
292   :printer #'print-byte-reg/mem)
293 (sb!disassem:define-arg-type word-reg/mem
294   :prefilter #'prefilter-reg/mem
295   :printer #'print-word-reg/mem)
296
297 ;;; added by jrd
298 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
299 (defun print-fp-reg (value stream dstate)
300   (declare (ignore dstate))
301   (format stream "FR~D" value))
302 (defun prefilter-fp-reg (value dstate)
303   ;; just return it
304   (declare (ignore dstate))
305   value)
306 ) ; EVAL-WHEN
307 (sb!disassem:define-arg-type fp-reg
308                              :prefilter #'prefilter-fp-reg
309                              :printer #'print-fp-reg)
310
311 (sb!disassem:define-arg-type width
312   :prefilter #'prefilter-width
313   :printer (lambda (value stream dstate)
314              (if;; (zerop value)
315                  (or (null value)
316                      (and (numberp value) (zerop value))) ; zzz jrd
317                  (princ 'b stream)
318                  (let ((word-width
319                         ;; set by a prefix instruction
320                         (or (sb!disassem:dstate-get-prop dstate 'word-width)
321                             +default-operand-size+)))
322                    (princ (schar (symbol-name word-width) 0) stream)))))
323
324 (eval-when (:compile-toplevel :load-toplevel :execute)
325 (defparameter *conditions*
326   '((:o . 0)
327     (:no . 1)
328     (:b . 2) (:nae . 2) (:c . 2)
329     (:nb . 3) (:ae . 3) (:nc . 3)
330     (:eq . 4) (:e . 4) (:z . 4)
331     (:ne . 5) (:nz . 5)
332     (:be . 6) (:na . 6)
333     (:nbe . 7) (:a . 7)
334     (:s . 8)
335     (:ns . 9)
336     (:p . 10) (:pe . 10)
337     (:np . 11) (:po . 11)
338     (:l . 12) (:nge . 12)
339     (:nl . 13) (:ge . 13)
340     (:le . 14) (:ng . 14)
341     (:nle . 15) (:g . 15)))
342 (defparameter *condition-name-vec*
343   (let ((vec (make-array 16 :initial-element nil)))
344     (dolist (cond *conditions*)
345       (when (null (aref vec (cdr cond)))
346         (setf (aref vec (cdr cond)) (car cond))))
347     vec))
348 ) ; EVAL-WHEN
349
350 ;;; Set assembler parameters. (In CMU CL, this was done with
351 ;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
352 (eval-when (:compile-toplevel :load-toplevel :execute)
353   (setf sb!assem:*assem-scheduler-p* nil))
354
355 (sb!disassem:define-arg-type condition-code
356   :printer *condition-name-vec*)
357
358 (defun conditional-opcode (condition)
359   (cdr (assoc condition *conditions* :test #'eq)))
360 \f
361 ;;;; disassembler instruction formats
362
363 (eval-when (:compile-toplevel :execute)
364   (defun swap-if (direction field1 separator field2)
365     `(:if (,direction :constant 0)
366           (,field1 ,separator ,field2)
367           (,field2 ,separator ,field1))))
368
369 (sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
370   (op    :field (byte 8 0))
371   ;; optional fields
372   (accum :type 'accum)
373   (imm))
374
375 (sb!disassem:define-instruction-format (simple 8)
376   (op    :field (byte 7 1))
377   (width :field (byte 1 0) :type 'width)
378   ;; optional fields
379   (accum :type 'accum)
380   (imm))
381
382 ;;; Same as simple, but with direction bit
383 (sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
384   (op :field (byte 6 2))
385   (dir :field (byte 1 1)))
386
387 ;;; Same as simple, but with the immediate value occurring by default,
388 ;;; and with an appropiate printer.
389 (sb!disassem:define-instruction-format (accum-imm 8
390                                      :include 'simple
391                                      :default-printer '(:name
392                                                         :tab accum ", " imm))
393   (imm :type 'imm-data))
394
395 (sb!disassem:define-instruction-format (reg-no-width 8
396                                      :default-printer '(:name :tab reg))
397   (op    :field (byte 5 3))
398   (reg   :field (byte 3 0) :type 'word-reg)
399   ;; optional fields
400   (accum :type 'word-accum)
401   (imm))
402
403 ;;; adds a width field to reg-no-width
404 (sb!disassem:define-instruction-format (reg 8
405                                         :default-printer '(:name :tab reg))
406   (op    :field (byte 4 4))
407   (width :field (byte 1 3) :type 'width)
408   (reg   :field (byte 3 0) :type 'reg)
409   ;; optional fields
410   (accum :type 'accum)
411   (imm)
412   )
413
414 ;;; Same as reg, but with direction bit
415 (sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
416   (op  :field (byte 3 5))
417   (dir :field (byte 1 4)))
418
419 (sb!disassem:define-instruction-format (two-bytes 16
420                                         :default-printer '(:name))
421   (op :fields (list (byte 8 0) (byte 8 8))))
422
423 (sb!disassem:define-instruction-format (reg-reg/mem 16
424                                         :default-printer
425                                         `(:name :tab reg ", " reg/mem))
426   (op      :field (byte 7 1))
427   (width   :field (byte 1 0)    :type 'width)
428   (reg/mem :fields (list (byte 2 14) (byte 3 8))
429                                 :type 'reg/mem)
430   (reg     :field (byte 3 11)   :type 'reg)
431   ;; optional fields
432   (imm))
433
434 ;;; same as reg-reg/mem, but with direction bit
435 (sb!disassem:define-instruction-format (reg-reg/mem-dir 16
436                                         :include 'reg-reg/mem
437                                         :default-printer
438                                         `(:name
439                                           :tab
440                                           ,(swap-if 'dir 'reg/mem ", " 'reg)))
441   (op  :field (byte 6 2))
442   (dir :field (byte 1 1)))
443
444 ;;; Same as reg-rem/mem, but uses the reg field as a second op code.
445 (sb!disassem:define-instruction-format (reg/mem 16
446                                         :default-printer '(:name :tab reg/mem))
447   (op      :fields (list (byte 7 1) (byte 3 11)))
448   (width   :field (byte 1 0)    :type 'width)
449   (reg/mem :fields (list (byte 2 14) (byte 3 8))
450                                 :type 'sized-reg/mem)
451   ;; optional fields
452   (imm))
453
454 ;;; Same as reg/mem, but with the immediate value occurring by default,
455 ;;; and with an appropiate printer.
456 (sb!disassem:define-instruction-format (reg/mem-imm 16
457                                         :include 'reg/mem
458                                         :default-printer
459                                         '(:name :tab reg/mem ", " imm))
460   (reg/mem :type 'sized-reg/mem)
461   (imm     :type 'imm-data))
462
463 ;;; Same as reg/mem, but with using the accumulator in the default printer
464 (sb!disassem:define-instruction-format
465     (accum-reg/mem 16
466      :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
467   (reg/mem :type 'reg/mem)              ; don't need a size
468   (accum :type 'accum))
469
470 ;;; Same as reg-reg/mem, but with a prefix of #b00001111
471 (sb!disassem:define-instruction-format (ext-reg-reg/mem 24
472                                         :default-printer
473                                         `(:name :tab reg ", " reg/mem))
474   (prefix  :field (byte 8 0)    :value #b00001111)
475   (op      :field (byte 7 9))
476   (width   :field (byte 1 8)    :type 'width)
477   (reg/mem :fields (list (byte 2 22) (byte 3 16))
478                                 :type 'reg/mem)
479   (reg     :field (byte 3 19)   :type 'reg)
480   ;; optional fields
481   (imm))
482
483 ;;; reg-no-width with #x0f prefix
484 (sb!disassem:define-instruction-format (ext-reg-no-width 16
485                                         :default-printer '(:name :tab reg))
486   (prefix  :field (byte 8 0)    :value #b00001111)
487   (op    :field (byte 5 11))
488   (reg   :field (byte 3 8) :type 'word-reg))
489
490 ;;; Same as reg/mem, but with a prefix of #b00001111
491 (sb!disassem:define-instruction-format (ext-reg/mem 24
492                                         :default-printer '(:name :tab reg/mem))
493   (prefix  :field (byte 8 0)    :value #b00001111)
494   (op      :fields (list (byte 7 9) (byte 3 19)))
495   (width   :field (byte 1 8)    :type 'width)
496   (reg/mem :fields (list (byte 2 22) (byte 3 16))
497                                 :type 'sized-reg/mem)
498   ;; optional fields
499   (imm))
500
501 (sb!disassem:define-instruction-format (ext-reg/mem-imm 24
502                                         :include 'ext-reg/mem
503                                         :default-printer
504                                         '(:name :tab reg/mem ", " imm))
505   (imm :type 'imm-data))
506 \f
507 ;;;; This section was added by jrd, for fp instructions.
508
509 ;;; regular fp inst to/from registers/memory
510 (sb!disassem:define-instruction-format (floating-point 16
511                                         :default-printer
512                                         `(:name :tab reg/mem))
513   (prefix :field (byte 5 3) :value #b11011)
514   (op     :fields (list (byte 3 0) (byte 3 11)))
515   (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
516
517 ;;; fp insn to/from fp reg
518 (sb!disassem:define-instruction-format (floating-point-fp 16
519                                         :default-printer `(:name :tab fp-reg))
520   (prefix :field (byte 5 3) :value #b11011)
521   (suffix :field (byte 2 14) :value #b11)
522   (op     :fields (list (byte 3 0) (byte 3 11)))
523   (fp-reg :field (byte 3 8) :type 'fp-reg))
524
525 ;;; fp insn to/from fp reg, with the reversed source/destination flag.
526 (sb!disassem:define-instruction-format
527  (floating-point-fp-d 16
528    :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
529   (prefix :field (byte 5 3) :value #b11011)
530   (suffix :field (byte 2 14) :value #b11)
531   (op     :fields (list (byte 2 0) (byte 3 11)))
532   (d      :field (byte 1 2))
533   (fp-reg :field (byte 3 8) :type 'fp-reg))
534
535
536 ;;; (added by (?) pfw)
537 ;;; fp no operand isns
538 (sb!disassem:define-instruction-format (floating-point-no 16
539                                       :default-printer '(:name))
540   (prefix :field (byte 8  0) :value #b11011001)
541   (suffix :field (byte 3 13) :value #b111)
542   (op     :field (byte 5  8)))
543
544 (sb!disassem:define-instruction-format (floating-point-3 16
545                                       :default-printer '(:name))
546   (prefix :field (byte 5 3) :value #b11011)
547   (suffix :field (byte 2 14) :value #b11)
548   (op     :fields (list (byte 3 0) (byte 6 8))))
549
550 (sb!disassem:define-instruction-format (floating-point-5 16
551                                       :default-printer '(:name))
552   (prefix :field (byte 8  0) :value #b11011011)
553   (suffix :field (byte 3 13) :value #b111)
554   (op     :field (byte 5  8)))
555
556 (sb!disassem:define-instruction-format (floating-point-st 16
557                                       :default-printer '(:name))
558   (prefix :field (byte 8  0) :value #b11011111)
559   (suffix :field (byte 3 13) :value #b111)
560   (op     :field (byte 5  8)))
561
562 (sb!disassem:define-instruction-format (string-op 8
563                                      :include 'simple
564                                      :default-printer '(:name width)))
565
566 (sb!disassem:define-instruction-format (short-cond-jump 16)
567   (op    :field (byte 4 4))
568   (cc    :field (byte 4 0) :type 'condition-code)
569   (label :field (byte 8 8) :type 'displacement))
570
571 (sb!disassem:define-instruction-format (short-jump 16
572                                      :default-printer '(:name :tab label))
573   (const :field (byte 4 4) :value #b1110)
574   (op    :field (byte 4 0))
575   (label :field (byte 8 8) :type 'displacement))
576
577 (sb!disassem:define-instruction-format (near-cond-jump 16)
578   (op    :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
579   (cc    :field (byte 4 8) :type 'condition-code)
580   ;; The disassembler currently doesn't let you have an instruction > 32 bits
581   ;; long, so we fake it by using a prefilter to read the offset.
582   (label :type 'displacement
583          :prefilter (lambda (value dstate)
584                       (declare (ignore value)) ; always nil anyway
585                       (sb!disassem:read-signed-suffix 32 dstate))))
586
587 (sb!disassem:define-instruction-format (near-jump 8
588                                      :default-printer '(:name :tab label))
589   (op    :field (byte 8 0))
590   ;; The disassembler currently doesn't let you have an instruction > 32 bits
591   ;; long, so we fake it by using a prefilter to read the address.
592   (label :type 'displacement
593          :prefilter (lambda (value dstate)
594                       (declare (ignore value)) ; always nil anyway
595                       (sb!disassem:read-signed-suffix 32 dstate))))
596
597
598 (sb!disassem:define-instruction-format (cond-set 24
599                                      :default-printer '('set cc :tab reg/mem))
600   (prefix :field (byte 8 0) :value #b00001111)
601   (op    :field (byte 4 12) :value #b1001)
602   (cc    :field (byte 4 8) :type 'condition-code)
603   (reg/mem :fields (list (byte 2 22) (byte 3 16))
604            :type 'byte-reg/mem)
605   (reg     :field (byte 3 19)   :value #b000))
606
607 (sb!disassem:define-instruction-format (cond-move 24
608                                      :default-printer
609                                         '('cmov cc :tab reg ", " reg/mem))
610   (prefix  :field (byte 8 0)    :value #b00001111)
611   (op      :field (byte 4 12)   :value #b0100)
612   (cc      :field (byte 4 8)    :type 'condition-code)
613   (reg/mem :fields (list (byte 2 22) (byte 3 16))
614                                 :type 'reg/mem)
615   (reg     :field (byte 3 19)   :type 'reg))
616
617 (sb!disassem:define-instruction-format (enter-format 32
618                                      :default-printer '(:name
619                                                         :tab disp
620                                                         (:unless (:constant 0)
621                                                           ", " level)))
622   (op :field (byte 8 0))
623   (disp :field (byte 16 8))
624   (level :field (byte 8 24)))
625
626 ;;; Single byte instruction with an immediate byte argument.
627 (sb!disassem:define-instruction-format (byte-imm 16
628                                      :default-printer '(:name :tab code))
629  (op :field (byte 8 0))
630  (code :field (byte 8 8)))
631 \f
632 ;;;; primitive emitters
633
634 (define-bitfield-emitter emit-word 16
635   (byte 16 0))
636
637 (define-bitfield-emitter emit-dword 32
638   (byte 32 0))
639
640 (define-bitfield-emitter emit-qword 64
641   (byte 64 0))
642
643 (define-bitfield-emitter emit-byte-with-reg 8
644   (byte 5 3) (byte 3 0))
645
646 (define-bitfield-emitter emit-mod-reg-r/m-byte 8
647   (byte 2 6) (byte 3 3) (byte 3 0))
648
649 (define-bitfield-emitter emit-sib-byte 8
650   (byte 2 6) (byte 3 3) (byte 3 0))
651
652 (define-bitfield-emitter emit-rex-byte 8
653   (byte 4 4) (byte 1 3) (byte 1 2) (byte 1 1) (byte 1 0))
654
655
656 \f
657 ;;;; fixup emitters
658
659 (defun emit-absolute-fixup (segment fixup &optional quad-p)
660   (note-fixup segment (if quad-p :absolute64 :absolute) fixup)
661   (let ((offset (fixup-offset fixup)))
662     (if (label-p offset)
663         (emit-back-patch segment
664                          (if quad-p 8 4)
665                          (lambda (segment posn)
666                            (declare (ignore posn))
667                            (let ((val  (- (+ (component-header-length)
668                                              (or (label-position offset)
669                                                  0))
670                                           other-pointer-lowtag)))
671                              (if quad-p
672                                  (emit-qword segment val )
673                                  (emit-dword segment val )))))
674         (if quad-p
675             (emit-qword segment (or offset 0))
676             (emit-dword segment (or offset 0))))))
677
678 (defun emit-relative-fixup (segment fixup)
679   (note-fixup segment :relative fixup)
680   (emit-dword segment (or (fixup-offset fixup) 0)))
681 \f
682 ;;;; the effective-address (ea) structure
683
684 (defun reg-tn-encoding (tn)
685   (declare (type tn tn))
686   (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
687   ;; ea only has space for three bits of register number: regs r8
688   ;; and up are selected by a REX prefix byte which caller is responsible
689   ;; for having emitted where necessary already
690   (let ((offset (mod (tn-offset tn) 16)))
691     (logior (ash (logand offset 1) 2)
692             (ash offset -1))))
693
694 (defstruct (ea (:constructor make-ea (size &key base index scale disp))
695                (:copier nil))
696   ;; note that we can represent an EA qith a QWORD size, but EMIT-EA
697   ;; can't actually emit it on its own: caller also needs to emit REX
698   ;; prefix
699   (size nil :type (member :byte :word :dword :qword))
700   (base nil :type (or tn null))
701   (index nil :type (or tn null))
702   (scale 1 :type (member 1 2 4 8))
703   (disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup)))
704 (def!method print-object ((ea ea) stream)
705   (cond ((or *print-escape* *print-readably*)
706          (print-unreadable-object (ea stream :type t)
707            (format stream
708                    "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
709                    (ea-size ea)
710                    (ea-base ea)
711                    (ea-index ea)
712                    (let ((scale (ea-scale ea)))
713                      (if (= scale 1) nil scale))
714                    (ea-disp ea))))
715         (t
716          (format stream "~A PTR [" (symbol-name (ea-size ea)))
717          (when (ea-base ea)
718            (write-string (sb!c::location-print-name (ea-base ea)) stream)
719            (when (ea-index ea)
720              (write-string "+" stream)))
721          (when (ea-index ea)
722            (write-string (sb!c::location-print-name (ea-index ea)) stream))
723          (unless (= (ea-scale ea) 1)
724            (format stream "*~A" (ea-scale ea)))
725          (typecase (ea-disp ea)
726            (null)
727            (integer
728             (format stream "~@D" (ea-disp ea)))
729            (t
730             (format stream "+~A" (ea-disp ea))))
731          (write-char #\] stream))))
732
733 (defun emit-ea (segment thing reg &optional allow-constants)
734   (etypecase thing
735     (tn
736      ;; this would be eleganter if we had a function that would create
737      ;; an ea given a tn
738      (ecase (sb-name (sc-sb (tn-sc thing)))
739        (registers
740         (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
741        (stack
742         ;; Convert stack tns into an index off RBP.
743         (let ((disp (- (* (1+ (tn-offset thing)) n-word-bytes))))
744           (cond ((< -128 disp 127)
745                  (emit-mod-reg-r/m-byte segment #b01 reg #b101)
746                  (emit-byte segment disp))
747                 (t
748                  (emit-mod-reg-r/m-byte segment #b10 reg #b101)
749                  (emit-dword segment disp)))))
750        (constant
751         (unless allow-constants
752           (error
753            "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
754         (emit-mod-reg-r/m-byte segment #b00 reg #b100)
755         (emit-sib-byte segment 1 4 5)   ;no base, no index
756         (emit-absolute-fixup segment
757                              (make-fixup nil
758                                          :code-object
759                                          (- (* (tn-offset thing) n-word-bytes)
760                                             other-pointer-lowtag))))))
761     (ea
762      (let* ((base (ea-base thing))
763             (index (ea-index thing))
764             (scale (ea-scale thing))
765             (disp (ea-disp thing))
766             (mod (cond ((or (null base)
767                             (and (eql disp 0)
768                                  (not (= (reg-tn-encoding base) #b101))))
769                         #b00)
770                        ((and (fixnump disp) (<= -128 disp 127))
771                         #b01)
772                        (t
773                         #b10)))
774             (r/m (cond (index #b100)
775                        ((null base) #b101)
776                        (t (reg-tn-encoding base)))))
777        (when (and (= mod 0) (= r/m #b101))
778          ;; this is rip-relative in amd64, so we'll use a sib instead
779          (setf r/m #b100 scale 1))
780        (emit-mod-reg-r/m-byte segment mod reg r/m)
781        (when (= r/m #b100)
782          (let ((ss (1- (integer-length scale)))
783                (index (if (null index)
784                           #b100
785                           (let ((index (reg-tn-encoding index)))
786                             (if (= index #b100)
787                                 (error "can't index off of ESP")
788                                 index))))
789                (base (if (null base)
790                          #b101
791                          (reg-tn-encoding base))))
792            (emit-sib-byte segment ss index base)))
793        (cond ((= mod #b01)
794               (emit-byte segment disp))
795              ((or (= mod #b10) (null base))
796               (if (fixup-p disp)
797                   (emit-absolute-fixup segment disp)
798                   (emit-dword segment disp))))))
799     (fixup
800      (emit-mod-reg-r/m-byte segment #b00 reg #b100)
801      (emit-sib-byte segment 0 #b100 #b101)
802      (emit-absolute-fixup segment thing))))
803
804 (defun fp-reg-tn-p (thing)
805   (and (tn-p thing)
806        (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
807
808 ;;; like the above, but for fp-instructions--jrd
809 (defun emit-fp-op (segment thing op)
810   (if (fp-reg-tn-p thing)
811       (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
812                                                  (byte 3 0)
813                                                  #b11000000)))
814     (emit-ea segment thing op)))
815
816 (defun byte-reg-p (thing)
817   (and (tn-p thing)
818        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
819        (member (sc-name (tn-sc thing)) *byte-sc-names*)
820        t))
821
822 (defun byte-ea-p (thing)
823   (typecase thing
824     (ea (eq (ea-size thing) :byte))
825     (tn
826      (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
827     (t nil)))
828
829 (defun word-reg-p (thing)
830   (and (tn-p thing)
831        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
832        (member (sc-name (tn-sc thing)) *word-sc-names*)
833        t))
834
835 (defun word-ea-p (thing)
836   (typecase thing
837     (ea (eq (ea-size thing) :word))
838     (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
839     (t nil)))
840
841 (defun dword-reg-p (thing)
842   (and (tn-p thing)
843        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
844        (member (sc-name (tn-sc thing)) *dword-sc-names*)
845        t))
846
847 (defun dword-ea-p (thing)
848   (typecase thing
849     (ea (eq (ea-size thing) :dword))
850     (tn
851      (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
852     (t nil)))
853
854 (defun qword-reg-p (thing)
855   (and (tn-p thing)
856        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
857        (member (sc-name (tn-sc thing)) *qword-sc-names*)
858        t))
859
860 (defun qword-ea-p (thing)
861   (typecase thing
862     (ea (eq (ea-size thing) :qword))
863     (tn
864      (and (member (sc-name (tn-sc thing)) *qword-sc-names*) t))
865     (t nil)))
866
867
868 (defun register-p (thing)
869   (and (tn-p thing)
870        (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
871
872 (defun accumulator-p (thing)
873   (and (register-p thing)
874        (= (tn-offset thing) 0)))
875 \f
876 ;;;; utilities
877
878 (def!constant +operand-size-prefix-byte+ #b01100110)
879
880 (defun maybe-emit-operand-size-prefix (segment size)
881   (unless (or (eq size :byte) 
882               (eq size :qword)          ; REX prefix handles this
883               (eq size +default-operand-size+))
884     (emit-byte segment +operand-size-prefix-byte+)))
885
886 (defun maybe-emit-rex-prefix (segment operand-size r x b)
887   (labels ((if-hi (r)        ;; offset of r8 is 16
888              (if (and r (> (tn-offset r) 15)) 1 0)))
889     (let ((rex-w (if (eq operand-size :qword) 1 0))
890           (rex-r (if-hi r))
891           (rex-x (if-hi x))
892           (rex-b (if-hi b)))
893       (when (not (zerop (logior rex-w rex-r rex-x rex-b)))
894         (emit-rex-byte segment #b0100 rex-w rex-r rex-x rex-b)))))
895
896 (defun maybe-emit-rex-for-ea (segment ea reg)
897   (let ((ea-p (ea-p ea)))               ;emit-ea can also be called with a tn
898     (maybe-emit-rex-prefix segment (operand-size ea) reg 
899                            (and ea-p (ea-index ea))
900                            (cond (ea-p (ea-base ea))
901                                  ((and (tn-p ea)
902                                        (eql (sb-name (sc-sb (tn-sc ea))) 
903                                             'registers))
904                                   ea)
905                                  (t nil)))))
906
907 (defun operand-size (thing)
908   (typecase thing
909     (tn
910      ;; FIXME: might as well be COND instead of having to use #. readmacro
911      ;; to hack up the code
912      (case (sc-name (tn-sc thing))
913        (#.*qword-sc-names*
914         :qword)
915        (#.*dword-sc-names*
916         :dword)
917        (#.*word-sc-names*
918         :word)
919        (#.*byte-sc-names*
920         :byte)
921        ;; added by jrd: float-registers is a separate size (?)
922        (#.*float-sc-names*
923         :float)
924        (#.*double-sc-names*
925         :double)
926        (t
927         (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
928     (ea
929      (ea-size thing))
930     (t
931      nil)))
932
933 (defun matching-operand-size (dst src)
934   (let ((dst-size (operand-size dst))
935         (src-size (operand-size src)))
936     (if dst-size
937         (if src-size
938             (if (eq dst-size src-size)
939                 dst-size
940                 (error "size mismatch: ~S is a ~S and ~S is a ~S."
941                        dst dst-size src src-size))
942             dst-size)
943         (if src-size
944             src-size
945             (error "can't tell the size of either ~S or ~S" dst src)))))
946
947 (defun emit-sized-immediate (segment size value &optional quad-p)
948   (ecase size
949     (:byte
950      (emit-byte segment value))
951     (:word
952      (emit-word segment value))
953     ((:dword :qword)
954      ;; except in a very few cases (MOV instructions A1,A3,B8) we expect
955      ;; dword data bytes even when 64 bit work is being done.  So, mostly
956      ;; we treat quad constants as dwords.
957      (if (and quad-p (eq size :qword))
958          (emit-qword segment value)
959          (emit-dword segment value)))))
960 \f
961 ;;;; general data transfer
962
963 (define-instruction mov (segment dst src)
964   ;; immediate to register
965   (:printer reg ((op #b1011) (imm nil :type 'imm-data))
966             '(:name :tab reg ", " imm))
967   ;; absolute mem to/from accumulator
968   (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
969             `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
970   ;; register to/from register/memory
971   (:printer reg-reg/mem-dir ((op #b100010)))
972   ;; immediate to register/memory
973   (:printer reg/mem-imm ((op '(#b1100011 #b000))))
974
975   (:emitter
976    (let ((size (matching-operand-size dst src)))
977      (maybe-emit-operand-size-prefix segment size)
978      (cond ((register-p dst)
979             (cond ((integerp src)
980                    (maybe-emit-rex-prefix segment size nil nil dst)
981                    (emit-byte-with-reg segment
982                                        (if (eq size :byte)
983                                            #b10110
984                                            #b10111)
985                                        (reg-tn-encoding dst))
986                    (emit-sized-immediate segment size src (eq size :qword)))
987                   ((and (fixup-p src) (accumulator-p dst))
988                    (maybe-emit-rex-prefix segment (operand-size src)
989                                           nil nil nil)
990                    (emit-byte segment
991                               (if (eq size :byte)
992                                   #b10100000
993                                   #b10100001))
994                    (emit-absolute-fixup segment src (eq size :qword)))
995                   (t
996                    (maybe-emit-rex-for-ea segment src dst)
997                    (emit-byte segment
998                               (if (eq size :byte)
999                                   #b10001010
1000                                   #b10001011))
1001                    (emit-ea segment src (reg-tn-encoding dst) t))))
1002            ((and (fixup-p dst) (accumulator-p src))
1003             (maybe-emit-rex-prefix segment size nil nil nil)
1004             (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
1005             (emit-absolute-fixup segment dst (eq size :qword)))
1006            ((integerp src)
1007             ;; C7 only deals with 32 bit immediates even if register is 
1008             ;; 64 bit: only b8-bf use 64 bit immediates
1009             (maybe-emit-rex-for-ea segment dst nil)
1010             (cond ((typep src '(or (signed-byte 32) (unsigned-byte 32)))
1011                    (emit-byte segment
1012                               (if (eq size :byte) #b11000110 #b11000111))
1013                    (emit-ea segment dst #b000)
1014                    (emit-sized-immediate segment 
1015                                          (case size (:qword :dword) (t size))
1016                                          src))
1017                   (t
1018                    (aver nil))))
1019            ((register-p src)
1020             (maybe-emit-rex-for-ea segment dst src)
1021             (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
1022             (emit-ea segment dst (reg-tn-encoding src)))
1023            ((fixup-p src)
1024             (maybe-emit-rex-for-ea segment dst nil)
1025             (emit-byte segment #b11000111)
1026             (emit-ea segment dst #b000)
1027             (emit-absolute-fixup segment src))
1028            (t
1029             (error "bogus arguments to MOV: ~S ~S" dst src))))))
1030
1031 (defun emit-move-with-extension (segment dst src signed-p)
1032   (aver (register-p dst))
1033   (let ((dst-size (operand-size dst))
1034         (src-size (operand-size src))
1035         (opcode (if signed-p  #b10111110 #b10110110)))
1036     (ecase dst-size
1037       (:word
1038        (aver (eq src-size :byte))
1039        (maybe-emit-operand-size-prefix segment :word)
1040        (emit-byte segment #b00001111)
1041        (emit-byte segment opcode)
1042        (emit-ea segment src (reg-tn-encoding dst)))
1043       ((:dword :qword)
1044        (ecase src-size
1045          (:byte
1046           (maybe-emit-operand-size-prefix segment :dword)
1047           (maybe-emit-rex-for-ea segment src dst)
1048           (emit-byte segment #b00001111)
1049           (emit-byte segment opcode)
1050           (emit-ea segment src (reg-tn-encoding dst)))
1051          (:word
1052           (maybe-emit-rex-for-ea segment src dst)
1053           (emit-byte segment #b00001111)
1054           (emit-byte segment (logior opcode 1))
1055           (emit-ea segment src (reg-tn-encoding dst)))
1056          (:dword
1057           (aver (eq dst-size :qword))
1058           ;; dst is in reg, src is in modrm
1059           (let ((ea-p (ea-p src)))
1060             (maybe-emit-rex-prefix segment (if signed-p :qword :dword) dst 
1061                                    (and ea-p (ea-index src))
1062                                    (cond (ea-p (ea-base src))
1063                                          ((tn-p src) src)
1064                                          (t nil)))
1065             (emit-byte segment #x63)    ;movsxd 
1066             ;;(emit-byte segment opcode)
1067             (emit-ea segment src (reg-tn-encoding dst)))))))))
1068
1069 (define-instruction movsx (segment dst src)
1070   (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg)))
1071   (:emitter (emit-move-with-extension segment dst src :signed)))
1072
1073 (define-instruction movzx (segment dst src)
1074   (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg)))
1075   (:emitter (emit-move-with-extension segment dst src nil)))
1076
1077 (define-instruction movsxd (segment dst src)
1078   (:printer reg-reg/mem ((op #x63) (reg nil :type 'word-reg)))
1079   (:emitter (emit-move-with-extension segment dst src :signed)))
1080
1081 ;;; this is not a real amd64 instruction, of course
1082 (define-instruction movzxd (segment dst src)
1083   (:printer reg-reg/mem ((op #x63) (reg nil :type 'word-reg)))
1084   (:emitter (emit-move-with-extension segment dst src nil)))
1085
1086 (define-instruction push (segment src)
1087   ;; register
1088   (:printer reg-no-width ((op #b01010)))
1089   ;; register/memory
1090   (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
1091   ;; immediate
1092   (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
1093             '(:name :tab imm))
1094   (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
1095             '(:name :tab imm))
1096   ;; ### segment registers?
1097
1098   (:emitter
1099    (cond ((integerp src)
1100           (cond ((<= -128 src 127)
1101                  (emit-byte segment #b01101010)
1102                  (emit-byte segment src))
1103                 (t
1104                  ;; AMD64 manual says no REX needed but is unclear
1105                  ;; whether it expects 32 or 64 bit immediate here
1106                  (emit-byte segment #b01101000)
1107                  (emit-dword segment src))))
1108          ((fixup-p src)
1109           ;; Interpret the fixup as an immediate dword to push.
1110           (emit-byte segment #b01101000)
1111           (emit-absolute-fixup segment src))
1112          (t
1113           (let ((size (operand-size src)))
1114             (aver (not (eq size :byte)))
1115             (maybe-emit-operand-size-prefix segment size)
1116             (maybe-emit-rex-for-ea segment src nil)
1117             (cond ((register-p src)
1118                    (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
1119                   (t
1120                    (emit-byte segment #b11111111)
1121                    (emit-ea segment src #b110 t))))))))
1122
1123 (define-instruction pusha (segment)
1124   (:printer byte ((op #b01100000)))
1125   (:emitter
1126    (emit-byte segment #b01100000)))
1127
1128 (define-instruction pop (segment dst)
1129   (:printer reg-no-width ((op #b01011)))
1130   (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
1131   (:emitter
1132    (let ((size (operand-size dst)))
1133      (aver (not (eq size :byte)))
1134      (maybe-emit-operand-size-prefix segment size)
1135      (maybe-emit-rex-for-ea segment dst nil)     
1136      (cond ((register-p dst)
1137             (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
1138            (t
1139             (emit-byte segment #b10001111)
1140             (emit-ea segment dst #b000))))))
1141
1142 (define-instruction popa (segment)
1143   (:printer byte ((op #b01100001)))
1144   (:emitter
1145    (emit-byte segment #b01100001)))
1146
1147 (define-instruction xchg (segment operand1 operand2)
1148   ;; Register with accumulator.
1149   (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
1150   ;; Register/Memory with Register.
1151   (:printer reg-reg/mem ((op #b1000011)))
1152   (:emitter
1153    (let ((size (matching-operand-size operand1 operand2)))
1154      (maybe-emit-operand-size-prefix segment size)
1155      (labels ((xchg-acc-with-something (acc something)
1156                 (if (and (not (eq size :byte)) (register-p something))
1157                     (emit-byte-with-reg segment
1158                                         #b10010
1159                                         (reg-tn-encoding something))
1160                     (xchg-reg-with-something acc something)))
1161               (xchg-reg-with-something (reg something)
1162                 (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
1163                 (emit-ea segment something (reg-tn-encoding reg))))
1164        (cond ((accumulator-p operand1)
1165               (xchg-acc-with-something operand1 operand2))
1166              ((accumulator-p operand2)
1167               (xchg-acc-with-something operand2 operand1))
1168              ((register-p operand1)
1169               (xchg-reg-with-something operand1 operand2))
1170              ((register-p operand2)
1171               (xchg-reg-with-something operand2 operand1))
1172              (t
1173               (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
1174
1175 (define-instruction lea (segment dst src)
1176   (:printer reg-reg/mem ((op #b1000110) (width 1)))
1177   (:emitter
1178    (aver (or  (dword-reg-p dst)  (qword-reg-p dst)))
1179    (maybe-emit-rex-for-ea segment src dst)
1180    (emit-byte segment #b10001101)
1181    (emit-ea segment src (reg-tn-encoding dst))))
1182
1183 (define-instruction cmpxchg (segment dst src)
1184   ;; Register/Memory with Register.
1185   (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
1186   (:emitter
1187    (aver (register-p src))
1188    (let ((size (matching-operand-size src dst)))
1189      (maybe-emit-operand-size-prefix segment size)
1190      (maybe-emit-rex-for-ea segment dst src)
1191      (emit-byte segment #b00001111)
1192      (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
1193      (emit-ea segment dst (reg-tn-encoding src)))))
1194
1195 \f
1196
1197 (define-instruction fs-segment-prefix (segment)
1198   (:emitter
1199    (emit-byte segment #x64)))
1200
1201 ;;;; flag control instructions
1202
1203 ;;; CLC -- Clear Carry Flag.
1204 (define-instruction clc (segment)
1205   (:printer byte ((op #b11111000)))
1206   (:emitter
1207    (emit-byte segment #b11111000)))
1208
1209 ;;; CLD -- Clear Direction Flag.
1210 (define-instruction cld (segment)
1211   (:printer byte ((op #b11111100)))
1212   (:emitter
1213    (emit-byte segment #b11111100)))
1214
1215 ;;; CLI -- Clear Iterrupt Enable Flag.
1216 (define-instruction cli (segment)
1217   (:printer byte ((op #b11111010)))
1218   (:emitter
1219    (emit-byte segment #b11111010)))
1220
1221 ;;; CMC -- Complement Carry Flag.
1222 (define-instruction cmc (segment)
1223   (:printer byte ((op #b11110101)))
1224   (:emitter
1225    (emit-byte segment #b11110101)))
1226
1227 ;;; LAHF -- Load AH into flags.
1228 (define-instruction lahf (segment)
1229   (:printer byte ((op #b10011111)))
1230   (:emitter
1231    (emit-byte segment #b10011111)))
1232
1233 ;;; POPF -- Pop flags.
1234 (define-instruction popf (segment)
1235   (:printer byte ((op #b10011101)))
1236   (:emitter
1237    (emit-byte segment #b10011101)))
1238
1239 ;;; PUSHF -- push flags.
1240 (define-instruction pushf (segment)
1241   (:printer byte ((op #b10011100)))
1242   (:emitter
1243    (emit-byte segment #b10011100)))
1244
1245 ;;; SAHF -- Store AH into flags.
1246 (define-instruction sahf (segment)
1247   (:printer byte ((op #b10011110)))
1248   (:emitter
1249    (emit-byte segment #b10011110)))
1250
1251 ;;; STC -- Set Carry Flag.
1252 (define-instruction stc (segment)
1253   (:printer byte ((op #b11111001)))
1254   (:emitter
1255    (emit-byte segment #b11111001)))
1256
1257 ;;; STD -- Set Direction Flag.
1258 (define-instruction std (segment)
1259   (:printer byte ((op #b11111101)))
1260   (:emitter
1261    (emit-byte segment #b11111101)))
1262
1263 ;;; STI -- Set Interrupt Enable Flag.
1264 (define-instruction sti (segment)
1265   (:printer byte ((op #b11111011)))
1266   (:emitter
1267    (emit-byte segment #b11111011)))
1268 \f
1269 ;;;; arithmetic
1270
1271 (defun emit-random-arith-inst (name segment dst src opcode
1272                                     &optional allow-constants)
1273   (let ((size (matching-operand-size dst src)))
1274     (maybe-emit-operand-size-prefix segment size)
1275     (cond
1276      ((integerp src)
1277       (cond ((and (not (eq size :byte)) (<= -128 src 127))
1278              (maybe-emit-rex-for-ea segment dst nil)
1279              (emit-byte segment #b10000011)
1280              (emit-ea segment dst opcode allow-constants)
1281              (emit-byte segment src))
1282             ((accumulator-p dst)
1283              (emit-byte segment
1284                         (dpb opcode
1285                              (byte 3 3)
1286                              (if (eq size :byte)
1287                                  #b00000100
1288                                  #b00000101)))
1289              (emit-sized-immediate segment size src))
1290             (t
1291              (maybe-emit-rex-for-ea segment dst nil)
1292              (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
1293              (emit-ea segment dst opcode allow-constants)
1294              (emit-sized-immediate segment size src))))
1295      ((register-p src)
1296       (maybe-emit-rex-for-ea segment dst src)
1297       (emit-byte segment
1298                  (dpb opcode
1299                       (byte 3 3)
1300                       (if (eq size :byte) #b00000000 #b00000001)))
1301       (emit-ea segment dst (reg-tn-encoding src) allow-constants))
1302      ((register-p dst)
1303       (maybe-emit-rex-for-ea segment src dst)
1304       (emit-byte segment
1305                  (dpb opcode
1306                       (byte 3 3)
1307                       (if (eq size :byte) #b00000010 #b00000011)))
1308       (emit-ea segment src (reg-tn-encoding dst) allow-constants))
1309      (t
1310       (error "bogus operands to ~A" name)))))
1311
1312 (eval-when (:compile-toplevel :execute)
1313   (defun arith-inst-printer-list (subop)
1314     `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
1315       (reg/mem-imm ((op (#b1000000 ,subop))))
1316       (reg/mem-imm ((op (#b1000001 ,subop))
1317                     (imm nil :type signed-imm-byte)))
1318       (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
1319   )
1320
1321 (define-instruction add (segment dst src)
1322   (:printer-list (arith-inst-printer-list #b000))
1323   (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
1324
1325 (define-instruction adc (segment dst src)
1326   (:printer-list (arith-inst-printer-list #b010))
1327   (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
1328
1329 (define-instruction sub (segment dst src)
1330   (:printer-list (arith-inst-printer-list #b101))
1331   (:emitter (emit-random-arith-inst "SUB" segment dst src #b101)))
1332
1333 (define-instruction sbb (segment dst src)
1334   (:printer-list (arith-inst-printer-list #b011))
1335   (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
1336
1337 (define-instruction cmp (segment dst src)
1338   (:printer-list (arith-inst-printer-list #b111))
1339   (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
1340
1341 (define-instruction inc (segment dst)
1342   ;; Register/Memory
1343   (:printer reg/mem ((op '(#b1111111 #b000))))
1344   (:emitter
1345    (let ((size (operand-size dst)))
1346      (maybe-emit-operand-size-prefix segment size)
1347      (cond #+nil ; these opcodes become REX prefixes in x86-64
1348            ((and (not (eq size :byte)) (register-p dst))
1349             (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
1350            (t
1351             (maybe-emit-rex-for-ea segment dst nil)
1352             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1353             (emit-ea segment dst #b000))))))
1354
1355 (define-instruction dec (segment dst)
1356   ;; Register.
1357   (:printer reg-no-width ((op #b01001)))
1358   ;; Register/Memory
1359   (:printer reg/mem ((op '(#b1111111 #b001))))
1360   (:emitter
1361    (let ((size (operand-size dst)))
1362      (maybe-emit-operand-size-prefix segment size)
1363      (cond ((and (not (eq size :byte)) (register-p dst))
1364             (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
1365            (t
1366             (maybe-emit-rex-for-ea segment dst nil)
1367             (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
1368             (emit-ea segment dst #b001))))))
1369
1370 (define-instruction neg (segment dst)
1371   (:printer reg/mem ((op '(#b1111011 #b011))))
1372   (:emitter
1373    (let ((size (operand-size dst)))
1374      (maybe-emit-operand-size-prefix segment size)
1375      (maybe-emit-rex-for-ea segment dst nil)
1376      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1377      (emit-ea segment dst #b011))))
1378
1379 (define-instruction aaa (segment)
1380   (:printer byte ((op #b00110111)))
1381   (:emitter
1382    (emit-byte segment #b00110111)))
1383
1384 (define-instruction aas (segment)
1385   (:printer byte ((op #b00111111)))
1386   (:emitter
1387    (emit-byte segment #b00111111)))
1388
1389 (define-instruction daa (segment)
1390   (:printer byte ((op #b00100111)))
1391   (:emitter
1392    (emit-byte segment #b00100111)))
1393
1394 (define-instruction das (segment)
1395   (:printer byte ((op #b00101111)))
1396   (:emitter
1397    (emit-byte segment #b00101111)))
1398
1399 (define-instruction mul (segment dst src)
1400   (:printer accum-reg/mem ((op '(#b1111011 #b100))))
1401   (:emitter
1402    (let ((size (matching-operand-size dst src)))
1403      (aver (accumulator-p dst))
1404      (maybe-emit-operand-size-prefix segment size)
1405      (maybe-emit-rex-for-ea segment src nil)
1406      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1407      (emit-ea segment src #b100))))
1408
1409 (define-instruction imul (segment dst &optional src1 src2)
1410   (:printer accum-reg/mem ((op '(#b1111011 #b101))))
1411   (:printer ext-reg-reg/mem ((op #b1010111)))
1412   (:printer reg-reg/mem ((op #b0110100) (width 1) (imm nil :type 'imm-word))
1413             '(:name :tab reg ", " reg/mem ", " imm))
1414   (:printer reg-reg/mem ((op #b0110101) (width 1)
1415                          (imm nil :type 'signed-imm-byte))
1416             '(:name :tab reg ", " reg/mem ", " imm))
1417   (:emitter
1418    (flet ((r/m-with-immed-to-reg (reg r/m immed)
1419             (let* ((size (matching-operand-size reg r/m))
1420                    (sx (and (not (eq size :byte)) (<= -128 immed 127))))
1421               (maybe-emit-operand-size-prefix segment size)
1422               (maybe-emit-rex-for-ea segment r/m reg)
1423               (emit-byte segment (if sx #b01101011 #b01101001))
1424               (emit-ea segment r/m (reg-tn-encoding reg))
1425               (if sx
1426                   (emit-byte segment immed)
1427                   (emit-sized-immediate segment size immed)))))
1428      (cond (src2
1429             (r/m-with-immed-to-reg dst src1 src2))
1430            (src1
1431             (if (integerp src1)
1432                 (r/m-with-immed-to-reg dst dst src1)
1433                 (let ((size (matching-operand-size dst src1)))
1434                   (maybe-emit-operand-size-prefix segment size)
1435                   (maybe-emit-rex-for-ea segment src1 dst)
1436                   (emit-byte segment #b00001111)
1437                   (emit-byte segment #b10101111)
1438                   (emit-ea segment src1 (reg-tn-encoding dst)))))
1439            (t
1440             (let ((size (operand-size dst)))
1441               (maybe-emit-operand-size-prefix segment size)
1442               (maybe-emit-rex-for-ea segment dst nil)
1443               (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1444               (emit-ea segment dst #b101)))))))
1445
1446 (define-instruction div (segment dst src)
1447   (:printer accum-reg/mem ((op '(#b1111011 #b110))))
1448   (:emitter
1449    (let ((size (matching-operand-size dst src)))
1450      (aver (accumulator-p dst))
1451      (maybe-emit-operand-size-prefix segment size)
1452      (maybe-emit-rex-for-ea segment src nil)
1453      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1454      (emit-ea segment src #b110))))
1455
1456 (define-instruction idiv (segment dst src)
1457   (:printer accum-reg/mem ((op '(#b1111011 #b111))))
1458   (:emitter
1459    (let ((size (matching-operand-size dst src)))
1460      (aver (accumulator-p dst))
1461      (maybe-emit-operand-size-prefix segment size)
1462      (maybe-emit-rex-for-ea segment src nil)
1463      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1464      (emit-ea segment src #b111))))
1465
1466 (define-instruction bswap (segment dst)
1467   (:printer ext-reg-no-width ((op #b11001)))
1468   (:emitter
1469    (let ((size (operand-size dst)))
1470      (maybe-emit-rex-prefix segment size nil nil dst)
1471      (emit-byte segment #x0f)
1472      (emit-byte-with-reg segment #b11001 (reg-tn-encoding dst)))))
1473
1474
1475 (define-instruction aad (segment)
1476   (:printer two-bytes ((op '(#b11010101 #b00001010))))
1477   (:emitter
1478    (emit-byte segment #b11010101)
1479    (emit-byte segment #b00001010)))
1480
1481 (define-instruction aam (segment)
1482   (:printer two-bytes ((op '(#b11010100 #b00001010))))
1483   (:emitter
1484    (emit-byte segment #b11010100)
1485    (emit-byte segment #b00001010)))
1486
1487 ;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
1488 (define-instruction cbw (segment)
1489   (:emitter
1490    (maybe-emit-operand-size-prefix segment :word)
1491    (emit-byte segment #b10011000)))
1492
1493 ;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
1494 (define-instruction cwde (segment)
1495   (:emitter
1496    (maybe-emit-operand-size-prefix segment :dword)
1497    (emit-byte segment #b10011000)))
1498
1499 ;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
1500 (define-instruction cwd (segment)
1501   (:emitter
1502    (maybe-emit-operand-size-prefix segment :word)
1503    (emit-byte segment #b10011001)))
1504
1505 ;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
1506 (define-instruction cdq (segment)
1507   (:printer byte ((op #b10011001)))
1508   (:emitter
1509    (maybe-emit-operand-size-prefix segment :dword)
1510    (emit-byte segment #b10011001)))
1511
1512 ;;; CQO -- Convert Quad or Octaword. RDX:RAX <- sign_xtnd(RAX)
1513 (define-instruction cqo (segment)
1514   (:printer byte ((op #b10011001)))
1515   (:emitter
1516    (maybe-emit-rex-prefix segment :qword nil nil nil)
1517    (emit-byte segment #b10011001)))
1518
1519 (define-instruction xadd (segment dst src)
1520   ;; Register/Memory with Register.
1521   (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
1522   (:emitter
1523    (aver (register-p src))
1524    (let ((size (matching-operand-size src dst)))
1525      (maybe-emit-operand-size-prefix segment size)
1526      (maybe-emit-rex-for-ea segment dst src)
1527      (emit-byte segment #b00001111)
1528      (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
1529      (emit-ea segment dst (reg-tn-encoding src)))))
1530
1531 \f
1532 ;;;; logic
1533
1534 (defun emit-shift-inst (segment dst amount opcode)
1535   (let ((size (operand-size dst)))
1536     (maybe-emit-operand-size-prefix segment size)
1537     (multiple-value-bind (major-opcode immed)
1538         (case amount
1539           (:cl (values #b11010010 nil))
1540           (1 (values #b11010000 nil))
1541           (t (values #b11000000 t)))
1542       (maybe-emit-rex-for-ea segment dst nil)
1543       (emit-byte segment
1544                  (if (eq size :byte) major-opcode (logior major-opcode 1)))
1545       (emit-ea segment dst opcode)
1546       (when immed
1547         (emit-byte segment amount)))))
1548
1549 (eval-when (:compile-toplevel :execute)
1550   (defun shift-inst-printer-list (subop)
1551     `((reg/mem ((op (#b1101000 ,subop)))
1552                (:name :tab reg/mem ", 1"))
1553       (reg/mem ((op (#b1101001 ,subop)))
1554                (:name :tab reg/mem ", " 'cl))
1555       (reg/mem-imm ((op (#b1100000 ,subop))
1556                     (imm nil :type signed-imm-byte))))))
1557
1558 (define-instruction rol (segment dst amount)
1559   (:printer-list
1560    (shift-inst-printer-list #b000))
1561   (:emitter
1562    (emit-shift-inst segment dst amount #b000)))
1563
1564 (define-instruction ror (segment dst amount)
1565   (:printer-list
1566    (shift-inst-printer-list #b001))
1567   (:emitter
1568    (emit-shift-inst segment dst amount #b001)))
1569
1570 (define-instruction rcl (segment dst amount)
1571   (:printer-list
1572    (shift-inst-printer-list #b010))
1573   (:emitter
1574    (emit-shift-inst segment dst amount #b010)))
1575
1576 (define-instruction rcr (segment dst amount)
1577   (:printer-list
1578    (shift-inst-printer-list #b011))
1579   (:emitter
1580    (emit-shift-inst segment dst amount #b011)))
1581
1582 (define-instruction shl (segment dst amount)
1583   (:printer-list
1584    (shift-inst-printer-list #b100))
1585   (:emitter
1586    (emit-shift-inst segment dst amount #b100)))
1587
1588 (define-instruction shr (segment dst amount)
1589   (:printer-list
1590    (shift-inst-printer-list #b101))
1591   (:emitter
1592    (emit-shift-inst segment dst amount #b101)))
1593
1594 (define-instruction sar (segment dst amount)
1595   (:printer-list
1596    (shift-inst-printer-list #b111))
1597   (:emitter
1598    (emit-shift-inst segment dst amount #b111)))
1599
1600 (defun emit-double-shift (segment opcode dst src amt)
1601   (let ((size (matching-operand-size dst src)))
1602     (when (eq size :byte)
1603       (error "Double shifts can only be used with words."))
1604     (maybe-emit-operand-size-prefix segment size)
1605     (maybe-emit-rex-for-ea segment dst src)
1606     (emit-byte segment #b00001111)
1607     (emit-byte segment (dpb opcode (byte 1 3)
1608                             (if (eq amt :cl) #b10100101 #b10100100)))
1609     (emit-ea segment dst (reg-tn-encoding src)) 
1610     (unless (eq amt :cl)
1611       (emit-byte segment amt))))
1612
1613 (eval-when (:compile-toplevel :execute)
1614   (defun double-shift-inst-printer-list (op)
1615     `(#+nil
1616       (ext-reg-reg/mem-imm ((op ,(logior op #b100))
1617                             (imm nil :type signed-imm-byte)))
1618       (ext-reg-reg/mem ((op ,(logior op #b101)))
1619          (:name :tab reg/mem ", " 'cl)))))
1620
1621 (define-instruction shld (segment dst src amt)
1622   (:declare (type (or (member :cl) (mod 32)) amt))
1623   (:printer-list (double-shift-inst-printer-list #b10100000))
1624   (:emitter
1625    (emit-double-shift segment #b0 dst src amt)))
1626
1627 (define-instruction shrd (segment dst src amt)
1628   (:declare (type (or (member :cl) (mod 32)) amt))
1629   (:printer-list (double-shift-inst-printer-list #b10101000))
1630   (:emitter
1631    (emit-double-shift segment #b1 dst src amt)))
1632
1633 (define-instruction and (segment dst src)
1634   (:printer-list
1635    (arith-inst-printer-list #b100))
1636   (:emitter
1637    (emit-random-arith-inst "AND" segment dst src #b100)))
1638
1639 (define-instruction test (segment this that)
1640   (:printer accum-imm ((op #b1010100)))
1641   (:printer reg/mem-imm ((op '(#b1111011 #b000))))
1642   (:printer reg-reg/mem ((op #b1000010)))
1643   (:emitter
1644    (let ((size (matching-operand-size this that)))
1645      (maybe-emit-operand-size-prefix segment size)
1646      (flet ((test-immed-and-something (immed something)
1647               (cond ((accumulator-p something)
1648                      (emit-byte segment
1649                                 (if (eq size :byte) #b10101000 #b10101001))
1650                      (emit-sized-immediate segment size immed))
1651                     (t
1652                      (maybe-emit-rex-for-ea segment something nil)
1653                      (emit-byte segment
1654                                 (if (eq size :byte) #b11110110 #b11110111))
1655                      (emit-ea segment something #b000)
1656                      (emit-sized-immediate segment size immed))))
1657             (test-reg-and-something (reg something)
1658               (maybe-emit-rex-for-ea segment something reg)
1659               (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
1660               (emit-ea segment something (reg-tn-encoding reg))))
1661        (cond ((integerp that)
1662               (test-immed-and-something that this))
1663              ((integerp this)
1664               (test-immed-and-something this that))
1665              ((register-p this)
1666               (test-reg-and-something this that))
1667              ((register-p that)
1668               (test-reg-and-something that this))
1669              (t
1670               (error "bogus operands for TEST: ~S and ~S" this that)))))))
1671
1672 (define-instruction or (segment dst src)
1673   (:printer-list
1674    (arith-inst-printer-list #b001))
1675   (:emitter
1676    (emit-random-arith-inst "OR" segment dst src #b001)))
1677
1678 (define-instruction xor (segment dst src)
1679   (:printer-list
1680    (arith-inst-printer-list #b110))
1681   (:emitter
1682    (emit-random-arith-inst "XOR" segment dst src #b110)))
1683
1684 (define-instruction not (segment dst)
1685   (:printer reg/mem ((op '(#b1111011 #b010))))
1686   (:emitter
1687    (let ((size (operand-size dst)))
1688      (maybe-emit-operand-size-prefix segment size)
1689      (maybe-emit-rex-for-ea segment dst nil)
1690      (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
1691      (emit-ea segment dst #b010))))
1692 \f
1693 ;;;; string manipulation
1694
1695 (define-instruction cmps (segment size)
1696   (:printer string-op ((op #b1010011)))
1697   (:emitter
1698    (maybe-emit-operand-size-prefix segment size)
1699    (maybe-emit-rex-prefix segment size nil nil nil)
1700    (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
1701
1702 (define-instruction ins (segment acc)
1703   (:printer string-op ((op #b0110110)))
1704   (:emitter
1705    (let ((size (operand-size acc)))
1706      (aver (accumulator-p acc))
1707      (maybe-emit-operand-size-prefix segment size)
1708      (maybe-emit-rex-prefix segment size nil nil nil)
1709      (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
1710
1711 (define-instruction lods (segment acc)
1712   (:printer string-op ((op #b1010110)))
1713   (:emitter
1714    (let ((size (operand-size acc)))
1715      (aver (accumulator-p acc))
1716      (maybe-emit-operand-size-prefix segment size)
1717      (maybe-emit-rex-prefix segment size nil nil nil)
1718      (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
1719
1720 (define-instruction movs (segment size)
1721   (:printer string-op ((op #b1010010)))
1722   (:emitter
1723    (maybe-emit-operand-size-prefix segment size)
1724    (maybe-emit-rex-prefix segment size nil nil nil)
1725    (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
1726
1727 (define-instruction outs (segment acc)
1728   (:printer string-op ((op #b0110111)))
1729   (:emitter
1730    (let ((size (operand-size acc)))
1731      (aver (accumulator-p acc))
1732      (maybe-emit-operand-size-prefix segment size)
1733      (maybe-emit-rex-prefix segment size nil nil nil)
1734      (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
1735
1736 (define-instruction scas (segment acc)
1737   (:printer string-op ((op #b1010111)))
1738   (:emitter
1739    (let ((size (operand-size acc)))
1740      (aver (accumulator-p acc))
1741      (maybe-emit-operand-size-prefix segment size)
1742      (maybe-emit-rex-prefix segment size nil nil nil)
1743      (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
1744
1745 (define-instruction stos (segment acc)
1746   (:printer string-op ((op #b1010101)))
1747   (:emitter
1748    (let ((size (operand-size acc)))
1749      (aver (accumulator-p acc))
1750      (maybe-emit-operand-size-prefix segment size)
1751      (maybe-emit-rex-prefix segment size nil nil nil)
1752      (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
1753
1754 (define-instruction xlat (segment)
1755   (:printer byte ((op #b11010111)))
1756   (:emitter
1757    (emit-byte segment #b11010111)))
1758
1759 (define-instruction rep (segment)
1760   (:emitter
1761    (emit-byte segment #b11110010)))
1762
1763 (define-instruction repe (segment)
1764   (:printer byte ((op #b11110011)))
1765   (:emitter
1766    (emit-byte segment #b11110011)))
1767
1768 (define-instruction repne (segment)
1769   (:printer byte ((op #b11110010)))
1770   (:emitter
1771    (emit-byte segment #b11110010)))
1772
1773 \f
1774 ;;;; bit manipulation
1775
1776 (define-instruction bsf (segment dst src)
1777   (:printer ext-reg-reg/mem ((op #b1011110) (width 0)))
1778   (:emitter
1779    (let ((size (matching-operand-size dst src)))
1780      (when (eq size :byte)
1781        (error "can't scan bytes: ~S" src))
1782      (maybe-emit-operand-size-prefix segment size)
1783      (maybe-emit-rex-for-ea segment src dst)
1784      (emit-byte segment #b00001111)
1785      (emit-byte segment #b10111100)
1786      (emit-ea segment src (reg-tn-encoding dst)))))
1787
1788 (define-instruction bsr (segment dst src)
1789   (:printer ext-reg-reg/mem ((op #b1011110) (width 1)))
1790   (:emitter
1791    (let ((size (matching-operand-size dst src)))
1792      (when (eq size :byte)
1793        (error "can't scan bytes: ~S" src))
1794      (maybe-emit-operand-size-prefix segment size)
1795      (maybe-emit-rex-for-ea segment src dst)
1796      (emit-byte segment #b00001111)
1797      (emit-byte segment #b10111101)
1798      (emit-ea segment src (reg-tn-encoding dst)))))
1799
1800 (defun emit-bit-test-and-mumble (segment src index opcode)
1801   (let ((size (operand-size src)))
1802     (when (eq size :byte)
1803       (error "can't scan bytes: ~S" src))
1804     (maybe-emit-operand-size-prefix segment size)
1805     (cond ((integerp index)
1806            (maybe-emit-rex-for-ea segment src nil)
1807            (emit-byte segment #b00001111)
1808            (emit-byte segment #b10111010)
1809            (emit-ea segment src opcode)
1810            (emit-byte segment index))
1811           (t
1812            (maybe-emit-rex-for-ea segment src index)
1813            (emit-byte segment #b00001111)
1814            (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
1815            (emit-ea segment src (reg-tn-encoding index))))))
1816
1817 (eval-when (:compile-toplevel :execute)
1818   (defun bit-test-inst-printer-list (subop)
1819     `((ext-reg/mem-imm ((op (#b1011101 ,subop))
1820                         (reg/mem nil :type word-reg/mem)
1821                         (imm nil :type imm-data)
1822                         (width 0)))
1823       (ext-reg-reg/mem ((op ,(dpb subop (byte 3 2) #b1000001))
1824                         (width 1))
1825                        (:name :tab reg/mem ", " reg)))))
1826
1827 (define-instruction bt (segment src index)
1828   (:printer-list (bit-test-inst-printer-list #b100))
1829   (:emitter
1830    (emit-bit-test-and-mumble segment src index #b100)))
1831
1832 (define-instruction btc (segment src index)
1833   (:printer-list (bit-test-inst-printer-list #b111))
1834   (:emitter
1835    (emit-bit-test-and-mumble segment src index #b111)))
1836
1837 (define-instruction btr (segment src index)
1838   (:printer-list (bit-test-inst-printer-list #b110))
1839   (:emitter
1840    (emit-bit-test-and-mumble segment src index #b110)))
1841
1842 (define-instruction bts (segment src index)
1843   (:printer-list (bit-test-inst-printer-list #b101))
1844   (:emitter
1845    (emit-bit-test-and-mumble segment src index #b101)))
1846
1847 \f
1848 ;;;; control transfer
1849
1850 (define-instruction call (segment where)
1851   (:printer near-jump ((op #b11101000)))
1852   (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
1853   (:emitter
1854    (typecase where
1855      (label
1856       (emit-byte segment #b11101000) ; 32 bit relative
1857       (emit-back-patch segment
1858                        4
1859                        (lambda (segment posn)
1860                          (emit-dword segment
1861                                      (- (label-position where)
1862                                         (+ posn 4))))))
1863      (fixup
1864       (emit-byte segment #b11101000)
1865       (emit-relative-fixup segment where))
1866      (t
1867       (emit-byte segment #b11111111)
1868       (emit-ea segment where #b010)))))
1869
1870 (defun emit-byte-displacement-backpatch (segment target)
1871   (emit-back-patch segment
1872                    1
1873                    (lambda (segment posn)
1874                      (let ((disp (- (label-position target) (1+ posn))))
1875                        (aver (<= -128 disp 127))
1876                        (emit-byte segment disp)))))
1877
1878 (define-instruction jmp (segment cond &optional where)
1879   ;; conditional jumps
1880   (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
1881   (:printer near-cond-jump () '('j cc :tab label))
1882   ;; unconditional jumps
1883   (:printer short-jump ((op #b1011)))
1884   (:printer near-jump ((op #b11101001)) )
1885   (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
1886   (:emitter
1887    (cond (where
1888           (emit-chooser
1889            segment 6 2
1890            (lambda (segment posn delta-if-after)
1891              (let ((disp (- (label-position where posn delta-if-after)
1892                             (+ posn 2))))
1893                (when (<= -128 disp 127)
1894                  (emit-byte segment
1895                             (dpb (conditional-opcode cond)
1896                                  (byte 4 0)
1897                                  #b01110000))
1898                  (emit-byte-displacement-backpatch segment where)
1899                  t)))
1900            (lambda (segment posn)
1901              (let ((disp (- (label-position where) (+ posn 6))))
1902                (emit-byte segment #b00001111)
1903                (emit-byte segment
1904                           (dpb (conditional-opcode cond)
1905                                (byte 4 0)
1906                                #b10000000))
1907                (emit-dword segment disp)))))
1908          ((label-p (setq where cond))
1909           (emit-chooser
1910            segment 5 0
1911            (lambda (segment posn delta-if-after)
1912              (let ((disp (- (label-position where posn delta-if-after)
1913                             (+ posn 2))))
1914                (when (<= -128 disp 127)
1915                  (emit-byte segment #b11101011)
1916                  (emit-byte-displacement-backpatch segment where)
1917                  t)))
1918            (lambda (segment posn)
1919              (let ((disp (- (label-position where) (+ posn 5))))
1920                (emit-byte segment #b11101001)
1921                (emit-dword segment disp)))))
1922          ((fixup-p where)
1923           (emit-byte segment #b11101001)
1924           (emit-relative-fixup segment where))
1925          (t
1926           (unless (or (ea-p where) (tn-p where))
1927                   (error "don't know what to do with ~A" where))
1928           (emit-byte segment #b11111111)
1929           (emit-ea segment where #b100)))))
1930
1931 (define-instruction jmp-short (segment label)
1932   (:emitter
1933    (emit-byte segment #b11101011)
1934    (emit-byte-displacement-backpatch segment label)))
1935
1936 (define-instruction ret (segment &optional stack-delta)
1937   (:printer byte ((op #b11000011)))
1938   (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
1939             '(:name :tab imm))
1940   (:emitter
1941    (cond (stack-delta
1942           (emit-byte segment #b11000010)
1943           (emit-word segment stack-delta))
1944          (t
1945           (emit-byte segment #b11000011)))))
1946
1947 (define-instruction jecxz (segment target)
1948   (:printer short-jump ((op #b0011)))
1949   (:emitter
1950    (emit-byte segment #b11100011)
1951    (emit-byte-displacement-backpatch segment target)))
1952
1953 (define-instruction loop (segment target)
1954   (:printer short-jump ((op #b0010)))
1955   (:emitter
1956    (emit-byte segment #b11100010)       ; pfw this was 11100011, or jecxz!!!!
1957    (emit-byte-displacement-backpatch segment target)))
1958
1959 (define-instruction loopz (segment target)
1960   (:printer short-jump ((op #b0001)))
1961   (:emitter
1962    (emit-byte segment #b11100001)
1963    (emit-byte-displacement-backpatch segment target)))
1964
1965 (define-instruction loopnz (segment target)
1966   (:printer short-jump ((op #b0000)))
1967   (:emitter
1968    (emit-byte segment #b11100000)
1969    (emit-byte-displacement-backpatch segment target)))
1970 \f
1971 ;;;; conditional move
1972 (define-instruction cmov (segment cond dst src)
1973   (:printer cond-move ())
1974   (:emitter
1975    (aver (register-p dst))
1976    (let ((size (matching-operand-size dst src)))
1977      (aver (or (eq size :word) (eq size :dword) (eq size :qword) ))
1978      (maybe-emit-operand-size-prefix segment size))
1979    (maybe-emit-rex-for-ea segment src dst)
1980    (emit-byte segment #b00001111)
1981    (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b01000000))
1982    (emit-ea segment src (reg-tn-encoding dst))))
1983
1984 ;;;; conditional byte set
1985
1986 (define-instruction set (segment dst cond)
1987   (:printer cond-set ())
1988   (:emitter
1989    (maybe-emit-rex-for-ea segment dst nil)
1990    (emit-byte segment #b00001111)
1991    (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
1992    (emit-ea segment dst #b000)))
1993 \f
1994 ;;;; enter/leave
1995
1996 (define-instruction enter (segment disp &optional (level 0))
1997   (:declare (type (unsigned-byte 16) disp)
1998             (type (unsigned-byte 8) level))
1999   (:printer enter-format ((op #b11001000)))
2000   (:emitter
2001    (emit-byte segment #b11001000)
2002    (emit-word segment disp)
2003    (emit-byte segment level)))
2004
2005 (define-instruction leave (segment)
2006   (:printer byte ((op #b11001001)))
2007   (:emitter
2008    (emit-byte segment #b11001001)))
2009 \f
2010 ;;;; interrupt instructions
2011
2012 (defun snarf-error-junk (sap offset &optional length-only)
2013   (let* ((length (sb!sys:sap-ref-8 sap offset))
2014          (vector (make-array length :element-type '(unsigned-byte 8))))
2015     (declare (type sb!sys:system-area-pointer sap)
2016              (type (unsigned-byte 8) length)
2017              (type (simple-array (unsigned-byte 8) (*)) vector))
2018     (cond (length-only
2019            (values 0 (1+ length) nil nil))
2020           (t
2021            (sb!kernel:copy-from-system-area sap (* n-byte-bits (1+ offset))
2022                                             vector (* n-word-bits
2023                                                       vector-data-offset)
2024                                             (* length n-byte-bits))
2025            (collect ((sc-offsets)
2026                      (lengths))
2027              (lengths 1)                ; the length byte
2028              (let* ((index 0)
2029                     (error-number (sb!c:read-var-integer vector index)))
2030                (lengths index)
2031                (loop
2032                  (when (>= index length)
2033                    (return))
2034                  (let ((old-index index))
2035                    (sc-offsets (sb!c:read-var-integer vector index))
2036                    (lengths (- index old-index))))
2037                (values error-number
2038                        (1+ length)
2039                        (sc-offsets)
2040                        (lengths))))))))
2041
2042 #|
2043 (defmacro break-cases (breaknum &body cases)
2044   (let ((bn-temp (gensym)))
2045     (collect ((clauses))
2046       (dolist (case cases)
2047         (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
2048       `(let ((,bn-temp ,breaknum))
2049          (cond ,@(clauses))))))
2050 |#
2051
2052 (defun break-control (chunk inst stream dstate)
2053   (declare (ignore inst))
2054   (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
2055     ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
2056     ;; map has it undefined; and it should be easier to look in the target
2057     ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
2058     ;; from first principles whether it's defined in some way that genesis
2059     ;; can't grok.
2060     (case (byte-imm-code chunk dstate)
2061       (#.error-trap
2062        (nt "error trap")
2063        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2064       (#.cerror-trap
2065        (nt "cerror trap")
2066        (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
2067       (#.breakpoint-trap
2068        (nt "breakpoint trap"))
2069       (#.pending-interrupt-trap
2070        (nt "pending interrupt trap"))
2071       (#.halt-trap
2072        (nt "halt trap"))
2073       (#.fun-end-breakpoint-trap
2074        (nt "function end breakpoint trap")))))
2075
2076 (define-instruction break (segment code)
2077   (:declare (type (unsigned-byte 8) code))
2078   (:printer byte-imm ((op #b11001100)) '(:name :tab code)
2079             :control #'break-control)
2080   (:emitter
2081    (emit-byte segment #b11001100)
2082    (emit-byte segment code)))
2083
2084 (define-instruction int (segment number)
2085   (:declare (type (unsigned-byte 8) number))
2086   (:printer byte-imm ((op #b11001101)))
2087   (:emitter
2088    (etypecase number
2089      ((member 3)
2090       (emit-byte segment #b11001100))
2091      ((unsigned-byte 8)
2092       (emit-byte segment #b11001101)
2093       (emit-byte segment number)))))
2094
2095 (define-instruction into (segment)
2096   (:printer byte ((op #b11001110)))
2097   (:emitter
2098    (emit-byte segment #b11001110)))
2099
2100 (define-instruction bound (segment reg bounds)
2101   (:emitter
2102    (let ((size (matching-operand-size reg bounds)))
2103      (when (eq size :byte)
2104        (error "can't bounds-test bytes: ~S" reg))
2105      (maybe-emit-operand-size-prefix segment size)
2106      (maybe-emit-rex-for-ea segment bounds reg)
2107      (emit-byte segment #b01100010)
2108      (emit-ea segment bounds (reg-tn-encoding reg)))))
2109
2110 (define-instruction iret (segment)
2111   (:printer byte ((op #b11001111)))
2112   (:emitter
2113    (emit-byte segment #b11001111)))
2114 \f
2115 ;;;; processor control
2116
2117 (define-instruction hlt (segment)
2118   (:printer byte ((op #b11110100)))
2119   (:emitter
2120    (emit-byte segment #b11110100)))
2121
2122 (define-instruction nop (segment)
2123   (:printer byte ((op #b10010000)))
2124   (:emitter
2125    (emit-byte segment #b10010000)))
2126
2127 (define-instruction wait (segment)
2128   (:printer byte ((op #b10011011)))
2129   (:emitter
2130    (emit-byte segment #b10011011)))
2131
2132 (define-instruction lock (segment)
2133   (:printer byte ((op #b11110000)))
2134   (:emitter
2135    (emit-byte segment #b11110000)))
2136 \f
2137 ;;;; miscellaneous hackery
2138
2139 (define-instruction byte (segment byte)
2140   (:emitter
2141    (emit-byte segment byte)))
2142
2143 (define-instruction word (segment word)
2144   (:emitter
2145    (emit-word segment word)))
2146
2147 (define-instruction dword (segment dword)
2148   (:emitter
2149    (emit-dword segment dword)))
2150
2151 (defun emit-header-data (segment type)
2152   (emit-back-patch segment
2153                    n-word-bytes
2154                    (lambda (segment posn)
2155                      (emit-qword segment
2156                                  (logior type
2157                                          (ash (+ posn
2158                                                  (component-header-length))
2159                                               (- n-widetag-bits
2160                                                  word-shift)))))))
2161
2162 (define-instruction simple-fun-header-word (segment)
2163   (:emitter
2164    (emit-header-data segment simple-fun-header-widetag)))
2165
2166 (define-instruction lra-header-word (segment)
2167   (:emitter
2168    (emit-header-data segment return-pc-header-widetag)))
2169 \f
2170 ;;;; fp instructions
2171 ;;;;
2172 ;;;; Note: We treat the single-precision and double-precision variants
2173 ;;;; as separate instructions.
2174
2175 ;;; Load single to st(0).
2176 (define-instruction fld (segment source)
2177   (:printer floating-point ((op '(#b001 #b000))))
2178   (:emitter
2179     (and (not (fp-reg-tn-p source))
2180          (maybe-emit-rex-for-ea segment source nil))
2181     (emit-byte segment #b11011001)
2182     (emit-fp-op segment source #b000)))
2183
2184 ;;; Load double to st(0).
2185 (define-instruction fldd (segment source)
2186   (:printer floating-point ((op '(#b101 #b000))))
2187   (:printer floating-point-fp ((op '(#b001 #b000))))
2188   (:emitter
2189    (if (fp-reg-tn-p source)
2190        (emit-byte segment #b11011001)
2191        (progn
2192          (maybe-emit-rex-for-ea segment source nil)
2193          (emit-byte segment #b11011101)))
2194    (emit-fp-op segment source #b000)))
2195
2196 ;;; Load long to st(0).
2197 (define-instruction fldl (segment source)
2198   (:printer floating-point ((op '(#b011 #b101))))
2199   (:emitter
2200     (and (not (fp-reg-tn-p source))
2201          (maybe-emit-rex-for-ea segment source nil))
2202     (emit-byte segment #b11011011)
2203     (emit-fp-op segment source #b101)))
2204
2205 ;;; Store single from st(0).
2206 (define-instruction fst (segment dest)
2207   (:printer floating-point ((op '(#b001 #b010))))
2208   (:emitter
2209     (cond ((fp-reg-tn-p dest)
2210            (emit-byte segment #b11011101)
2211            (emit-fp-op segment dest #b010))
2212           (t
2213            (maybe-emit-rex-for-ea segment dest nil)
2214            (emit-byte segment #b11011001)
2215            (emit-fp-op segment dest #b010)))))
2216
2217 ;;; Store double from st(0).
2218 (define-instruction fstd (segment dest)
2219   (:printer floating-point ((op '(#b101 #b010))))
2220   (:printer floating-point-fp ((op '(#b101 #b010))))
2221   (:emitter
2222    (cond ((fp-reg-tn-p dest)
2223           (emit-byte segment #b11011101)
2224           (emit-fp-op segment dest #b010))
2225          (t
2226           (maybe-emit-rex-for-ea segment dest nil)
2227           (emit-byte segment #b11011101)
2228           (emit-fp-op segment dest #b010)))))
2229
2230 ;;; Arithmetic ops are all done with at least one operand at top of
2231 ;;; stack. The other operand is is another register or a 32/64 bit
2232 ;;; memory loc.
2233
2234 ;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
2235 ;;; that these conflict with the Gdb conventions for binops. To reduce
2236 ;;; the confusion I've added comments showing the mathamatical
2237 ;;; operation and the two syntaxes. By the ASM386 convention the
2238 ;;; instruction syntax is:
2239 ;;;
2240 ;;;      Fop Source
2241 ;;; or   Fop Destination, Source
2242 ;;;
2243 ;;; If only one operand is given then it is the source and the
2244 ;;; destination is ST(0). There are reversed forms of the fsub and
2245 ;;; fdiv instructions inducated by an 'R' suffix.
2246 ;;;
2247 ;;; The mathematical operation for the non-reverse form is always:
2248 ;;;     destination = destination op source
2249 ;;;
2250 ;;; For the reversed form it is:
2251 ;;;     destination = source op destination
2252 ;;;
2253 ;;; The instructions below only accept one operand at present which is
2254 ;;; usually the source. I've hack in extra instructions to implement
2255 ;;; the fops with a ST(i) destination, these have a -sti suffix and
2256 ;;; the operand is the destination with the source being ST(0).
2257
2258 ;;; Add single:
2259 ;;;   st(0) = st(0) + memory or st(i).
2260 (define-instruction fadd (segment source)
2261   (:printer floating-point ((op '(#b000 #b000))))
2262   (:emitter
2263     (and (not (fp-reg-tn-p source))
2264          (maybe-emit-rex-for-ea segment source nil))
2265     (emit-byte segment #b11011000)
2266     (emit-fp-op segment source #b000)))
2267
2268 ;;; Add double:
2269 ;;;   st(0) = st(0) + memory or st(i).
2270 (define-instruction faddd (segment source)
2271   (:printer floating-point ((op '(#b100 #b000))))
2272   (:printer floating-point-fp ((op '(#b000 #b000))))
2273   (:emitter
2274    (and (not (fp-reg-tn-p source))
2275         (maybe-emit-rex-for-ea segment source nil))
2276    (if (fp-reg-tn-p source)
2277        (emit-byte segment #b11011000)
2278      (emit-byte segment #b11011100))
2279    (emit-fp-op segment source #b000)))
2280
2281 ;;; Add double destination st(i):
2282 ;;;   st(i) = st(0) + st(i).
2283 (define-instruction fadd-sti (segment destination)
2284   (:printer floating-point-fp ((op '(#b100 #b000))))
2285   (:emitter
2286    (aver (fp-reg-tn-p destination))
2287    (emit-byte segment #b11011100)
2288    (emit-fp-op segment destination #b000)))
2289 ;;; with pop
2290 (define-instruction faddp-sti (segment destination)
2291   (:printer floating-point-fp ((op '(#b110 #b000))))
2292   (:emitter
2293    (aver (fp-reg-tn-p destination))
2294    (emit-byte segment #b11011110)
2295    (emit-fp-op segment destination #b000)))
2296
2297 ;;; Subtract single:
2298 ;;;   st(0) = st(0) - memory or st(i).
2299 (define-instruction fsub (segment source)
2300   (:printer floating-point ((op '(#b000 #b100))))
2301   (:emitter
2302     (and (not (fp-reg-tn-p source))
2303          (maybe-emit-rex-for-ea segment source nil))
2304     (emit-byte segment #b11011000)
2305     (emit-fp-op segment source #b100)))
2306
2307 ;;; Subtract single, reverse:
2308 ;;;   st(0) = memory or st(i) - st(0).
2309 (define-instruction fsubr (segment source)
2310   (:printer floating-point ((op '(#b000 #b101))))
2311   (:emitter
2312     (and (not (fp-reg-tn-p source))
2313          (maybe-emit-rex-for-ea segment source nil))
2314     (emit-byte segment #b11011000)
2315     (emit-fp-op segment source #b101)))
2316
2317 ;;; Subtract double:
2318 ;;;   st(0) = st(0) - memory or st(i).
2319 (define-instruction fsubd (segment source)
2320   (:printer floating-point ((op '(#b100 #b100))))
2321   (:printer floating-point-fp ((op '(#b000 #b100))))
2322   (:emitter
2323    (if (fp-reg-tn-p source)
2324        (emit-byte segment #b11011000)
2325        (progn
2326          (and (not (fp-reg-tn-p source))
2327               (maybe-emit-rex-for-ea segment source nil))
2328          (emit-byte segment #b11011100)))
2329    (emit-fp-op segment source #b100)))
2330
2331 ;;; Subtract double, reverse:
2332 ;;;   st(0) = memory or st(i) - st(0).
2333 (define-instruction fsubrd (segment source)
2334   (:printer floating-point ((op '(#b100 #b101))))
2335   (:printer floating-point-fp ((op '(#b000 #b101))))
2336   (:emitter
2337    (if (fp-reg-tn-p source)
2338        (emit-byte segment #b11011000)
2339        (progn
2340          (and (not (fp-reg-tn-p source))
2341               (maybe-emit-rex-for-ea segment source nil))
2342          (emit-byte segment #b11011100)))
2343    (emit-fp-op segment source #b101)))
2344
2345 ;;; Subtract double, destination st(i):
2346 ;;;   st(i) = st(i) - st(0).
2347 ;;;
2348 ;;; ASM386 syntax: FSUB ST(i), ST
2349 ;;; Gdb    syntax: fsubr %st,%st(i)
2350 (define-instruction fsub-sti (segment destination)
2351   (:printer floating-point-fp ((op '(#b100 #b101))))
2352   (:emitter
2353    (aver (fp-reg-tn-p destination))
2354    (emit-byte segment #b11011100)
2355    (emit-fp-op segment destination #b101)))
2356 ;;; with a pop
2357 (define-instruction fsubp-sti (segment destination)
2358   (:printer floating-point-fp ((op '(#b110 #b101))))
2359   (:emitter
2360    (aver (fp-reg-tn-p destination))
2361    (emit-byte segment #b11011110)
2362    (emit-fp-op segment destination #b101)))
2363
2364 ;;; Subtract double, reverse, destination st(i):
2365 ;;;   st(i) = st(0) - st(i).
2366 ;;;
2367 ;;; ASM386 syntax: FSUBR ST(i), ST
2368 ;;; Gdb    syntax: fsub %st,%st(i)
2369 (define-instruction fsubr-sti (segment destination)
2370   (:printer floating-point-fp ((op '(#b100 #b100))))
2371   (:emitter
2372    (aver (fp-reg-tn-p destination))
2373    (emit-byte segment #b11011100)
2374    (emit-fp-op segment destination #b100)))
2375 ;;; with a pop
2376 (define-instruction fsubrp-sti (segment destination)
2377   (:printer floating-point-fp ((op '(#b110 #b100))))
2378   (:emitter
2379    (aver (fp-reg-tn-p destination))
2380    (emit-byte segment #b11011110)
2381    (emit-fp-op segment destination #b100)))
2382
2383 ;;; Multiply single:
2384 ;;;   st(0) = st(0) * memory or st(i).
2385 (define-instruction fmul (segment source)
2386   (:printer floating-point ((op '(#b000 #b001))))
2387   (:emitter
2388    (and (not (fp-reg-tn-p source))
2389         (maybe-emit-rex-for-ea segment source nil))
2390    (emit-byte segment #b11011000)
2391    (emit-fp-op segment source #b001)))
2392
2393 ;;; Multiply double:
2394 ;;;   st(0) = st(0) * memory or st(i).
2395 (define-instruction fmuld (segment source)
2396   (:printer floating-point ((op '(#b100 #b001))))
2397   (:printer floating-point-fp ((op '(#b000 #b001))))
2398   (:emitter
2399    (if (fp-reg-tn-p source)
2400        (emit-byte segment #b11011000)
2401        (progn
2402          (and (not (fp-reg-tn-p source))
2403               (maybe-emit-rex-for-ea segment source nil))
2404          (emit-byte segment #b11011100)))
2405    (emit-fp-op segment source #b001)))
2406
2407 ;;; Multiply double, destination st(i):
2408 ;;;   st(i) = st(i) * st(0).
2409 (define-instruction fmul-sti (segment destination)
2410   (:printer floating-point-fp ((op '(#b100 #b001))))
2411   (:emitter
2412    (aver (fp-reg-tn-p destination))
2413    (emit-byte segment #b11011100)
2414    (emit-fp-op segment destination #b001)))
2415
2416 ;;; Divide single:
2417 ;;;   st(0) = st(0) / memory or st(i).
2418 (define-instruction fdiv (segment source)
2419   (:printer floating-point ((op '(#b000 #b110))))
2420   (:emitter
2421    (and (not (fp-reg-tn-p source))
2422         (maybe-emit-rex-for-ea segment source nil))
2423    (emit-byte segment #b11011000)
2424    (emit-fp-op segment source #b110)))
2425
2426 ;;; Divide single, reverse:
2427 ;;;   st(0) = memory or st(i) / st(0).
2428 (define-instruction fdivr (segment source)
2429   (:printer floating-point ((op '(#b000 #b111))))
2430   (:emitter
2431    (and (not (fp-reg-tn-p source))
2432         (maybe-emit-rex-for-ea segment source nil))
2433    (emit-byte segment #b11011000)
2434    (emit-fp-op segment source #b111)))
2435
2436 ;;; Divide double:
2437 ;;;   st(0) = st(0) / memory or st(i).
2438 (define-instruction fdivd (segment source)
2439   (:printer floating-point ((op '(#b100 #b110))))
2440   (:printer floating-point-fp ((op '(#b000 #b110))))
2441   (:emitter
2442    (if (fp-reg-tn-p source)
2443        (emit-byte segment #b11011000)
2444        (progn
2445          (and (not (fp-reg-tn-p source))
2446               (maybe-emit-rex-for-ea segment source nil))
2447          (emit-byte segment #b11011100)))
2448    (emit-fp-op segment source #b110)))
2449
2450 ;;; Divide double, reverse:
2451 ;;;   st(0) = memory or st(i) / st(0).
2452 (define-instruction fdivrd (segment source)
2453   (:printer floating-point ((op '(#b100 #b111))))
2454   (:printer floating-point-fp ((op '(#b000 #b111))))
2455   (:emitter
2456    (if (fp-reg-tn-p source)
2457        (emit-byte segment #b11011000)
2458        (progn 
2459          (and (not (fp-reg-tn-p source))
2460               (maybe-emit-rex-for-ea segment source nil))
2461          (emit-byte segment #b11011100)))
2462    (emit-fp-op segment source #b111)))
2463
2464 ;;; Divide double, destination st(i):
2465 ;;;   st(i) = st(i) / st(0).
2466 ;;;
2467 ;;; ASM386 syntax: FDIV ST(i), ST
2468 ;;; Gdb    syntax: fdivr %st,%st(i)
2469 (define-instruction fdiv-sti (segment destination)
2470   (:printer floating-point-fp ((op '(#b100 #b111))))
2471   (:emitter
2472    (aver (fp-reg-tn-p destination))
2473    (emit-byte segment #b11011100)
2474    (emit-fp-op segment destination #b111)))
2475
2476 ;;; Divide double, reverse, destination st(i):
2477 ;;;   st(i) = st(0) / st(i).
2478 ;;;
2479 ;;; ASM386 syntax: FDIVR ST(i), ST
2480 ;;; Gdb    syntax: fdiv %st,%st(i)
2481 (define-instruction fdivr-sti (segment destination)
2482   (:printer floating-point-fp ((op '(#b100 #b110))))
2483   (:emitter
2484    (aver (fp-reg-tn-p destination))
2485    (emit-byte segment #b11011100)
2486    (emit-fp-op segment destination #b110)))
2487
2488 ;;; Exchange fr0 with fr(n). (There is no double precision variant.)
2489 (define-instruction fxch (segment source)
2490   (:printer floating-point-fp ((op '(#b001 #b001))))
2491   (:emitter
2492     (unless (and (tn-p source)
2493                  (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
2494       (cl:break))
2495     (emit-byte segment #b11011001)
2496     (emit-fp-op segment source #b001)))
2497
2498 ;;; Push 32-bit integer to st0.
2499 (define-instruction fild (segment source)
2500   (:printer floating-point ((op '(#b011 #b000))))
2501   (:emitter
2502     (and (not (fp-reg-tn-p source))
2503          (maybe-emit-rex-for-ea segment source nil))
2504     (emit-byte segment #b11011011)
2505     (emit-fp-op segment source #b000)))
2506
2507 ;;; Push 64-bit integer to st0.
2508 (define-instruction fildl (segment source)
2509   (:printer floating-point ((op '(#b111 #b101))))
2510   (:emitter
2511     (and (not (fp-reg-tn-p source))
2512          (maybe-emit-rex-for-ea segment source nil))
2513     (emit-byte segment #b11011111)
2514     (emit-fp-op segment source #b101)))
2515
2516 ;;; Store 32-bit integer.
2517 (define-instruction fist (segment dest)
2518   (:printer floating-point ((op '(#b011 #b010))))
2519   (:emitter
2520    (and (not (fp-reg-tn-p dest))
2521         (maybe-emit-rex-for-ea segment dest nil))
2522    (emit-byte segment #b11011011)
2523    (emit-fp-op segment dest #b010)))
2524
2525 ;;; Store and pop 32-bit integer.
2526 (define-instruction fistp (segment dest)
2527   (:printer floating-point ((op '(#b011 #b011))))
2528   (:emitter
2529    (and (not (fp-reg-tn-p dest))
2530         (maybe-emit-rex-for-ea segment dest nil))
2531    (emit-byte segment #b11011011)
2532    (emit-fp-op segment dest #b011)))
2533
2534 ;;; Store and pop 64-bit integer.
2535 (define-instruction fistpl (segment dest)
2536   (:printer floating-point ((op '(#b111 #b111))))
2537   (:emitter
2538    (and (not (fp-reg-tn-p dest))
2539         (maybe-emit-rex-for-ea segment dest nil))
2540    (emit-byte segment #b11011111)
2541    (emit-fp-op segment dest #b111)))
2542
2543 ;;; Store single from st(0) and pop.
2544 (define-instruction fstp (segment dest)
2545   (:printer floating-point ((op '(#b001 #b011))))
2546   (:emitter
2547    (cond ((fp-reg-tn-p dest)
2548           (emit-byte segment #b11011101)
2549           (emit-fp-op segment dest #b011))
2550          (t
2551           (maybe-emit-rex-for-ea segment dest nil)
2552           (emit-byte segment #b11011001)
2553           (emit-fp-op segment dest #b011)))))
2554
2555 ;;; Store double from st(0) and pop.
2556 (define-instruction fstpd (segment dest)
2557   (:printer floating-point ((op '(#b101 #b011))))
2558   (:printer floating-point-fp ((op '(#b101 #b011))))
2559   (:emitter
2560    (cond ((fp-reg-tn-p dest)
2561           (emit-byte segment #b11011101)
2562           (emit-fp-op segment dest #b011))
2563          (t
2564           (maybe-emit-rex-for-ea segment dest nil)
2565           (emit-byte segment #b11011101)
2566           (emit-fp-op segment dest #b011)))))
2567
2568 ;;; Store long from st(0) and pop.
2569 (define-instruction fstpl (segment dest)
2570   (:printer floating-point ((op '(#b011 #b111))))
2571   (:emitter
2572    (and (not (fp-reg-tn-p dest))
2573         (maybe-emit-rex-for-ea segment dest nil))
2574    (emit-byte segment #b11011011)
2575    (emit-fp-op segment dest #b111)))
2576
2577 ;;; Decrement stack-top pointer.
2578 (define-instruction fdecstp (segment)
2579   (:printer floating-point-no ((op #b10110)))
2580   (:emitter
2581    (emit-byte segment #b11011001)
2582    (emit-byte segment #b11110110)))
2583
2584 ;;; Increment stack-top pointer.
2585 (define-instruction fincstp (segment)
2586   (:printer floating-point-no ((op #b10111)))
2587   (:emitter
2588    (emit-byte segment #b11011001)
2589    (emit-byte segment #b11110111)))
2590
2591 ;;; Free fp register.
2592 (define-instruction ffree (segment dest)
2593   (:printer floating-point-fp ((op '(#b101 #b000))))
2594   (:emitter
2595    (and (not (fp-reg-tn-p dest))
2596         (maybe-emit-rex-for-ea segment dest nil))
2597    (emit-byte segment #b11011101)
2598    (emit-fp-op segment dest #b000)))
2599
2600 (define-instruction fabs (segment)
2601   (:printer floating-point-no ((op #b00001)))
2602   (:emitter
2603    (emit-byte segment #b11011001)
2604    (emit-byte segment #b11100001)))
2605
2606 (define-instruction fchs (segment)
2607   (:printer floating-point-no ((op #b00000)))
2608   (:emitter
2609    (emit-byte segment #b11011001)
2610    (emit-byte segment #b11100000)))
2611
2612 (define-instruction frndint(segment)
2613   (:printer floating-point-no ((op #b11100)))
2614   (:emitter
2615    (emit-byte segment #b11011001)
2616    (emit-byte segment #b11111100)))
2617
2618 ;;; Initialize NPX.
2619 (define-instruction fninit(segment)
2620   (:printer floating-point-5 ((op #b00011)))
2621   (:emitter
2622    (emit-byte segment #b11011011)
2623    (emit-byte segment #b11100011)))
2624
2625 ;;; Store Status Word to AX.
2626 (define-instruction fnstsw(segment)
2627   (:printer floating-point-st ((op #b00000)))
2628   (:emitter
2629    (emit-byte segment #b11011111)
2630    (emit-byte segment #b11100000)))
2631
2632 ;;; Load Control Word.
2633 ;;;
2634 ;;; src must be a memory location
2635 (define-instruction fldcw(segment src)
2636   (:printer floating-point ((op '(#b001 #b101))))
2637   (:emitter
2638    (and (not (fp-reg-tn-p src))
2639         (maybe-emit-rex-for-ea segment src nil))
2640    (emit-byte segment #b11011001)
2641    (emit-fp-op segment src #b101)))
2642
2643 ;;; Store Control Word.
2644 (define-instruction fnstcw(segment dst)
2645   (:printer floating-point ((op '(#b001 #b111))))
2646   (:emitter
2647    (and (not (fp-reg-tn-p dst))
2648         (maybe-emit-rex-for-ea segment dst nil))
2649    (emit-byte segment #b11011001)
2650    (emit-fp-op segment dst #b111)))
2651
2652 ;;; Store FP Environment.
2653 (define-instruction fstenv(segment dst)
2654   (:printer floating-point ((op '(#b001 #b110))))
2655   (:emitter
2656    (and (not (fp-reg-tn-p dst))
2657         (maybe-emit-rex-for-ea segment dst nil))
2658    (emit-byte segment #b11011001)
2659    (emit-fp-op segment dst #b110)))
2660
2661 ;;; Restore FP Environment.
2662 (define-instruction fldenv(segment src)
2663   (:printer floating-point ((op '(#b001 #b100))))
2664   (:emitter
2665    (and (not (fp-reg-tn-p src))
2666         (maybe-emit-rex-for-ea segment src nil))
2667    (emit-byte segment #b11011001)
2668    (emit-fp-op segment src #b100)))
2669
2670 ;;; Save FP State.
2671 (define-instruction fsave(segment dst)
2672   (:printer floating-point ((op '(#b101 #b110))))
2673   (:emitter
2674    (and (not (fp-reg-tn-p dst))
2675         (maybe-emit-rex-for-ea segment dst nil))
2676    (emit-byte segment #b11011101)
2677    (emit-fp-op segment dst #b110)))
2678
2679 ;;; Restore FP State.
2680 (define-instruction frstor(segment src)
2681   (:printer floating-point ((op '(#b101 #b100))))
2682   (:emitter
2683    (and (not (fp-reg-tn-p src))
2684         (maybe-emit-rex-for-ea segment src nil))
2685    (emit-byte segment #b11011101)
2686    (emit-fp-op segment src #b100)))
2687
2688 ;;; Clear exceptions.
2689 (define-instruction fnclex(segment)
2690   (:printer floating-point-5 ((op #b00010)))
2691   (:emitter
2692    (emit-byte segment #b11011011)
2693    (emit-byte segment #b11100010)))
2694
2695 ;;; comparison
2696 (define-instruction fcom (segment src)
2697   (:printer floating-point ((op '(#b000 #b010))))
2698   (:emitter
2699    (and (not (fp-reg-tn-p src))
2700         (maybe-emit-rex-for-ea segment src nil))
2701    (emit-byte segment #b11011000)
2702    (emit-fp-op segment src #b010)))
2703
2704 (define-instruction fcomd (segment src)
2705   (:printer floating-point ((op '(#b100 #b010))))
2706   (:printer floating-point-fp ((op '(#b000 #b010))))
2707   (:emitter
2708    (if (fp-reg-tn-p src)
2709        (emit-byte segment #b11011000)
2710        (progn
2711          (maybe-emit-rex-for-ea segment src nil)
2712          (emit-byte segment #b11011100)))
2713    (emit-fp-op segment src #b010)))
2714
2715 ;;; Compare ST1 to ST0, popping the stack twice.
2716 (define-instruction fcompp (segment)
2717   (:printer floating-point-3 ((op '(#b110 #b011001))))
2718   (:emitter
2719    (emit-byte segment #b11011110)
2720    (emit-byte segment #b11011001)))
2721
2722 ;;; unordered comparison
2723 (define-instruction fucom (segment src)
2724   (:printer floating-point-fp ((op '(#b101 #b100))))
2725   (:emitter
2726    (aver (fp-reg-tn-p src))
2727    (emit-byte segment #b11011101)
2728    (emit-fp-op segment src #b100)))
2729
2730 (define-instruction ftst (segment)
2731   (:printer floating-point-no ((op #b00100)))
2732   (:emitter
2733    (emit-byte segment #b11011001)
2734    (emit-byte segment #b11100100)))
2735
2736 ;;;; 80387 specials
2737
2738 (define-instruction fsqrt(segment)
2739   (:printer floating-point-no ((op #b11010)))
2740   (:emitter
2741    (emit-byte segment #b11011001)
2742    (emit-byte segment #b11111010)))
2743
2744 (define-instruction fscale(segment)
2745   (:printer floating-point-no ((op #b11101)))
2746   (:emitter
2747    (emit-byte segment #b11011001)
2748    (emit-byte segment #b11111101)))
2749
2750 (define-instruction fxtract(segment)
2751   (:printer floating-point-no ((op #b10100)))
2752   (:emitter
2753    (emit-byte segment #b11011001)
2754    (emit-byte segment #b11110100)))
2755
2756 (define-instruction fsin(segment)
2757   (:printer floating-point-no ((op #b11110)))
2758   (:emitter
2759    (emit-byte segment #b11011001)
2760    (emit-byte segment #b11111110)))
2761
2762 (define-instruction fcos(segment)
2763   (:printer floating-point-no ((op #b11111)))
2764   (:emitter
2765    (emit-byte segment #b11011001)
2766    (emit-byte segment #b11111111)))
2767
2768 (define-instruction fprem1(segment)
2769   (:printer floating-point-no ((op #b10101)))
2770   (:emitter
2771    (emit-byte segment #b11011001)
2772    (emit-byte segment #b11110101)))
2773
2774 (define-instruction fprem(segment)
2775   (:printer floating-point-no ((op #b11000)))
2776   (:emitter
2777    (emit-byte segment #b11011001)
2778    (emit-byte segment #b11111000)))
2779
2780 (define-instruction fxam (segment)
2781   (:printer floating-point-no ((op #b00101)))
2782   (:emitter
2783    (emit-byte segment #b11011001)
2784    (emit-byte segment #b11100101)))
2785
2786 ;;; These do push/pop to stack and need special handling
2787 ;;; in any VOPs that use them. See the book.
2788
2789 ;;; st0 <- st1*log2(st0)
2790 (define-instruction fyl2x(segment)      ; pops stack
2791   (:printer floating-point-no ((op #b10001)))
2792   (:emitter
2793    (emit-byte segment #b11011001)
2794    (emit-byte segment #b11110001)))
2795
2796 (define-instruction fyl2xp1(segment)
2797   (:printer floating-point-no ((op #b11001)))
2798   (:emitter
2799    (emit-byte segment #b11011001)
2800    (emit-byte segment #b11111001)))
2801
2802 (define-instruction f2xm1(segment)
2803   (:printer floating-point-no ((op #b10000)))
2804   (:emitter
2805    (emit-byte segment #b11011001)
2806    (emit-byte segment #b11110000)))
2807
2808 (define-instruction fptan(segment)      ; st(0) <- 1; st(1) <- tan
2809   (:printer floating-point-no ((op #b10010)))
2810   (:emitter
2811    (emit-byte segment #b11011001)
2812    (emit-byte segment #b11110010)))
2813
2814 (define-instruction fpatan(segment)     ; POPS STACK
2815   (:printer floating-point-no ((op #b10011)))
2816   (:emitter
2817    (emit-byte segment #b11011001)
2818    (emit-byte segment #b11110011)))
2819
2820 ;;;; loading constants
2821
2822 (define-instruction fldz(segment)
2823   (:printer floating-point-no ((op #b01110)))
2824   (:emitter
2825    (emit-byte segment #b11011001)
2826    (emit-byte segment #b11101110)))
2827
2828 (define-instruction fld1(segment)
2829   (:printer floating-point-no ((op #b01000)))
2830   (:emitter
2831    (emit-byte segment #b11011001)
2832    (emit-byte segment #b11101000)))
2833
2834 (define-instruction fldpi(segment)
2835   (:printer floating-point-no ((op #b01011)))
2836   (:emitter
2837    (emit-byte segment #b11011001)
2838    (emit-byte segment #b11101011)))
2839
2840 (define-instruction fldl2t(segment)
2841   (:printer floating-point-no ((op #b01001)))
2842   (:emitter
2843    (emit-byte segment #b11011001)
2844    (emit-byte segment #b11101001)))
2845
2846 (define-instruction fldl2e(segment)
2847   (:printer floating-point-no ((op #b01010)))
2848   (:emitter
2849    (emit-byte segment #b11011001)
2850    (emit-byte segment #b11101010)))
2851
2852 (define-instruction fldlg2(segment)
2853   (:printer floating-point-no ((op #b01100)))
2854   (:emitter
2855    (emit-byte segment #b11011001)
2856    (emit-byte segment #b11101100)))
2857
2858 (define-instruction fldln2(segment)
2859   (:printer floating-point-no ((op #b01101)))
2860   (:emitter
2861    (emit-byte segment #b11011001)
2862    (emit-byte segment #b11101101)))
2863