?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge /Users/sabetts/src/movitzcvs/movitz
[movitz-core.git] / asm-x86.lisp
blob9d0c0172e05a6bafe4e57884717c2f2e3f39e02d
1 ;;;;------------------------------------------------------------------
2 ;;;;
3 ;;;; Copyright (C) 2007 Frode V. Fjeld
4 ;;;;
5 ;;;; Description: x86 assembler for 16, 32, and 64-bit modes.
6 ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
7 ;;;; Distribution: See the accompanying file COPYING.
8 ;;;;
9 ;;;; $Id: asm-x86.lisp,v 1.30 2008/02/23 22:35:10 ffjeld Exp $
10 ;;;;
11 ;;;;------------------------------------------------------------------
12
13 (defpackage asm-x86
14 (:use :common-lisp :asm)
15 (:export #:assemble-instruction
16 #:disassemble-instruction
17 #:*cpu-mode*
18 #:*position-independent-p*))
19
20 (in-package asm-x86)
21
22 (defvar *cpu-mode* :32-bit)
23
24 (defvar *instruction-encoders*
25 (make-hash-table :test 'eq))
26
27 (defvar *use-jcc-16-bit-p* nil
28 "Whether to use 16-bit JCC instructions in 32-bit mode.")
29
30 (defun prefix-lookup (prefix-name)
31 (cdr (or (assoc prefix-name
32 '((:operand-size-override . #x66)
33 (:address-size-override . #x67)
34 (:16-bit-operand . #x66)
35 (:16-bit-address . #x67)
36 (:lock . #xf0)
37 (:repne . #xf2)
38 (:repz . #xf3)
39 (:cs-override . #x2e)
40 (:ss-override . #x36)
41 (:ds-override . #x3e)
42 (:es-override . #x26)
43 (:fs-override . #x64)
44 (:gs-override . #x65)))
45 (error "There is no instruction prefix named ~S." prefix-name))))
46
47 (defun rex-encode (rexes &key rm)
48 (let ((rex (logior (if (null rexes)
49 0
50 (+ #x40 (loop for rex in rexes
51 sum (ecase rex
52 (:rex.w #b1000)
53 (:rex.r #b0100)
54 (:rex.x #b0010)
55 (:rex.b #b0001)))))
56 (if (not rm)
57 0
58 (ldb (byte 1 3) rm)))))
59 (unless (zerop rex)
60 (list rex))))
61
62
63
64 (deftype octet ()
65 '(unsigned-byte 8))
66
67 (deftype xint (size)
68 `(or (unsigned-byte ,size)
69 (signed-byte ,size)))
70
71 (deftype uint (size)
72 `(unsigned-byte ,size))
73
74 (deftype sint (size)
75 `(signed-byte ,size))
76
77 (defun integer-to-octets (i n)
78 "Return list of n octets, encoding i in signed little endian."
79 (loop for b from 0 below (* 8 n) by 8
80 collect (ldb (byte 8 b) i)))
81
82 (defun encode-values-fun (operator legacy-prefixes prefixes rexes opcode mod reg rm scale index base displacement immediate operand-size address-size)
83 (assert opcode)
84 (when (or (and (eq address-size :32-bit)
85 (eq *cpu-mode* :64-bit))
86 (and (eq address-size :16-bit)
87 (eq *cpu-mode* :32-bit))
88 (and (eq address-size :64-bit)
89 (eq *cpu-mode* :32-bit))
90 (and (eq address-size :32-bit)
91 (eq *cpu-mode* :16-bit)))
92 (pushnew :address-size-override
93 prefixes))
94 (when (or (and (eq operand-size :16-bit)
95 (eq *cpu-mode* :64-bit))
96 (and (eq operand-size :16-bit)
97 (eq *cpu-mode* :32-bit))
98 (and (eq operand-size :32-bit)
99 (eq *cpu-mode* :16-bit)))
100 (pushnew :operand-size-override
101 prefixes))
102 (let ((code (append legacy-prefixes
103 (mapcar #'prefix-lookup (reverse prefixes))
104 (rex-encode rexes :rm rm)
105 (when (< 16 (integer-length opcode))
106 (list (ldb (byte 8 16) opcode)))
107 (when (< 8(integer-length opcode))
108 (list (ldb (byte 8 8) opcode)))
109 (list (ldb (byte 8 0) opcode))
110 (when (or mod reg rm)
111 (assert (and mod reg rm) (mod reg rm)
112 "Either all or none of mod, reg, and rm must be defined. mod=~S, reg=~S, rm=~S." mod reg rm)
113 (check-type mod (unsigned-byte 2))
114 (list (logior (ash (ldb (byte 2 0) mod)
115 6)
116 (ash (ldb (byte 3 0) reg)
117 3)
118 (ash (ldb (byte 3 0) rm)
119 0))))
120 (when (or scale index base)
121 (assert (and scale index base) (scale index base)
122 "Either all or none of scale, index, and base must be defined. scale=~S, index=~S, base=~S." scale index base)
123 (check-type scale (unsigned-byte 2))
124 (check-type index (unsigned-byte 4))
125 (check-type base (unsigned-byte 4))
126 (list (logior (ash (ldb (byte 2 0) scale)
127 6)
128 (ash (ldb (byte 3 0) index)
129 3)
130 (ash (ldb (byte 3 0) base)
131 0))))
132 displacement
133 immediate)))
134 (append (compute-extra-prefixes operator *pc* (length code))
135 code)))
136
137 (defmacro encode (values-form)
138 `(multiple-value-call #'encode-values-fun operator legacy-prefixes ,values-form))
139
140 (defmacro merge-encodings (form1 form2)
141 `(multiple-value-bind (prefixes1 rexes1 opcode1 mod1 reg1 rm1 scale1 index1 base1 displacement1 immediate1 operand-size1 address-size1)
142 ,form1
143 (multiple-value-bind (prefixes2 rexes2 opcode2 mod2 reg2 rm2 scale2 index2 base2 displacement2 immediate2 operand-size2 address-size2)
144 ,form2
145 (macrolet ((getone (a b name)
146 `(cond
147 ((and ,a ,b)
148 (error "~A doubly defined: ~S and ~S." ',name ,a ,b))
149 (,a)
150 (,b))))
151 (encoded-values :prefixes (append prefixes1 prefixes2)
152 :rex (append (if (listp rexes1)
153 rexes1
154 (list rexes1))
155 (if (listp rexes2)
156 rexes2
157 (list rexes2)))
158 :opcode (getone opcode1 opcode2 opcode)
159 :mod (getone mod1 mod2 mod)
160 :reg (getone reg1 reg2 reg)
161 :rm (getone rm1 rm2 rm)
162 :scale (getone scale1 scale2 scale)
163 :index (getone index1 index2 index)
164 :base (getone base1 base2 base)
165 :displacement (getone displacement1 displacement2 displacement)
166 :immediate (getone immediate1 immediate2 immediate)
167 :operand-size (getone operand-size1 operand-size2 operand-size)
168 :address-size (getone address-size1 address-size2 address-size))))))
169
170
171 (defun encoded-values (&key prefixes prefix rex opcode mod reg rm scale index base displacement immediate operand-size address-size)
172 (values (append (when prefix
173 (list prefix))
174 prefixes)
175 (if (keywordp rex)
176 (list rex)
177 rex)
178 opcode
179 mod reg rm
180 scale index base
181 displacement
182 immediate
183 operand-size
184 address-size))
185
186 (defun assemble-instruction (instruction)
187 "Assemble a single instruction to a list of octets of x86 machine code, according to *cpu-mode* etc."
188 (multiple-value-bind (instruction legacy-prefixes options)
189 (if (listp (car instruction))
190 (values (cdr instruction)
191 (remove-if #'listp (car instruction))
192 (remove-if #'keywordp (car instruction)))
193 (values instruction
194 nil
195 nil))
196 (destructuring-bind (operator &rest operands)
197 instruction
198 (multiple-value-bind (code failp)
199 (apply (or (gethash operator *instruction-encoders*)
200 (error "Unknown instruction operator ~S in ~S." operator instruction))
201 operator
202 (mapcar #'prefix-lookup legacy-prefixes)
203 operands)
204 (cond
205 (failp
206 (error "Unable to encode ~S." instruction))
207 ((null options)
208 code)
209 ((assoc :size options)
210 (assert (= (second (assoc :size options))
211 (length code)))
212 code))))))
213
214 (defmacro define-operator (operator operator-mode lambda-list &body body)
215 (check-type operator keyword)
216 (labels ((find-forms (body)
217 (cond
218 ((atom body)
219 nil)
220 ((member (car body) '(reg-modrm modrm opcode imm-modrm imm opcode-reg pc-rel moffset))
221 (list body))
222 (t (mapcan #'find-forms body)))))
223 (let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator))))
224 `(progn
225 (defun ,defun-name (operator legacy-prefixes ,@lambda-list)
226 (declare (ignorable operator legacy-prefixes))
227 (let ((operator-mode ',operator-mode)
228 (default-rex nil))
229 (declare (ignorable operator-mode default-rex))
230 (macrolet ((disassembler (&body body)
231 (declare (ignore body)))
232 (assembler (&body body)
233 `(progn ,@body)))
234 (block operator
235 ,@body
236 (values nil 'fail)))))
237 (setf (gethash ',operator *instruction-encoders*)
238 ',defun-name)
239 (macrolet ((disassembler (&body body)
240 `(progn ,@body))
241 (assembler (&body body)
242 (declare (ignore body))))
243 (let ((operator ',operator)
244 (operator-mode ',operator-mode)
245 (operand-formals ',lambda-list))
246 (declare (ignorable operator operand-formals operator-mode))
247 ,@(find-forms body)))
248 ',operator))))
249
250 (defmacro define-operator/none (name lambda-list &body body)
251 `(define-operator ,name nil ,lambda-list ,@body))
252
253 (deftype list-of (&rest elements)
254 "A list with elements of specified type(s)."
255 (labels ((make-list-of (elements)
256 (if (null elements)
257 'null
258 `(cons ,(car elements)
259 ,(make-list-of (cdr elements))))))
260 (make-list-of elements)))
261
262 (deftype list-of* (&rest elements)
263 "A list starting with elements of specified type(s)."
264 (labels ((make-list-of (elements)
265 (if (null elements)
266 'list
267 `(cons ,(car elements)
268 ,(make-list-of (cdr elements))))))
269 (make-list-of elements)))
270
271 (defparameter *opcode-disassemblers-16*
272 (make-array 256 :initial-element nil))
273
274 (defparameter *opcode-disassemblers-32*
275 (make-array 256 :initial-element nil))
276
277 (defparameter *opcode-disassemblers-64*
278 (make-array 256 :initial-element nil))
279
280 (deftype disassembly-decoder ()
281 '(list-of* boolean keyword (or keyword null) symbol))
282
283 (defun (setf opcode-disassembler) (decoder opcode operator-mode)
284 (check-type decoder disassembly-decoder)
285 (labels ((set-it (table pos)
286 (check-type pos (integer 0 *))
287 (check-type table (simple-vector 256))
288 (let ((bit-pos (* 8 (1- (ceiling (integer-length pos) 8)))))
289 (if (not (plusp bit-pos))
290 (progn
291 (unless (or (eq nil decoder)
292 (eq nil (svref table pos))
293 (equal decoder (svref table pos)))
294 (warn "Redefining disassembler for ~@[~(~A~) ~]opcode #x~X from ~{~S ~}to ~{~S~^ ~}."
295 operator-mode opcode (svref table pos) decoder))
296 (setf (svref table pos) decoder))
297 (set-it (or (svref table (ldb (byte 8 bit-pos) pos))
298 (setf (svref table (ldb (byte 8 bit-pos) pos))
299 (make-array 256 :initial-element nil)))
300 (ldb (byte bit-pos 0) pos))))))
301 (ecase operator-mode
302 (:16-bit
303 (set-it *opcode-disassemblers-16* opcode))
304 (:32-bit
305 (set-it *opcode-disassemblers-32* opcode))
306 (:64-bit
307 (set-it *opcode-disassemblers-64* opcode))
308 ((:8-bit nil)
309 (set-it *opcode-disassemblers-16* opcode)
310 (set-it *opcode-disassemblers-32* opcode)
311 (set-it *opcode-disassemblers-64* opcode)))))
312
313
314
315 (defmacro define-disassembler ((operator opcode &optional cpu-mode digit backup-p) lambda-list &body body)
316 (cond
317 (digit
318 `(loop for mod from #b00 to #b11
319 do (loop for r/m from #b000 to #b111
320 as ext-opcode = (logior (ash ,opcode 8)
321 (ash ,digit 3)
322 (ash mod 6)
323 r/m)
324 do (define-disassembler (,operator ext-opcode ,cpu-mode nil t) ,lambda-list ,@body))))
325 ((symbolp lambda-list)
326 `(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,backup-p ,operator ,cpu-mode ',lambda-list ,@body)))
327 (t (let ((defun-name (intern (format nil "~A-~A-~X~@[-~A~]" 'disassembler operator opcode cpu-mode))))
328 `(progn
329 (defun ,defun-name ,lambda-list ,@body)
330 (setf (opcode-disassembler ,opcode ',cpu-mode) (list ,backup-p ,operator ',cpu-mode ',defun-name))
331 ',defun-name)))))
332
333 (defun disassemble-simple-prefix (code operator opcode operand-size address-size rex)
334 (declare (ignore opcode rex))
335 (let ((instruction (code-call (disassemble-instruction code operand-size address-size nil))))
336 (values (if (consp (car instruction))
337 (list* (list* operator (car instruction))
338 (cdr instruction))
339 (list* (list operator)
340 instruction))
341 code)))
342
343 (define-disassembler (:lock #xf0) disassemble-simple-prefix)
344 (define-disassembler (:repne #xf2) disassemble-simple-prefix)
345 (define-disassembler (:repz #xf3) disassemble-simple-prefix)
346 (define-disassembler (:cs-override #x2e) disassemble-simple-prefix)
347 (define-disassembler (:ss-override #x36) disassemble-simple-prefix)
348 (define-disassembler (:ds-override #x3e) disassemble-simple-prefix)
349 (define-disassembler (:es-override #x26) disassemble-simple-prefix)
350 (define-disassembler (:fs-override #x64) disassemble-simple-prefix)
351 (define-disassembler (:gs-override #x65) disassemble-simple-prefix)
352
353 (define-disassembler (:operand-size-override #x66 :32-bit) (code operator opcode operand-size address-size rex)
354 (declare (ignore operator opcode operand-size rex))
355 (disassemble-instruction code :16-bit address-size nil))
356
357 (define-disassembler (:address-size-override #x67 :32-bit) (code operator opcode operand-size address-size rex)
358 (declare (ignore operator opcode address-size rex))
359 (disassemble-instruction code operand-size :16-bit nil))
360
361 (define-disassembler (:operand-size-override #x66 :16-bit) (code operator opcode operand-size address-size rex)
362 (declare (ignore operator opcode operand-size rex))
363 (disassemble-instruction code :32-bit address-size nil))
364
365 (define-disassembler (:address-size-override #x67 :16-bit) (code operator opcode operand-size address-size rex)
366 (declare (ignore operator opcode address-size rex))
367 (disassemble-instruction code operand-size :32-bit nil))
368
369 (defmacro define-operator/8 (operator lambda-list &body body)
370 `(define-operator ,operator :8-bit ,lambda-list
371 (let ((default-rex nil))
372 (declare (ignorable default-rex))
373 ,@body)))
374
375 (defmacro define-operator/16 (operator lambda-list &body body)
376 `(define-operator ,operator :16-bit ,lambda-list
377 (let ((default-rex nil))
378 (declare (ignorable default-rex))
379 ,@body)))
380
381 (defmacro define-operator/32 (operator lambda-list &body body)
382 `(define-operator ,operator :32-bit ,lambda-list
383 (let ((default-rex nil))
384 (declare (ignorable default-rex))
385 ,@body)))
386
387 (defmacro define-operator/64 (operator lambda-list &body body)
388 `(define-operator ,operator :64-bit ,lambda-list
389 (let ((default-rex '(:rex.w)))
390 (declare (ignorable default-rex))
391 ,@body)))
392
393 (defmacro define-operator/64* (operator lambda-list &body body)
394 `(define-operator ,operator :64-bit ,lambda-list
395 (let ((default-rex (case *cpu-mode*
396 (:64-bit nil)
397 (t '(:rex.w)))))
398 (declare (ignorable default-rex))
399 ,@body)))
400
401 (defmacro define-operator* ((&key |16| |32| |64| dispatch) args &body body)
402 (let ((body16 (subst '(xint 16) :int-16-32-64
403 (subst :dx :dx-edx-rdx
404 (subst :ax :ax-eax-rax body))))
405 (body32 (subst '(xint 32) :int-16-32-64
406 (subst :edx :dx-edx-rdx
407 (subst :eax :ax-eax-rax body))))
408 (body64 (subst '(sint 32) :int-16-32-64
409 (subst :rdx :dx-edx-rdx
410 (subst :rax :ax-eax-rax body)))))
411 `(progn
412 ,(when |16|
413 `(define-operator/16 ,|16| ,args ,@body16))
414 ,(when |32|
415 `(define-operator/32 ,|32| ,args ,@body32))
416 ,(when |64|
417 `(define-operator/64 ,|64| ,args ,@body64))
418 ,(when dispatch
419 (let ((dispatch-name (intern (format nil "~A-~A" 'instruction-dispatcher dispatch))))
420 `(progn
421 (defun ,dispatch-name (&rest args)
422 (declare (dynamic-extent args))
423 (loop for encoder in (ecase *cpu-mode*
424 (:32-bit ',(remove nil (list |32| |16| |64|)))
425 (:64-bit ',(remove nil (list |64| |32| |16|)))
426 (:16-bit ',(remove nil (list |16| |32| |64|))))
427 thereis (apply (gethash encoder *instruction-encoders*) args)
428 finally (return (values nil 'fail))))
429 (setf (gethash ',dispatch *instruction-encoders*)
430 ',dispatch-name))))
431 nil)))
432
433 (defun resolve-and-encode (x type &key size)
434 (encode-integer (cond
435 ((typep x type)
436 x)
437 ((integerp x)
438 (error "Immediate value #x~X out of range for ~S." x type))
439 ((assoc x *symtab*)
440 (let ((value (cdr (assoc x *symtab*))))
441 (assert (typep value type))
442 value))
443 (t (error "Unresolved symbol ~S (size ~S)." x size)))
444 type))
445
446 (defun resolve-pc-relative (operand)
447 (etypecase operand
448 (pc-relative-operand
449 (reduce #'+ (cdr operand)
450 :key #'resolve-operand))
451 (symbol-reference
452 (assert *pc* (*pc*) "Cannot encode a pc-relative operand without a value for ~S." '*pc*)
453 (- (resolve-operand operand)
454 *pc*))))
455
456 (defun encode-integer (i type)
457 (assert (typep i type))
458 (let ((bit-size (cadr type)))
459 (loop for b upfrom 0 below bit-size by 8
460 collect (ldb (byte 8 b) i))))
461
462 (defun type-octet-size (type)
463 (assert (member (car type)
464 '(sint uint xint))
465 (type))
466 (values (ceiling (cadr type) 8)))
467
468 (defun opcode-octet-size (opcode)
469 (loop do (setf opcode (ash opcode -8))
470 count t
471 while (plusp opcode)))
472
473 (defun parse-indirect-operand (operand)
474 (assert (indirect-operand-p operand))
475 (let (reg offsets reg2 reg-scale)
476 (dolist (expr operand)
477 (etypecase expr
478 (register-operand
479 (if reg
480 (setf reg2 expr)
481 (setf reg expr)))
482 ((cons register-operand
483 (cons (member 1 2 4 8) null))
484 (when reg
485 (assert (not reg-scale))
486 (setf reg2 reg))
487 (setf reg (first expr)
488 reg-scale (second expr)))
489 (immediate-operand
490 (push expr offsets))
491 ((cons (eql :+))
492 (dolist (term (cdr expr))
493 (push term offsets)))))
494 (when (and (eq reg2 :esp)
495 (or (not reg-scale)
496 (eql 1 reg-scale)))
497 (psetf reg reg2
498 reg2 reg))
499 (values reg offsets reg2 (if (not reg)
500 nil
501 (or reg-scale 1)))))
502
503 (defun register-set-by-mode (mode)
504 (ecase mode
505 (:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh))
506 (:16-bit '(:ax :cx :dx :bx :sp :bp :si :di))
507 (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi))
508 (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :13 :r14 :r15))
509 (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7))
510 (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7))))
511
512 (defun encode-reg/mem (operand mode)
513 (check-type mode (member nil :8-bit :16-bit :32-bit :64-bit :mm :xmm))
514 (if (and mode (keywordp operand))
515 (encoded-values :mod #b11
516 :rm (or (position operand (register-set-by-mode mode))
517 (error "Unknown ~(~D~) register ~S." mode operand)))
518 (multiple-value-bind (reg offsets reg2 reg-scale)
519 (parse-indirect-operand operand)
520 (check-type reg-scale (member nil 1 2 4 8))
521 (assert (or (not reg2)
522 (and reg reg2)))
523 (assert (or (not reg-scale)
524 (and reg reg-scale)))
525 (let ((offset (reduce #'+ offsets
526 :key #'resolve-operand)))
527 (cond
528 ((and (not reg)
529 (eq mode :16-bit)
530 (typep offset '(xint 16)))
531 (encoded-values :mod #b00
532 :rm #b110
533 :address-size :16-bit
534 :displacement (encode-integer offset '(xint 16))))
535 ((and (not reg)
536 (typep offset '(xint 32)))
537 (encoded-values :mod #b00
538 :rm #b101
539 :address-size :32-bit
540 :displacement (encode-integer offset '(xint 32))))
541 ((and (eq reg :sp)
542 (not reg2)
543 (= 1 reg-scale))
544 (etypecase offset
545 ((eql 0)
546 (encoded-values :mod #b00
547 :rm #b100
548 :scale 0
549 :index #b100
550 :base #b100
551 :address-size :16-bit))
552 ((sint 8)
553 (encoded-values :mod #b01
554 :rm #b100
555 :displacement (encode-integer offset '(sint 8))
556 :scale 0
557 :index #b100
558 :base #b100
559 :address-size :16-bit))
560 ((xint 32)
561 (encoded-values :mod #b10
562 :rm #b100
563 :displacement (encode-integer offset '(xint 32))
564 :scale 0
565 :index #b100
566 :base #b100
567 :address-size :16-bit))))
568 ((and (eq reg :esp)
569 (= 1 reg-scale))
570 (let ((reg2-index (or (position reg2 '(:eax :ecx :edx :ebx nil :ebp :esi :edi))
571 (error "Unknown reg2 [F] ~S." reg2))))
572 (etypecase offset
573 ((eql 0)
574 (encoded-values :mod #b00
575 :rm #b100
576 :scale 0
577 :index reg2-index
578 :base #b100
579 :address-size :32-bit))
580 ((sint 8)
581 (encoded-values :mod #b01
582 :rm #b100
583 :displacement (encode-integer offset '(sint 8))
584 :scale 0
585 :index reg2-index
586 :base #b100
587 :address-size :32-bit))
588 ((xint 32)
589 (encoded-values :mod #b10
590 :rm #b100
591 :displacement (encode-integer offset '(xint 32))
592 :scale 0
593 :index reg2-index
594 :base #b100
595 :address-size :32-bit)))))
596 ((and (eq reg :rsp)
597 (not reg2)
598 (= 1 reg-scale))
599 (etypecase offset
600 ((eql 0)
601 (encoded-values :mod #b00
602 :rm #b100
603 :scale 0
604 :index #b100
605 :base #b100
606 :address-size :64-bit))
607 ((sint 8)
608 (encoded-values :mod #b01
609 :rm #b100
610 :displacement (encode-integer offset '(sint 8))
611 :scale 0
612 :index #b100
613 :base #b100
614 :address-size :64-bit))
615 ((sint 32)
616 (encoded-values :mod #b10
617 :rm #b100
618 :displacement (encode-integer offset '(sint 32))
619 :scale 0
620 :index #b100
621 :base #b100
622 :address-size :64-bit))))
623 (t (multiple-value-bind (register-index map address-size)
624 (let* ((map32 '(:eax :ecx :edx :ebx :esp :ebp :esi :edi))
625 (index32 (position reg map32))
626 (map64 '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15))
627 (index64 (unless index32
628 (position reg map64))))
629 (if index32
630 (values index32 map32 :32-bit)
631 (values index64 map64 :64-bit)))
632 (cond
633 ((and (not reg2)
634 register-index
635 (= 1 reg-scale)
636 (and (zerop offset)
637 (not (= register-index #b101))))
638 (encoded-values :mod #b00
639 :rm register-index
640 :address-size address-size))
641 ((and (not reg2)
642 register-index
643 (= 1 reg-scale)
644 (typep offset '(sint 8)))
645 (encoded-values :mod #b01
646 :rm register-index
647 :displacement (encode-integer offset '(sint 8))
648 :address-size address-size))
649 ((and (not reg2)
650 register-index
651 (= 1 reg-scale)
652 (or (typep offset '(sint 32))
653 (and (eq :32-bit address-size)
654 (typep offset '(xint 32)))))
655 (encoded-values :mod #b10
656 :rm register-index
657 :displacement (encode-integer offset '(sint 32))
658 :address-size address-size))
659 ((and (not reg2)
660 register-index
661 (if (eq :64-bit *cpu-mode*)
662 (typep offset '(sint 32))
663 (typep offset '(xint 32)))
664 (not (= #b100 register-index)))
665 (encoded-values :rm #b100
666 :mod #b00
667 :index register-index
668 :base #b101
669 :scale (or (position reg-scale '(1 2 4 8))
670 (error "Unknown register scale ~S." reg-scale))
671 :displacement (encode-integer offset '(xint 32))))
672 ((and reg2
673 register-index
674 (zerop offset)
675 (not (= register-index #b100)))
676 (encoded-values :mod #b00
677 :rm #b100
678 :scale (or (position reg-scale '(1 2 4 8))
679 (error "Unknown register scale ~S." reg-scale))
680 :index register-index
681 :base (or (position reg2 map)
682 (error "unknown reg2 [A] ~S" reg2))
683 :address-size address-size))
684 ((and reg2
685 register-index
686 (typep offset '(sint 8))
687 (not (= register-index #b100)))
688 (encoded-values :mod #b01
689 :rm #b100
690 :scale (position reg-scale '(1 2 4 8))
691 :index register-index
692 :base (or (position reg2 map)
693 (error "unknown reg2 [B] ~S" reg2))
694 :address-size address-size
695 :displacement (encode-integer offset '(sint 8))))
696 ((and reg2
697 register-index
698 (eq :32-bit address-size)
699 (typep offset '(sint 8))
700 (not (= register-index #b100)))
701 (encoded-values :mod #b01
702 :rm #b100
703 :scale (position reg-scale '(1 2 4 8))
704 :index register-index
705 :base (or (position reg2 map)
706 (error "unknown reg2 [C] ~S." reg2))
707 :address-size address-size
708 :displacement (encode-integer offset '(sint 8))))
709 ((and reg2
710 register-index
711 (eq :32-bit address-size)
712 (typep offset '(xint 32))
713 (not (= register-index #b100)))
714 (encoded-values :mod #b10
715 :rm #b100
716 :scale (position reg-scale '(1 2 4 8))
717 :index register-index
718 :base (or (position reg2 map)
719 (error "unknown reg2 [D] ~S." reg2))
720 :address-size address-size
721 :displacement (encode-integer offset '(xint 32))))
722 ((and reg2
723 register-index
724 (eq :64-bit address-size)
725 (typep offset '(sint 32))
726 (not (= register-index #b100)))
727 (encoded-values :mod #b01
728 :rm #b100
729 :scale (position reg-scale '(1 2 4 8))
730 :index register-index
731 :base (or (position reg2 map)
732 (error "unknown reg2 [E] ~S" reg2))
733 :address-size address-size
734 :displacement (encode-integer offset '(sint 32))))
735 (t (let ((rm16 (position-if (lambda (x)
736 (or (and (eq (car x) reg)
737 (eq (cdr x) reg2))
738 (and (eq (car x) reg2)
739 (eq (cdr x) reg))))
740 '((:bx . :si) (:bx . :di) (:bp . :si) (:bp . :di)
741 (:si) (:di) (:bp) (:bx)))))
742 (cond
743 ((and rm16
744 (zerop offset)
745 (not (= #b110 rm16)))
746 (encoded-values :mod #b00
747 :rm rm16
748 :address-size :16-bit))
749 ((and rm16
750 (typep offset '(sint 8)))
751 (encoded-values :mod #b01
752 :rm rm16
753 :address-size :16-bit
754 :displacement (encode-integer offset '(sint 8))))
755 ((and rm16
756 (typep offset '(xint 16)))
757 (encoded-values :mod #b10
758 :rm rm16
759 :address-size :16-bit
760 :displacement (encode-integer offset '(xint 16))))
761 (t (error "Huh? reg: ~S, reg2: ~S, scale: ~S, offset: ~S" reg reg2 reg-scale offset)))))))))))))
762
763 (defun operand-ordering (formals &rest arrangement)
764 (loop with rarrangement = (reverse arrangement)
765 for formal in formals
766 when (getf rarrangement formal)
767 collect it))
768
769 (defun order-operands (ordering &rest operands)
770 (loop for key in ordering
771 collect (or (getf operands key)
772 (error "No operand ~S in ~S." key operands))))
773
774 (defmacro pop-code (code-place &optional context)
775 `(progn
776 (unless ,code-place
777 (error "End of byte-stream in the middle of an instruction."))
778 (let ((x (pop ,code-place)))
779 (check-type x (unsigned-byte 8) ,(format nil "an octet (context: ~A)" context))
780 x)))
781
782 (defmacro code-call (form &optional (code-place (case (car form) ((funcall apply) (third form)) (t (second form)))))
783 "Execute form, then 'magically' update the code binding with the secondary return value from form."
784 `(let (tmp)
785 (declare (ignorable tmp))
786 (setf (values tmp ,code-place) ,form)))
787
788 (defun decode-integer (code type)
789 "Decode an integer of specified type."
790 (let* ((bit-size (cadr type))
791 (unsigned-integer (loop for b from 0 below bit-size by 8
792 sum (ash (pop-code code integer) b))))
793 (values (if (or (not (member (car type) '(sint signed-byte)))
794 (not (logbitp (1- bit-size) unsigned-integer)))
795 unsigned-integer
796 (- (ldb (byte bit-size 0)
797 (1+ (lognot unsigned-integer)))))
798 code)))
799
800 (defun disassemble-instruction (code &optional override-operand-size override-address-size rex)
801 (labels ((lookup-decoder (table opcode)
802 (let* ((backup-code code)
803 (datum (pop-code code))
804 (opcode (logior (ash opcode 8)
805 datum))
806 (decoder (svref table datum)))
807 (typecase decoder
808 (vector
809 (lookup-decoder decoder opcode))
810 (disassembly-decoder
811 (when (car decoder)
812 (setf code backup-code))
813 (values (cdr decoder)
814 opcode))
815 (t (error "No disassembler registered for opcode #x~X." opcode))))))
816 (multiple-value-bind (decoder opcode)
817 (lookup-decoder (ecase (or override-operand-size *cpu-mode*)
818 (:16-bit *opcode-disassemblers-16*)
819 (:32-bit *opcode-disassemblers-32*)
820 (:64-bit *opcode-disassemblers-64*))
821 0)
822 (destructuring-bind (operator operand-size decoder-function &rest extra-args)
823 decoder
824 (values (code-call (apply decoder-function
825 code
826 operator
827 opcode
828 (or operand-size override-operand-size)
829 (or override-address-size *cpu-mode*)
830 rex
831 extra-args))
832 code)))))
833
834 (defun decode-no-operands (code operator opcode operand-size address-size rex &rest fixed-operands)
835 (declare (ignore opcode operand-size address-size rex))
836 (values (list* operator
837 (remove nil fixed-operands))
838 code))
839
840 (defun decode-reg-modrm (code operator opcode operand-size address-size rex operand-ordering)
841 (declare (ignore opcode rex))
842 (values (list* operator
843 (order-operands operand-ordering
844 :reg (nth (ldb (byte 3 3) (car code))
845 (register-set-by-mode operand-size))
846 :modrm (ecase address-size
847 (:32-bit
848 (code-call (decode-reg-modrm-32 code operand-size)))
849 (:16-bit
850 (code-call (decode-reg-modrm-16 code operand-size))))))
851 code))
852
853
854 (defun decode-modrm (code operator opcode operand-size address-size rex)
855 (declare (ignore opcode rex))
856 (values (list operator
857 (ecase address-size
858 (:32-bit
859 (code-call (decode-reg-modrm-32 code operand-size)))
860 (:16-bit
861 (code-call (decode-reg-modrm-16 code operand-size)))))
862 code))
863
864 (defun decode-imm-modrm (code operator opcode operand-size address-size rex imm-type operand-ordering &key fixed-modrm)
865 (declare (ignore opcode rex))
866 (values (list* operator
867 (order-operands operand-ordering
868 :modrm (or fixed-modrm
869 (when (member :modrm operand-ordering)
870 (ecase address-size
871 (:32-bit
872 (code-call (decode-reg-modrm-32 code operand-size)))
873 (:16-bit
874 (code-call (decode-reg-modrm-16 code operand-size))))))
875 :imm (code-call (decode-integer code imm-type))))
876 code))
877
878 (defun decode-pc-rel (code operator opcode operand-size address-size rex type)
879 (declare (ignore opcode operand-size address-size rex))
880 (values (list operator
881 `(:pc+ ,(code-call (decode-integer code type))))
882 code))
883
884 (defun decode-moffset (code operator opcode operand-size address-size rex type operand-ordering fixed-operand)
885 (declare (ignore opcode operand-size address-size rex))
886 (values (list* operator
887 (order-operands operand-ordering
888 :moffset (list (code-call (decode-integer code type)))
889 :fixed fixed-operand))
890 code))
891
892 (defun decode-opcode-reg (code operator opcode operand-size address-size rex operand-ordering extra-operand)
893 (declare (ignore address-size rex))
894 (values (list* operator
895 (order-operands operand-ordering
896 :reg (nth (ldb (byte 3 0) opcode)
897 (register-set-by-mode operand-size))
898 :extra extra-operand))
899 code))
900
901 (defun decode-reg-modrm-16 (code operand-size)
902 (let* ((modrm (pop-code code mod/rm))
903 (mod (ldb (byte 2 6) modrm))
904 (reg (ldb (byte 3 3) modrm))
905 (r/m (ldb (byte 3 0) modrm)))
906 (values (if (= mod #b11)
907 (nth reg (register-set-by-mode operand-size))
908 (flet ((operands (i)
909 (nth i '((:bx :si) (:bx :di) (:bp :si) (:bp :di) (:si) (:di) (:bp) (:bx)))))
910 (ecase mod
911 (#b00
912 (case r/m
913 (#b110 (code-call (decode-integer code '(uint 16))))
914 (t (operands r/m))))
915 (#b01
916 (append (operands r/m)
917 (code-call (decode-integer code '(sint 8)))))
918 (#b10
919 (append (operands r/m)
920 (code-call (decode-integer code '(uint 16))))))))
921 code)))
922
923 (defun decode-reg-modrm-32 (code operand-size)
924 "Return a list of the REG, and the MOD/RM operands."
925 (let* ((modrm (pop-code code mod/rm))
926 (mod (ldb (byte 2 6) modrm))
927 (r/m (ldb (byte 3 0) modrm)))
928 (values (if (= mod #b11)
929 (nth r/m (register-set-by-mode operand-size))
930 (flet ((decode-sib ()
931 (let* ((sib (pop-code code sib))
932 (ss (ldb (byte 2 6) sib))
933 (index (ldb (byte 3 3) sib))
934 (base (ldb (byte 3 0) sib)))
935 (nconc (unless (= index #b100)
936 (let ((index-reg (nth index (register-set-by-mode :32-bit))))
937 (if (= ss #b00)
938 (list index-reg)
939 (list (list index-reg (ash 2 ss))))))
940 (if (/= base #b101)
941 (list (nth base (register-set-by-mode :32-bit)))
942 (ecase mod
943 (#b00 nil)
944 ((#b01 #b10) (list :ebp))))))))
945 (ecase mod
946 (#b00 (case r/m
947 (#b100 (decode-sib))
948 (#b101 (code-call (decode-integer code '(uint 32))))
949 (t (list (nth r/m (register-set-by-mode :32-bit))))))
950 (#b01 (case r/m
951 (#b100 (nconc(decode-sib)
952 (list (code-call (decode-integer code '(sint 8))))))
953 (t (list (nth r/m (register-set-by-mode :32-bit))
954 (code-call (decode-integer code '(sint 8)))))))
955 (#b10 (case r/m
956 (#b100 (nconc (decode-sib)
957 (list (code-call (decode-integer code '(uint 32))))))
958 (t (list (nth r/m (register-set-by-mode :32-bit))
959 (code-call (decode-integer code '(uint 32))))))))))
960 code)))
961
962
963 (defmacro return-when (form)
964 `(let ((x ,form))
965 (when x (return-from operator x))))
966
967 (defmacro return-values-when (form)
968 `(let ((x (encode ,form)))
969 (when x (return-from operator x))))
970
971 (defmacro imm (imm-operand opcode imm-type &optional extra-operand &rest extras)
972 `(progn
973 (assembler
974 (when (and ,@(when extra-operand
975 (list (list* 'eql extra-operand)))
976 (immediate-p ,imm-operand))
977 (let ((immediate (resolve-operand ,imm-operand)))
978 (when (typep immediate ',imm-type)
979 (return-values-when
980 (encoded-values :opcode ,opcode
981 :immediate (encode-integer immediate ',imm-type)
982 :operand-size operator-mode
983 :rex default-rex
984 ,@extras))))))
985 (disassembler
986 ,(if extra-operand
987 `(define-disassembler (operator ,opcode operator-mode)
988 decode-imm-modrm
989 ',imm-type
990 (operand-ordering operand-formals
991 :imm ',imm-operand
992 :modrm ',(first extra-operand))
993 :fixed-modrm ',(second extra-operand))
994 `(define-disassembler (operator ,opcode operator-mode)
995 decode-imm-modrm
996 ',imm-type
997 '(:imm))))))
998
999 (defmacro imm-modrm (op-imm op-modrm opcode digit type)
1000 `(progn
1001 (assembler
1002 (when (immediate-p ,op-imm)
1003 (let ((immediate (resolve-operand ,op-imm)))
1004 (when (typep immediate ',type)
1005 (return-values-when
1006 (merge-encodings (encoded-values :opcode ,opcode
1007 :reg ,digit
1008 :operand-size operator-mode
1009 :rex default-rex
1010 :immediate (encode-integer immediate ',type))
1011 (encode-reg/mem ,op-modrm operator-mode)))))))
1012 (disassembler
1013 (define-disassembler (operator ,opcode operator-mode ,digit)
1014 decode-imm-modrm
1015 ',type
1016 (operand-ordering operand-formals
1017 :imm ',op-imm
1018 :modrm ',op-modrm)))))
1019
1020
1021 (defun compute-extra-prefixes (operator pc size)
1022 (let ((ff (assoc operator *instruction-compute-extra-prefix-map*)))
1023 (when ff
1024 (funcall (cdr ff) pc size))))
1025
1026 (defun encode-pc-rel (operator legacy-prefixes opcode operand type &rest extras)
1027 (when (typep operand '(or pc-relative-operand symbol-reference))
1028 (let* ((estimated-code-size-no-extras (+ (length legacy-prefixes)
1029 (type-octet-size type)
1030 (opcode-octet-size opcode)))
1031 (estimated-extra-prefixes (compute-extra-prefixes operator *pc* estimated-code-size-no-extras))
1032 (estimated-code-size (+ estimated-code-size-no-extras
1033 (length estimated-extra-prefixes)))
1034 (offset (let ((*pc* (when *pc*
1035 (+ *pc* estimated-code-size))))
1036 (resolve-pc-relative operand))))
1037 (when (typep offset type)
1038 (let ((code (let ((*instruction-compute-extra-prefix-map* nil))
1039 (encode (apply #'encoded-values
1040 :opcode opcode
1041 :displacement (encode-integer offset type)
1042 extras)))))
1043 (if (= (length code)
1044 estimated-code-size-no-extras)
1045 (append estimated-extra-prefixes code)
1046 (let* ((code-size (length code))
1047 (extra-prefixes (compute-extra-prefixes operator *pc* code-size))
1048 (offset (let ((*pc* (when *pc*
1049 (+ *pc* code-size (length extra-prefixes)))))
1050 (resolve-pc-relative operand))))
1051 (when (typep offset type)
1052 (let ((code (let ((*instruction-compute-extra-prefix-map* nil))
1053 (encode (apply #'encoded-values
1054 :opcode opcode
1055 :displacement (encode-integer offset type)
1056 extras)))))
1057 (assert (= code-size (length code)))
1058 (append extra-prefixes code))))))))))
1059
1060 (defmacro pc-rel (opcode operand type &rest extras)
1061 `(progn
1062 (assembler
1063 (return-when (encode-pc-rel operator legacy-prefixes ,opcode ,operand ',type ,@extras)))
1064 (disassembler
1065 (define-disassembler (operator ,opcode operator-mode)
1066 decode-pc-rel
1067 ',type))))
1068
1069 (defmacro modrm (operand opcode digit)
1070 `(progn
1071 (assembler
1072 (when (typep ,operand '(or register-operand indirect-operand))
1073 (return-values-when
1074 (merge-encodings (encoded-values :opcode ,opcode
1075 :reg ,digit
1076 :operand-size operator-mode
1077 :rex default-rex)
1078 (encode-reg/mem ,operand operator-mode)))))
1079 (disassembler
1080 (define-disassembler (operator ,opcode operator-mode ,digit) decode-modrm))))
1081
1082 (defun encode-reg-modrm (operator legacy-prefixes op-reg op-modrm opcode operator-mode default-rex &optional reg/mem-mode &rest extras)
1083 (let* ((reg-map (ecase operator-mode
1084 (:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh))
1085 (:16-bit '(:ax :cx :dx :bx :sp :bp :si :di))
1086 (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi))
1087 (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15))
1088 (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7 :mm8))
1089 (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7))))
1090 (reg-index (position op-reg reg-map)))
1091 (when reg-index
1092 (encode (merge-encodings (apply #'encoded-values
1093 :opcode opcode
1094 :reg reg-index
1095 :operand-size operator-mode
1096 :rex default-rex
1097 extras)
1098 (encode-reg/mem op-modrm (or reg/mem-mode operator-mode)))))))
1099
1100 (defmacro reg-modrm (op-reg op-modrm opcode &optional reg/mem-mode &rest extras)
1101 `(progn
1102 (assembler
1103 (return-when (encode-reg-modrm operator legacy-prefixes ,op-reg ,op-modrm ,opcode
1104 operator-mode default-rex ,reg/mem-mode ,@extras)))
1105 (disassembler
1106 (define-disassembler (operator ,opcode operator-mode)
1107 decode-reg-modrm
1108 (operand-ordering operand-formals
1109 :reg ',op-reg
1110 :modrm ',op-modrm)))))
1111
1112 (defun encode-reg-cr (operator legacy-prefixes op-reg op-cr opcode operator-mode default-rex &rest extras)
1113 (let* ((reg-map (ecase operator-mode
1114 (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi))
1115 (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15))))
1116 (reg-index (position op-reg reg-map))
1117 (cr-index (position op-cr '(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7))))
1118 (when (and reg-index
1119 cr-index)
1120 (encode (apply #'encoded-values
1121 :opcode opcode
1122 :mod #b11
1123 :rm reg-index
1124 :reg cr-index
1125 :operand-size (if (not (eq *cpu-mode* :64-bit))
1126 nil
1127 operator-mode)
1128 :rex default-rex
1129 extras)))))
1130
1131 (defmacro reg-cr (op-reg op-cr opcode &rest extras)
1132 `(return-when (encode-reg-cr operator legacy-prefixes ,op-reg ,op-cr ,opcode operator-mode default-rex ,@extras)))
1133
1134 (defmacro sreg-modrm (op-sreg op-modrm opcode)
1135 `(let* ((reg-map '(:es :cs :ss :ds :fs :gs))
1136 (reg-index (position ,op-sreg reg-map)))
1137 (when reg-index
1138 (return-values-when
1139 (merge-encodings (encoded-values :opcode ,opcode
1140 :reg reg-index
1141 :rex default-rex)
1142 (encode-reg/mem ,op-modrm operator-mode))))))
1143
1144 (defmacro moffset (opcode op-offset type fixed-operand)
1145 `(progn
1146 (assembler
1147 (when (and ,@(when fixed-operand
1148 `((eql ,@fixed-operand)))
1149 (indirect-operand-p ,op-offset))
1150 (multiple-value-bind (reg offsets reg2)
1151 (parse-indirect-operand ,op-offset)
1152 (when (and (not reg)
1153 (not reg2))
1154 (return-values-when
1155 (encoded-values :opcode ,opcode
1156 :displacement (encode-integer (reduce #'+ offsets
1157 :key #'resolve-operand)
1158 ',type)))))))
1159 (disassembler
1160 (define-disassembler (operator ,opcode operator-mode)
1161 decode-moffset
1162 ',type
1163 (operand-ordering operand-formals
1164 :moffset ',op-offset
1165 :fixed ',(first fixed-operand))
1166 ',(second fixed-operand)))))
1167
1168
1169
1170 (defmacro opcode (opcode &optional fixed-operand &rest extras)
1171 `(progn
1172 (assembler
1173 (when (and ,@(when fixed-operand
1174 `((eql ,@fixed-operand))))
1175 (return-values-when
1176 (encoded-values :opcode ,opcode
1177 ,@extras
1178 :operand-size operator-mode))))
1179 (disassembler
1180 (define-disassembler (operator ,opcode)
1181 decode-no-operands
1182 ,(second fixed-operand)))))
1183
1184 (defmacro opcode* (opcode &rest extras)
1185 `(return-values-when
1186 (encoded-values :opcode ,opcode
1187 ,@extras)))
1188
1189 (defun encode-opcode-reg (operator legacy-prefixes opcode op-reg operator-mode default-rex)
1190 (let* ((reg-map (ecase operator-mode
1191 (:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh))
1192 (:16-bit '(:ax :cx :dx :bx :sp :bp :si :di))
1193 (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi))
1194 (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15))
1195 (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7 :mm8))
1196 (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7))))
1197 (reg-index (position op-reg reg-map)))
1198 (when reg-index
1199 (encode (encoded-values :opcode (+ opcode (ldb (byte 3 0) reg-index))
1200 :operand-size operator-mode
1201 :rex (cond
1202 ((>= reg-index 8)
1203 (assert (eq :64-bit operator-mode))
1204 '(:rex.w :rex.r))
1205 (t default-rex)))))))
1206
1207 (defmacro opcode-reg (opcode op-reg &optional extra-operand)
1208 `(progn
1209 (assembler
1210 (when (and ,@(when extra-operand
1211 `((eql ,@extra-operand))))
1212 (return-when
1213 (encode-opcode-reg operator legacy-prefixes ,opcode ,op-reg operator-mode default-rex))))
1214 (disassembler
1215 (loop for reg from #b000 to #b111
1216 do ,(if (not extra-operand)
1217 `(define-disassembler (operator (logior ,opcode reg) operator-mode)
1218 decode-opcode-reg
1219 '(:reg)
1220 nil)
1221 `(define-disassembler (operator (logior ,opcode reg) operator-mode)
1222 decode-opcode-reg
1223 (operand-ordering operand-formals
1224 :reg ',op-reg
1225 :extra ',(first extra-operand))
1226 ',(second extra-operand)))))))
1227
1228 (defun encode-opcode-reg-imm (operator legacy-prefixes opcode op-reg op-imm type operator-mode default-rex)
1229 (when (immediate-p op-imm)
1230 (let ((immediate (resolve-operand op-imm)))
1231 (when (typep immediate type)
1232 (let* ((reg-map (ecase operator-mode
1233 (:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh))
1234 (:16-bit '(:ax :cx :dx :bx :sp :bp :si :di))
1235 (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi))
1236 (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15))
1237 (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7 :mm8))
1238 (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7))))
1239 (reg-index (position op-reg reg-map)))
1240 (when reg-index
1241 (encode (encoded-values :opcode (+ opcode (ldb (byte 3 0) reg-index))
1242 :operand-size operator-mode
1243 :immediate (encode-integer immediate type)
1244 :rex (cond
1245 ((>= reg-index 8)
1246 (assert (eq :64-bit operator-mode))
1247 '(:rex.w :rex.r))
1248 (t default-rex))))))))))
1249
1250 (defmacro opcode-reg-imm (opcode op-reg op-imm type)
1251 `(return-when
1252 (encode-opcode-reg-imm operator legacy-prefixes ,opcode ,op-reg ,op-imm ',type operator-mode default-rex)))
1253
1254 (defmacro far-pointer (opcode segment offset offset-type &rest extra)
1255 `(when (and (immediate-p ,segment)
1256 (indirect-operand-p ,offset)); FIXME: should be immediate-p, change in bootblock.lisp.
1257 (let ((segment (resolve-operand ,segment))
1258 (offset (resolve-operand (car ,offset))))
1259 (when (and (typep segment '(uint 16))
1260 (typep offset ',offset-type))
1261 (return-when (encode (encoded-values :opcode ,opcode
1262 :immediate (append (encode-integer offset ',offset-type)
1263 (encode-integer segment '(uint 16)))
1264 ,@extra)))))))
1265
1266
1267 ;;;;;;;;;;; Pseudo-instructions
1268
1269 (define-operator/none :% (op &rest form)
1270 (case op
1271 (:bytes
1272 (return-from operator
1273 (destructuring-bind (byte-size &rest data)
1274 form
1275 (loop for datum in data
1276 append (loop for b from 0 below byte-size by 8
1277 collect (ldb (byte 8 b)
1278 (resolve-operand datum)))))))
1279 (:funcall
1280 (return-from operator
1281 (destructuring-bind (function &rest args)
1282 form
1283 (apply function (mapcar #'resolve-operand args)))))
1284 (:fun
1285 (return-from operator
1286 (destructuring-bind (function &rest args)
1287 (car form)
1288 (loop for cbyte in (apply function (mapcar #'resolve-operand args))
1289 append (loop for octet from 0 below (imagpart cbyte)
1290 collect (ldb (byte 8 (* 8 octet))
1291 (realpart cbyte)))))))
1292 (:format
1293 (return-from operator
1294 (destructuring-bind (byte-size format-control &rest format-args)
1295 form
1296 (ecase byte-size
1297 (8 (let ((data (map 'list #'char-code
1298 (apply #'format nil format-control
1299 (mapcar #'resolve-operand format-args)))))
1300 (cons (length data)
1301 data)))))))
1302 (:align
1303 (return-from operator
1304 (destructuring-bind (alignment)
1305 form
1306 (let* ((offset (mod *pc* alignment)))
1307 (when (plusp offset)
1308 (make-list (- alignment offset)
1309 :initial-element 0))))))))
1310
1311 ;;;;;;;;;;; ADC
1312
1313 (define-operator/8 :adcb (src dst)
1314 (imm src #x14 (xint 8) (dst :al))
1315 (imm-modrm src dst #x80 2 (xint 8))
1316 (reg-modrm dst src #x12)
1317 (reg-modrm src dst #x10))
1318
1319 (define-operator* (:16 :adcw :32 :adcl :64 :adcr) (src dst)
1320 (imm-modrm src dst #x83 2 (sint 8))
1321 (imm src #x15 :int-16-32-64 (dst :ax-eax-rax))
1322 (imm-modrm src dst #x81 2 :int-16-32-64)
1323 (reg-modrm dst src #x13)
1324 (reg-modrm src dst #x11))
1325
1326 ;;;;;;;;;;; ADD
1327
1328 (define-operator/8 :addb (src dst)
1329 (imm src #x04 (xint 8) (dst :al))
1330 (imm-modrm src dst #x80 0 (xint 8))
1331 (reg-modrm dst src #x02)
1332 (reg-modrm src dst #x00))
1333
1334 (define-operator* (:16 :addw :32 :addl :64 :addr) (src dst)
1335 (imm-modrm src dst #x83 0 (sint 8))
1336 (imm src #x05 :int-16-32-64 (dst :ax-eax-rax))
1337 (imm-modrm src dst #x81 0 :int-16-32-64)
1338 (reg-modrm dst src #x03)
1339 (reg-modrm src dst #x01))
1340
1341 ;;;;;;;;;;; AND
1342
1343 (define-operator/8 :andb (mask dst)
1344 (imm mask #x24 (xint 8) (dst :al))
1345 (imm-modrm mask dst #x80 4 (xint 8))
1346 (reg-modrm dst mask #x22)
1347 (reg-modrm mask dst #x20))
1348
1349 (define-operator* (:16 :andw :32 :andl :64 :andr) (mask dst)
1350 (imm-modrm mask dst #x83 4 (sint 8))
1351 (imm mask #x25 :int-16-32-64 (dst :ax-eax-rax))
1352 (imm-modrm mask dst #x81 4 :int-16-32-64)
1353 (reg-modrm dst mask #x23)
1354 (reg-modrm mask dst #x21))
1355
1356 ;;;;;;;;;;; BOUND, BSF, BSR, BSWAP
1357
1358 (define-operator* (:16 :boundw :32 :bound) (bounds reg)
1359 (reg-modrm reg bounds #x62))
1360
1361 (define-operator* (:16 :bsfw :32 :bsfl :64 :bsfr) (src dst)
1362 (reg-modrm dst src #x0fbc))
1363
1364 (define-operator* (:16 :bsrw :32 :bsrl :64 :bsrr) (src dst)
1365 (reg-modrm dst src #x0fbd))
1366
1367 (define-operator* (:32 :bswap :64 :bswapr) (dst)
1368 (opcode-reg #x0fc8 dst))
1369
1370 ;;;;;;;;;;; BT, BTC, BTR, BTS
1371
1372 (define-operator* (:16 :btw :32 :btl :64 :btr) (bit src)
1373 (imm-modrm bit src #x0fba 4 (uint 8))
1374 (reg-modrm bit src #x0fa3))
1375
1376 (define-operator* (:16 :btcw :32 :btcl :64 :btcr) (bit src)
1377 (imm-modrm bit src #x0fba 7 (uint 8))
1378 (reg-modrm bit src #x0fbb))
1379
1380 (define-operator* (:16 :btrw :32 :btrl :64 :btrr) (bit src)
1381 (imm-modrm bit src #x0fba 6 (uint 8))
1382 (reg-modrm bit src #x0fb3))
1383
1384 (define-operator* (:16 :btsw :32 :btsl :64 :btsr) (bit src)
1385 (imm-modrm bit src #x0fba 5 (uint 8))
1386 (reg-modrm bit src #x0fab))
1387
1388 ;;;;;;;;;;; CALL
1389
1390 (define-operator/16 :callw (dest)
1391 (pc-rel #xe8 dest (sint 16))
1392 (modrm dest #xff 2))
1393
1394 (define-operator/32 :call (dest)
1395 (pc-rel #xe8 dest (sint 32))
1396 (modrm dest #xff 2))
1397
1398 (define-operator/none :call-segment (dest)
1399 (modrm dest #xff 3))
1400
1401 ;;;;;;;;;;; CLC, CLD, CLI, CLTS, CMC
1402
1403 (define-operator/none :clc () (opcode #xf8))
1404 (define-operator/none :cld () (opcode #xfc))
1405 (define-operator/none :cli () (opcode #xfa))
1406 (define-operator/none :clts () (opcode #x0f06))
1407 (define-operator/none :cmc () (opcode #xf5))
1408
1409 ;;;;;;;;;;; CMOVcc
1410
1411 (define-operator* (:16 :cmovaw :32 :cmova :64 :cmovar) (src dst)
1412 (reg-modrm dst src #x0f47)) ; Move if above, CF=0 and ZF=0.
1413
1414 (define-operator* (:16 :cmovaew :32 :cmovae :64 :cmovaer) (src dst)
1415 (reg-modrm dst src #x0f43)) ; Move if above or equal, CF=0.
1416
1417 (define-operator* (:16 :cmovbw :32 :cmovb :64 :cmovbr) (src dst)
1418 (reg-modrm dst src #x0f42)) ; Move if below, CF=1.
1419
1420 (define-operator* (:16 :cmovbew :32 :cmovbe :64 :cmovber) (src dst)
1421 (reg-modrm dst src #x0f46)) ; Move if below or equal, CF=1 or ZF=1.
1422
1423 (define-operator* (:16 :cmovcw :32 :cmovc :64 :cmovcr) (src dst)
1424 (reg-modrm dst src #x0f42)) ; Move if carry, CF=1.
1425
1426 (define-operator* (:16 :cmovew :32 :cmove :64 :cmover) (src dst)
1427 (reg-modrm dst src #x0f44)) ; Move if equal, ZF=1.
1428
1429 (define-operator* (:16 :cmovgw :32 :cmovg :64 :cmovgr) (src dst)
1430 (reg-modrm dst src #x0f4f)) ; Move if greater, ZF=0 and SF=OF.
1431
1432 (define-operator* (:16 :cmovgew :32 :cmovge :64 :cmovger) (src dst)
1433 (reg-modrm dst src #x0f4d)) ; Move if greater or equal, SF=OF.
1434
1435 (define-operator* (:16 :cmovlw :32 :cmovl :64 :cmovlr) (src dst)
1436 (reg-modrm dst src #x0f4c))
1437
1438 (define-operator* (:16 :cmovlew :32 :cmovle :64 :cmovler) (src dst)
1439 (reg-modrm dst src #x0f4e)) ; Move if less or equal, ZF=1 or SF/=OF.
1440
1441 (define-operator* (:16 :cmovnaw :32 :cmovna :64 :cmovnar) (src dst)
1442 (reg-modrm dst src #x0f46)) ; Move if not above, CF=1 or ZF=1.
1443
1444 (define-operator* (:16 :cmovnaew :32 :cmovnae :64 :cmovnaer) (src dst)
1445 (reg-modrm dst src #x0f42)) ; Move if not above or equal, CF=1.
1446
1447 (define-operator* (:16 :cmovnbw :32 :cmovnb :64 :cmovnbr) (src dst)
1448 (reg-modrm dst src #x0f43)) ; Move if not below, CF=0.
1449
1450 (define-operator* (:16 :cmovnbew :32 :cmovnbe :64 :cmovnber) (src dst)
1451 (reg-modrm dst src #x0f47)) ; Move if not below or equal, CF=0 and ZF=0.
1452
1453 (define-operator* (:16 :cmovncw :32 :cmovnc :64 :cmovncr) (src dst)
1454 (reg-modrm dst src #x0f43)) ; Move if not carry, CF=0.
1455
1456 (define-operator* (:16 :cmovnew :32 :cmovne :64 :cmovner) (src dst)
1457 (reg-modrm dst src #x0f45)) ; Move if not equal, ZF=0.
1458
1459 (define-operator* (:16 :cmovngew :32 :cmovnge :64 :cmovnger) (src dst)
1460 (reg-modrm dst src #x0f4c)) ; Move if not greater or equal, SF/=OF.
1461
1462 (define-operator* (:16 :cmovnlw :32 :cmovnl :64 :cmovnlr) (src dst)
1463 (reg-modrm dst src #x0f4d)) ; Move if not less SF=OF.
1464
1465 (define-operator* (:16 :cmovnlew :32 :cmovnle :64 :cmovnler) (src dst)
1466 (reg-modrm dst src #x0f4f)) ; Move if not less or equal, ZF=0 and SF=OF.
1467
1468 (define-operator* (:16 :cmovnow :32 :cmovno :64 :cmovnor) (src dst)
1469 (reg-modrm dst src #x0f41)) ; Move if not overflow, OF=0.
1470
1471 (define-operator* (:16 :cmovnpw :32 :cmovnp :64 :cmovnpr) (src dst)
1472 (reg-modrm dst src #x0f4b)) ; Move if not parity, PF=0.
1473
1474 (define-operator* (:16 :cmovnsw :32 :cmovns :64 :cmovnsr) (src dst)
1475 (reg-modrm dst src #x0f49)) ; Move if not sign, SF=0.
1476
1477 (define-operator* (:16 :cmovnzw :32 :cmovnz :64 :cmovnzr) (src dst)
1478 (reg-modrm dst src #x0f45)) ; Move if not zero, ZF=0.
1479
1480 (define-operator* (:16 :cmovow :32 :cmovo :64 :cmovor) (src dst)
1481 (reg-modrm dst src #x0f40)) ; Move if overflow, OF=1.
1482
1483 (define-operator* (:16 :cmovpw :32 :cmovp :64 :cmovpr) (src dst)
1484 (reg-modrm dst src #x0f4a)) ; Move if parity, PF=1.
1485
1486 (define-operator* (:16 :cmovsw :32 :cmovs :64 :cmovsr) (src dst)
1487 (reg-modrm dst src #x0f48)) ; Move if sign, SF=1
1488
1489 (define-operator* (:16 :cmovzw :32 :cmovz :64 :cmovzr) (src dst)
1490 (reg-modrm dst src #x0f44)) ; Move if zero, ZF=1
1491
1492 ;;;;;;;;;;; CMP
1493
1494 (define-operator/8 :cmpb (src dst)
1495 (imm src #x3c (xint 8) (dst :al))
1496 (imm-modrm src dst #x80 7 (xint 8))
1497 (reg-modrm dst src #x3a)
1498 (reg-modrm src dst #x38))
1499
1500 (define-operator* (:16 :cmpw :32 :cmpl :64 :cmpr) (src dst)
1501 (imm-modrm src dst #x83 7 (sint 8))
1502 (imm src #x3d :int-16-32-64 (dst :ax-eax-rax))
1503 (imm-modrm src dst #x81 7 :int-16-32-64)
1504 (reg-modrm dst src #x3b)
1505 (reg-modrm src dst #x39))
1506
1507 ;;;;;;;;;;; CMPXCHG
1508
1509 (define-operator/8 :cmpxchgb (cmp-reg cmp-modrm al-dst)
1510 (when (eq al-dst :al)
1511 (reg-modrm cmp-reg cmp-modrm #x0fb0)))
1512
1513 (define-operator* (:16 :cmpxchgw :32 :cmpxchgl :64 :cmpxchgr) (cmp-reg cmp-modrm al-dst)
1514 (when (eq al-dst :ax-eax-rax)
1515 (reg-modrm cmp-reg cmp-modrm #x0fb1)))
1516
1517 ;;;;;;;;;;; CMPXCHG8B, CMPXCHG16B
1518
1519 (define-operator/32 :cmpxchg8b (address)
1520 (modrm address #x0fc7 1))
1521
1522 (define-operator/64 :cmpxchg16b (address)
1523 (modrm address #x0fc7 1))
1524
1525 ;;;;;;;;;;; CPUID
1526
1527 (define-operator/none :cpuid ()
1528 (opcode* #x0fa2))
1529
1530 ;;;;;;;;;;; CWD, CDQ
1531
1532 (define-operator/16 :cwd (reg1 reg2)
1533 (when (and (eq reg1 :ax)
1534 (eq reg2 :dx))
1535 (opcode #x99)))
1536
1537 (define-operator/32 :cdq (reg1 reg2)
1538 (when (and (eq reg1 :eax)
1539 (eq reg2 :edx))
1540 (opcode #x99)))
1541
1542 (define-operator/64 :cqo (reg1 reg2)
1543 (when (and (eq reg1 :rax)
1544 (eq reg2 :rdx))
1545 (opcode #x99)))
1546
1547 ;;;;;;;;;;; DEC
1548
1549 (define-operator/8 :decb (dst)
1550 (modrm dst #xfe 1))
1551
1552 (define-operator* (:16 :decw :32 :decl) (dst)
1553 (unless (eq *cpu-mode* :64-bit)
1554 (opcode-reg #x48 dst))
1555 (modrm dst #xff 1))
1556
1557 (define-operator* (:64 :decr) (dst)
1558 (modrm dst #xff 1))
1559
1560 ;;;;;;;;;;; DIV
1561
1562 (define-operator/8 :divb (divisor dividend)
1563 (when (eq dividend :ax)
1564 (modrm divisor #xf6 6)))
1565
1566 (define-operator* (:16 :divw :32 :divl :64 :divr) (divisor dividend1 dividend2)
1567 (when (and (eq dividend1 :ax-eax-rax)
1568 (eq dividend2 :dx-edx-rdx))
1569 (modrm divisor #xf7 6)))
1570
1571 ;;;;;;;;;;; HLT
1572
1573 (define-operator/none :halt ()
1574 (opcode #xf4))
1575
1576 ;;;;;;;;;;; IDIV
1577
1578 (define-operator/8 :idivb (divisor dividend1 dividend2)
1579 (when (and (eq dividend1 :al)
1580 (eq dividend2 :ah))
1581 (modrm divisor #xf6 7)))
1582
1583 (define-operator* (:16 :idivw :32 :idivl :64 :idivr) (divisor dividend1 dividend2)
1584 (when (and (eq dividend1 :ax-eax-rax)
1585 (eq dividend2 :dx-edx-rdx))
1586 (modrm divisor #xf7 7)))
1587
1588 ;;;;;;;;;;; IMUL
1589
1590 (define-operator/32 :imull (factor product1 &optional product2)
1591 (when (not product2)
1592 (reg-modrm product1 factor #x0faf))
1593 (when (and (eq product1 :eax)
1594 (eq product2 :edx))
1595 (modrm factor #xf7 5))
1596 (typecase factor
1597 ((sint 8)
1598 (reg-modrm product1 product2 #x6b
1599 nil
1600 :displacement (encode-integer factor '(sint 8))))
1601 ((sint 32)
1602 (reg-modrm product1 product2 #x69
1603 nil
1604 :displacement (encode-integer factor '(sint 32))))))
1605
1606 ;;;;;;;;;;; IN
1607
1608 (define-operator/8 :inb (port dst)
1609 (when (eq :al dst)
1610 (typecase port
1611 ((eql :dx)
1612 (opcode #xec))
1613 ((uint 8)
1614 (imm port #xe4 (uint 8) (dst :al))))))
1615
1616 (define-operator/16 :inw (port dst)
1617 (when (eq :ax dst)
1618 (typecase port
1619 ((eql :dx)
1620 (opcode #xed))
1621 ((uint 8)
1622 (imm port #xe5 (uint 8) (dst :ax))))))
1623
1624 (define-operator/32 :inl (port dst)
1625 (when (eq :eax dst)
1626 (typecase port
1627 ((eql :dx)
1628 (opcode #xed))
1629 ((uint 8)
1630 (imm port #xe5 (uint 8) (dst :eax))))))
1631
1632 ;;;;;;;;;;; INC
1633
1634 (define-operator/8 :incb (dst)
1635 (modrm dst #xfe 0))
1636
1637 (define-operator* (:16 :incw :32 :incl) (dst)
1638 (unless (eq *cpu-mode* :64-bit)
1639 (opcode-reg #x40 dst))
1640 (modrm dst #xff 0))
1641
1642 (define-operator* (:64 :incr) (dst)
1643 (modrm dst #xff 0))
1644
1645 ;;;;;;;;;;; INT
1646
1647 (define-operator/none :break ()
1648 (opcode #xcc))
1649
1650 (define-operator/none :int (vector)
1651 (imm vector #xcd (uint 8)))
1652
1653 (define-operator/none :into ()
1654 (opcode #xce))
1655
1656 ;;;;;;;;;;; INVLPG
1657
1658 (define-operator/none :invlpg (address)
1659 (modrm address #x0f01 7))
1660
1661 ;;;;;;;;;;; IRET
1662
1663 (define-operator* (:16 :iret :32 :iretd :64 :iretq) ()
1664 (opcode #xcf () :rex default-rex))
1665
1666 ;;;;;;;;;;; Jcc
1667
1668 (defmacro define-jcc (name opcode1 &optional (opcode2 (+ #x0f10 opcode1)))
1669 `(define-operator/none ,name (dst)
1670 (pc-rel ,opcode1 dst (sint 8))
1671 (when (or (and (eq *cpu-mode* :32-bit)
1672 *use-jcc-16-bit-p*)
1673 (eq *cpu-mode* :16-bit))
1674 (pc-rel ,opcode2 dst (sint 16)
1675 :operand-size :16-bit))
1676 (pc-rel ,opcode2 dst (sint 32)
1677 :operand-size (case *cpu-mode*
1678 ((:16-bit :32-bit)
1679 :32-bit)))))
1680
1681 (define-jcc :ja #x77)
1682 (define-jcc :jae #x73)
1683 (define-jcc :jb #x72)
1684 (define-jcc :jbe #x76)
1685 (define-jcc :jc #x72)
1686 (define-jcc :jecx #xe3)
1687 (define-jcc :je #x74)
1688 (define-jcc :jg #x7f)
1689 (define-jcc :jge #x7d)
1690 (define-jcc :jl #x7c)
1691 (define-jcc :jle #x7e)
1692 (define-jcc :jna #x76)
1693 (define-jcc :jnae #x72)
1694 (define-jcc :jnb #x73)
1695 (define-jcc :jnbe #x77)
1696 (define-jcc :jnc #x73)
1697 (define-jcc :jne #x75)
1698 (define-jcc :jng #x7e)
1699 (define-jcc :jnge #x7c)
1700 (define-jcc :jnl #x7d)
1701 (define-jcc :jnle #x7f)
1702 (define-jcc :jno #x71)
1703 (define-jcc :jnp #x7b)
1704 (define-jcc :jns #x79)
1705 (define-jcc :jnz #x75)
1706 (define-jcc :jo #x70)
1707 (define-jcc :jp #x7a)
1708 (define-jcc :jpe #x7a)
1709 (define-jcc :jpo #x7b)
1710 (define-jcc :js #x78)
1711 (define-jcc :jz #x74)
1712
1713 (define-operator* (:16 :jcxz :32 :jecxz :64 :jrcxz) (dst)
1714 (pc-rel #xe3 dst (sint 8)
1715 :operand-size operator-mode
1716 :rex default-rex))
1717
1718 ;;;;;;;;;;; JMP
1719
1720 (define-operator/none :jmp (seg-dst &optional dst)
1721 (cond
1722 (dst
1723 (when (eq *cpu-mode* :16-bit)
1724 (far-pointer #xea seg-dst dst (uint 16)))
1725 (when (eq *cpu-mode* :32-bit)
1726 (far-pointer #xea seg-dst dst (xint 32))))
1727 (t (let ((dst seg-dst))
1728 (pc-rel #xeb dst (sint 8))
1729 (when (or (and (eq *cpu-mode* :32-bit)
1730 *use-jcc-16-bit-p*)
1731 (eq *cpu-mode* :16-bit))
1732 (pc-rel #xe9 dst (sint 16)))
1733 (pc-rel #xe9 dst (sint 32))
1734 (when (or (not *position-independent-p*)
1735 (indirect-operand-p dst))
1736 (let ((operator-mode :32-bit))
1737 (modrm dst #xff 4)))))))
1738
1739 (define-operator* (:16 :jmpw-segment :32 :jmp-segment :64 :jmpr-segment) (addr)
1740 (modrm addr #xff 5))
1741
1742 ;;;;;;;;;;; LAHF, LAR
1743
1744 (define-operator/none :lahf ()
1745 (case *cpu-mode*
1746 ((:16-bit :32-bit)
1747 (opcode #x9f))))
1748
1749 (define-operator* (:16 :larw :32 :larl :64 :larr) (src dst)
1750 (reg-modrm dst src #x0f02))
1751
1752 ;;;;;;;;;;; LEA
1753
1754 (define-operator* (:16 :leaw :32 :leal :64 :lear) (addr dst)
1755 (reg-modrm dst addr #x8d))
1756
1757 ;;;;;;;;;;; LEAVE
1758
1759 (define-operator/none :leave ()
1760 (opcode #xc9))
1761
1762 ;;;;;;;;;;; LFENCE
1763
1764 (define-operator/none :lfence ()
1765 (opcode #x0faee8))
1766
1767 ;;;;;;;;;;; LGDT, LIDT
1768
1769 (define-operator* (:16 :lgdtw :32 :lgdtl :64 :lgdtr :dispatch :lgdt) (addr)
1770 (when (eq operator-mode *cpu-mode*)
1771 (modrm addr #x0f01 2)))
1772
1773 (define-operator* (:16 :lidtw :32 :lidt :64 :lidtr) (addr)
1774 (modrm addr #x0f01 3))
1775
1776 ;;;;;;;;;;; LMSW
1777
1778 (define-operator/16 :lmsw (src)
1779 (modrm src #x0f01 6))
1780
1781 ;;;;;;;;;;; LODS
1782
1783 (define-operator/8 :lodsb ()
1784 (opcode #xac))
1785
1786 (define-operator* (:16 :lodsw :32 :lodsl :64 :lodsr) ()
1787 (opcode #xad))
1788
1789 ;;;;;;;;;;; LOOP, LOOPE, LOOPNE
1790
1791 (define-operator/none :loop (dst)
1792 (pc-rel #xe2 dst (sint 8)))
1793
1794 (define-operator/none :loope (dst)
1795 (pc-rel #xe1 dst (sint 8)))
1796
1797 (define-operator/none :loopne (dst)
1798 (pc-rel #xe0 dst (sint 8)))
1799
1800 ;;;;;;;;;;; MOV
1801
1802 (define-operator/8 :movb (src dst)
1803 (moffset #xa2 dst (uint 8) (src :al))
1804 (moffset #xa0 src (uint 8) (dst :al))
1805 (opcode-reg-imm #xb0 dst src (xint 8))
1806 (imm-modrm src dst #xc6 0 (xint 8))
1807 (reg-modrm dst src #x8a)
1808 (reg-modrm src dst #x88))
1809
1810 (define-operator/16 :movw (src dst)
1811 (moffset #xa3 dst (uint 16) (src :ax))
1812 (moffset #xa0 src (uint 16) (dst :ax))
1813 (opcode-reg-imm #xb8 dst src (xint 16))
1814 (imm-modrm src dst #xc7 0 (xint 16))
1815 (sreg-modrm src dst #x8c)
1816 (sreg-modrm dst src #x8e)
1817 (reg-modrm dst src #x8b)
1818 (reg-modrm src dst #x89))
1819
1820 (define-operator/32 :movl (src dst)
1821 (moffset #xa3 dst (uint 32) (src :eax))
1822 (moffset #xa0 src (uint 32) (dst :eax))
1823 (opcode-reg-imm #xb8 dst src (xint 32))
1824 (imm-modrm src dst #xc7 0 (xint 32))
1825 (reg-modrm dst src #x8b)
1826 (reg-modrm src dst #x89))
1827
1828 ;;;;;;;;;;; MOVCR
1829
1830 (define-operator* (:32 :movcrl :64 :movcrr :dispatch :movcr) (src dst)
1831 (when (eq src :cr8)
1832 (reg-cr dst :cr0 #xf00f20
1833 :operand-size nil))
1834 (when (eq dst :cr8)
1835 (reg-cr src :cr0 #xf00f22
1836 :operand-size nil))
1837 (reg-cr src dst #x0f22
1838 :operand-size nil)
1839 (reg-cr dst src #x0f20
1840 :operand-size nil))
1841
1842 ;;;;;;;;;;; MOVS
1843
1844 (define-operator/8 :movsb ()
1845 (opcode #xa4))
1846
1847 (define-operator/16 :movsw ()
1848 (opcode #xa5))
1849
1850 (define-operator/32 :movsl ()
1851 (opcode #xa5))
1852
1853 ;;;;;;;;;;; MOVSX
1854
1855 (define-operator* (:32 :movsxb) (src dst)
1856 (reg-modrm dst src #x0fbe))
1857
1858 (define-operator* (:32 :movsxw) (src dst)
1859 (reg-modrm dst src #x0fbf))
1860
1861 ;;;;;;;;;;; MOVZX
1862
1863 (define-operator* (:16 :movzxbw :32 :movzxbl :dispatch :movzxb) (src dst)
1864 (reg-modrm dst src #x0fb6 :8-bit))
1865
1866 (define-operator* (:32 :movzxw) (src dst)
1867 (reg-modrm dst src #x0fb7))
1868
1869 ;;;;;;;;;;; MUL
1870
1871 (define-operator/32 :mull (factor product1 &optional product2)
1872 (when (and (eq product1 :eax)
1873 (eq product2 :edx))
1874 (modrm factor #xf7 4)))
1875
1876 ;;;;;;;;;;; NEG
1877
1878 (define-operator/8 :negb (dst)
1879 (modrm dst #xf6 3))
1880
1881 (define-operator* (:16 :negw :32 :negl :64 :negr) (dst)
1882 (modrm dst #xf7 3))
1883
1884 ;;;;;;;;;;; NOT
1885
1886 (define-operator/8 :notb (dst)
1887 (modrm dst #xf6 2))
1888
1889 (define-operator* (:16 :notw :32 :notl :64 :notr) (dst)
1890 (modrm dst #xf7 2))
1891
1892 ;;;;;;;;;;; OR
1893
1894 (define-operator/8 :orb (src dst)
1895 (imm src #x0c (xint 8) (dst :al))
1896 (imm-modrm src dst #x80 1 (xint 8))
1897 (reg-modrm dst src #x0a)
1898 (reg-modrm src dst #x08))
1899
1900 (define-operator* (:16 :orw :32 :orl :64 :orr) (src dst)
1901 (imm-modrm src dst #x83 1 (sint 8))
1902 (imm src #x0d :int-16-32-64 (dst :ax-eax-rax))
1903 (imm-modrm src dst #x81 1 :int-16-32-64)
1904 (reg-modrm dst src #x0b)
1905 (reg-modrm src dst #x09))
1906
1907 ;;;;;;;;;;; OUT
1908
1909 (define-operator/8 :outb (src port)
1910 (when (eq :al src)
1911 (typecase port
1912 ((eql :dx)
1913 (opcode #xee))
1914 ((uint 8)
1915 (imm port #xe6 (uint 8) (src :al))))))
1916
1917 (define-operator/16 :outw (src port)
1918 (when (eq :ax src)
1919 (typecase port
1920 ((eql :dx)
1921 (opcode #xef))
1922 ((uint 8)
1923 (imm port #xe7 (uint 8) (src :ax))))))
1924
1925 (define-operator/32 :outl (src port)
1926 (when (eq :eax src)
1927 (typecase port
1928 ((eql :dx)
1929 (opcode #xef))
1930 ((uint 8)
1931 (imm port #xe7 (uint 8) (src :eax))))))
1932
1933 ;;;;;;;;;;; POP
1934
1935 (define-operator* (:16 :popw :32 :popl) (dst)
1936 (opcode #x1f (dst :ds))
1937 (opcode #x07 (dst :es))
1938 (opcode #x17 (dst :ss))
1939 (opcode #x0fa1 (dst :fs))
1940 (opcode #x0fa9 (dst :gs))
1941 (opcode-reg #x58 dst)
1942 (modrm dst #x8f 0))
1943
1944 (define-operator/64* :popr (dst)
1945 (opcode-reg #x58 dst)
1946 (modrm dst #x8f 0))
1947
1948 ;;;;;;;;;;; POPF
1949
1950 (define-operator* (:16 :popfw :32 :popfl :64 :popfr) ()
1951 (opcode #x9d))
1952
1953 ;;;;;;;;;;; PRFETCH
1954
1955 (define-operator/none :prefetch-nta (m8)
1956 (modrm m8 #x0f18 0))
1957
1958 (define-operator/none :prefetch-t0 (m8)
1959 (modrm m8 #x0f18 1))
1960
1961 (define-operator/none :prefetch-t1 (m8)
1962 (modrm m8 #x0f18 2))
1963
1964 (define-operator/none :prefetch-t2 (m8)
1965 (modrm m8 #x0f18 3))
1966
1967 ;;;;;;;;;;; PUSH
1968
1969 (define-operator* (:16 :pushw :32 :pushl) (src)
1970 (opcode #x0e (src :cs))
1971 (opcode #x16 (src :ss))
1972 (opcode #x1e (src :ds))
1973 (opcode #x06 (src :es))
1974 (opcode #x0fa0 (src :fs))
1975 (opcode #x0fa8 (src :gs))
1976 (opcode-reg #x50 src)
1977 (imm src #x6a (sint 8))
1978 (imm src #x68 :int-16-32-64 () :operand-size operator-mode)
1979 (modrm src #xff 6))
1980
1981 (define-operator/64* :pushr (src)
1982 (opcode-reg #x50 src)
1983 (imm src #x6a (sint 8))
1984 (imm src #x68 (sint 16) () :operand-size :16-bit)
1985 (imm src #x68 (sint 32))
1986 (modrm src #xff 6))
1987
1988 ;;;;;;;;;;; PUSHF
1989
1990 (define-operator* (:16 :pushfw :32 :pushfl :64 :pushfr) ()
1991 (opcode #x9c))
1992
1993 ;;;;;;;;;;; RDTSC
1994
1995 (define-operator/none :rdtsc ()
1996 (opcode #x0f31))
1997
1998 ;;;;;;;;;;; RET
1999
2000 (define-operator/none :ret ()
2001 (opcode #xc3))
2002
2003 ;;;;;;;;;;; SAR
2004
2005 (define-operator/8 :sarb (count dst)
2006 (case count
2007 (1 (modrm dst #xd0 7))
2008 (:cl (modrm dst #xd2 7)))
2009 (imm-modrm count dst #xc0 7 (uint 8)))
2010
2011 (define-operator* (:16 :sarw :32 :sarl :64 :sarr) (count dst)
2012 (case count
2013 (1 (modrm dst #xd1 7))
2014 (:cl (modrm dst #xd3 7)))
2015 (imm-modrm count dst #xc1 7 (uint 8)))
2016
2017 ;;;;;;;;;;; SBB
2018
2019 (define-operator/8 :sbbb (subtrahend dst)
2020 (imm subtrahend #x1c (xint 8) (dst :al))
2021 (imm-modrm subtrahend dst #x80 3 (xint 8))
2022 (reg-modrm dst subtrahend #x1a)
2023 (reg-modrm subtrahend dst #x18))
2024
2025 (define-operator* (:16 :sbbw :32 :sbbl :64 :sbbr) (subtrahend dst)
2026 (imm-modrm subtrahend dst #x83 3 (sint 8))
2027 (imm subtrahend #x1d :int-16-32-64 (dst :ax-eax-rax))
2028 (imm-modrm subtrahend dst #x81 3 :int-16-32-64)
2029 (reg-modrm dst subtrahend #x1b)
2030 (reg-modrm subtrahend dst #x19))
2031
2032 ;;;;;;;;;;; SGDT
2033
2034 (define-operator/8 :sgdt (addr)
2035 (modrm addr #x0f01 0))
2036
2037 ;;;;;;;;;;; SHL
2038
2039 (define-operator/8 :shlb (count dst)
2040 (case count
2041 (1 (modrm dst #xd0 4))
2042 (:cl (modrm dst #xd2 4)))
2043 (imm-modrm count dst #xc0 4 (uint 8)))
2044
2045 (define-operator* (:16 :shlw :32 :shll :64 :shlr) (count dst)
2046 (case count
2047 (1 (modrm dst #xd1 4))
2048 (:cl (modrm dst #xd3 4)))
2049 (imm-modrm count dst #xc1 4 (uint 8)))
2050
2051 ;;;;;;;;;;; SHLD
2052
2053 (define-operator* (:16 :shldw :32 :shldl :64 :shldr) (count dst1 dst2)
2054 (when (eq :cl count)
2055 (reg-modrm dst1 dst2 #x0fa5))
2056 (when (immediate-p count)
2057 (let ((immediate (resolve-operand count)))
2058 (when (typep immediate '(uint #x8))
2059 (reg-modrm dst1 dst2 #x0fa4
2060 nil
2061 :immediate (encode-integer count '(uint 8)))))))
2062
2063 ;;;;;;;;;;; SHR
2064
2065 (define-operator/8 :shrb (count dst)
2066 (case count
2067 (1 (modrm dst #xd0 5))
2068 (:cl (modrm dst #xd2 5)))
2069 (imm-modrm count dst #xc0 5 (uint 8)))
2070
2071 (define-operator* (:16 :shrw :32 :shrl :64 :shrr) (count dst)
2072 (case count
2073 (1 (modrm dst #xd1 5))
2074 (:cl (modrm dst #xd3 5)))
2075 (imm-modrm count dst #xc1 5 (uint 8)))
2076
2077 ;;;;;;;;;;; SHRD
2078
2079 (define-operator* (:16 :shrdw :32 :shrdl :64 :shrdr) (count dst1 dst2)
2080 (when (eq :cl count)
2081 (reg-modrm dst1 dst2 #x0fad))
2082 (when (immediate-p count)
2083 (let ((immediate (resolve-operand count)))
2084 (when (typep immediate '(uint #x8))
2085 (reg-modrm dst1 dst2 #x0fac
2086 nil
2087 :immediate (encode-integer count '(uint 8)))))))
2088
2089
2090 ;;;;;;;;;;; STC, STD, STI
2091
2092 (define-operator/none :stc ()
2093 (opcode #xf9))
2094
2095 (define-operator/none :std ()
2096 (opcode #xfd))
2097
2098 (define-operator/none :sti ()
2099 (opcode #xfb))
2100
2101 ;;;;;;;;;;; SUB
2102
2103 (define-operator/8 :subb (subtrahend dst)
2104 (imm subtrahend #x2c (xint 8) (dst :al))
2105 (imm-modrm subtrahend dst #x80 5 (xint 8))
2106 (reg-modrm dst subtrahend #x2a)
2107 (reg-modrm subtrahend dst #x28))
2108
2109 (define-operator* (:16 :subw :32 :subl :64 :subr) (subtrahend dst)
2110 (imm-modrm subtrahend dst #x83 5 (sint 8))
2111 (imm subtrahend #x2d :int-16-32-64 (dst :ax-eax-rax))
2112 (imm-modrm subtrahend dst #x81 5 :int-16-32-64)
2113 (reg-modrm dst subtrahend #x2b)
2114 (reg-modrm subtrahend dst #x29))
2115
2116 ;;;;;;;;;;; TEST
2117
2118 (define-operator/8 :testb (mask dst)
2119 (imm mask #xa8 (xint 8) (dst :al))
2120 (imm-modrm mask dst #xf6 0 (xint 8))
2121 (reg-modrm mask dst #x84))
2122
2123 (define-operator* (:16 :testw :32 :testl :64 :testr) (mask dst)
2124 (imm mask #xa9 :int-16-32-64 (dst :ax-eax-rax))
2125 (imm-modrm mask dst #xf7 0 :int-16-32-64)
2126 (reg-modrm mask dst #x85))
2127
2128 ;;;;;;;;;;; WBINVD, WSRMSR
2129
2130 (define-operator/none :wbinvd ()
2131 (opcode #x0f09))
2132
2133 (define-operator/none :wrmsr ()
2134 (opcode #x0f30))
2135
2136 ;;;;;;;;;;; XCHG
2137
2138 (define-operator/8 :xchgb (x y)
2139 (reg-modrm y x #x86)
2140 (reg-modrm x y #x86))
2141
2142 (define-operator* (:16 :xchgw :32 :xchgl :64 :xchgr) (x y)
2143 (opcode-reg #x90 x (y :ax-eax-rax))
2144 (opcode-reg #x90 y (x :ax-eax-rax))
2145 (reg-modrm x y #x87)
2146 (reg-modrm y x #x87))
2147
2148 ;;;;;;;;;;; XOR
2149
2150 (define-operator/8 :xorb (src dst)
2151 (imm src #x34 (xint 8) (dst :al))
2152 (imm-modrm src dst #x80 6 (xint 8))
2153 (reg-modrm dst src #x32)
2154 (reg-modrm src dst #x30))
2155
2156 (define-operator* (:16 :xorw :32 :xorl :64 :xorr) (src dst)
2157 (imm-modrm src dst #x83 6 (sint 8))
2158 (imm src #x35 :int-16-32-64 (dst :ax-eax-rax))
2159 (imm-modrm src dst #x81 6 :int-16-32-64)
2160 (reg-modrm dst src #x33)
2161 (reg-modrm src dst #x31))
2162
2163 ;;;;;;;;;;;;;;;; NOP
2164
2165 (define-operator/none :nop ()
2166 (opcode #x90))
2167
git repository of the movitz source code