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