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