?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Use the new disassembler.
[movitz-core.git] / asm-x86.lisp
blob75e938e219c41333f01c707a2b217c2bb4729a5c
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.29 2008/02/18 22:30:47 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* 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 nil digit-p)) lambda-list &body body)
316 (cond
317 (digit-p
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) ,lambda-list ,@body))))
325 ((symbolp lambda-list)
326 `(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,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 ,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* ((datum (pop-code code))
803 (opcode (logior (ash opcode 8)
804 datum))
805 (decoder (svref table datum)))
806 (typecase decoder
807 ((simple-vector 256)
808 (lookup-decoder decoder opcode))
809 (disassembly-decoder
810 (values decoder
811 opcode))
812 (t (error "No disassembler registered for opcode #x~X." opcode))))))
813 (multiple-value-bind (decoder opcode)
814 (lookup-decoder (ecase (or override-operand-size *cpu-mode*)
815 (:16-bit *opcode-disassemblers-16*)
816 (:32-bit *opcode-disassemblers-32*)
817 (:64-bit *opcode-disassemblers-64*))
818 0)
819 (destructuring-bind (operator operand-size decoder-function &rest extra-args)
820 decoder
821 (values (code-call (apply decoder-function
822 code
823 operator
824 opcode
825 (or operand-size override-operand-size)
826 (or override-address-size *cpu-mode*)
827 rex
828 extra-args))
829 code)))))
830
831 (defun decode-no-operands (code operator opcode operand-size address-size rex &rest fixed-operands)
832 (declare (ignore opcode operand-size address-size rex))
833 (values (list* operator
834 (remove nil fixed-operands))
835 code))
836
837 (defun decode-reg-modrm (code operator opcode operand-size address-size rex operand-ordering)
838 (declare (ignore opcode rex))
839 (values (list* operator
840 (order-operands operand-ordering
841 :reg (nth (ldb (byte 3 3) (car code))
842 (register-set-by-mode operand-size))
843 :modrm (ecase address-size
844 (:32-bit
845 (code-call (decode-reg-modrm-32 code operand-size)))
846 (:16-bit
847 (code-call (decode-reg-modrm-16 code operand-size))))))
848 code))
849
850
851 (defun decode-modrm (code operator opcode operand-size address-size rex)
852 (declare (ignore opcode rex))
853 (values (list operator
854 (ecase address-size
855 (:32-bit
856 (code-call (decode-reg-modrm-32 code operand-size)))
857 (:16-bit
858 (code-call (decode-reg-modrm-16 code operand-size)))))
859 code))
860
861 (defun decode-imm-modrm (code operator opcode operand-size address-size rex imm-type operand-ordering &key fixed-modrm)
862 (declare (ignore opcode rex))
863 (values (list* operator
864 (order-operands operand-ordering
865 :modrm (or fixed-modrm
866 (when (member :modrm operand-ordering)
867 (ecase address-size
868 (:32-bit
869 (code-call (decode-reg-modrm-32 code operand-size)))
870 (:16-bit
871 (code-call (decode-reg-modrm-16 code operand-size))))))
872 :imm (code-call (decode-integer code imm-type))))
873 code))
874
875 (defun decode-pc-rel (code operator opcode operand-size address-size rex type)
876 (declare (ignore opcode operand-size address-size rex))
877 (values (list operator
878 `(:pc+ ,(code-call (decode-integer code type))))
879 code))
880
881 (defun decode-moffset (code operator opcode operand-size address-size rex type operand-ordering fixed-operand)
882 (declare (ignore opcode operand-size address-size rex))
883 (values (list* operator
884 (order-operands operand-ordering
885 :moffset (list (code-call (decode-integer code type)))
886 :fixed fixed-operand))
887 code))
888
889 (defun decode-opcode-reg (code operator opcode operand-size address-size rex operand-ordering extra-operand)
890 (declare (ignore address-size rex))
891 (values (list* operator
892 (order-operands operand-ordering
893 :reg (nth (ldb (byte 3 0) opcode)
894 (register-set-by-mode operand-size))
895 :extra extra-operand))
896 code))
897
898 (defun decode-reg-modrm-16 (code operand-size)
899 (let* ((modrm (pop-code code mod/rm))
900 (mod (ldb (byte 2 6) modrm))
901 (reg (ldb (byte 3 3) modrm))
902 (r/m (ldb (byte 3 0) modrm)))
903 (values (if (= mod #b11)
904 (nth reg (register-set-by-mode operand-size))
905 (flet ((operands (i)
906 (nth i '((:bx :si) (:bx :di) (:bp :si) (:bp :di) (:si) (:di) (:bp) (:bx)))))
907 (ecase mod
908 (#b00
909 (case r/m
910 (#b110 (code-call (decode-integer code '(uint 16))))
911 (t (operands r/m))))
912 (#b01
913 (append (operands r/m)
914 (code-call (decode-integer code '(sint 8)))))
915 (#b10
916 (append (operands r/m)
917 (code-call (decode-integer code '(uint 16))))))))
918 code)))
919
920 (defun decode-reg-modrm-32 (code operand-size)
921 "Return a list of the REG, and the MOD/RM operands."
922 (let* ((modrm (pop-code code mod/rm))
923 (mod (ldb (byte 2 6) modrm))
924 (r/m (ldb (byte 3 0) modrm)))
925 (values (if (= mod #b11)
926 (nth r/m (register-set-by-mode operand-size))
927 (flet ((decode-sib ()
928 (let* ((sib (pop-code code sib))
929 (ss (ldb (byte 2 6) sib))
930 (index (ldb (byte 3 3) sib))
931 (base (ldb (byte 3 0) sib)))
932 (nconc (unless (= index #b100)
933 (let ((index-reg (nth index (register-set-by-mode :32-bit))))
934 (if (= ss #b00)
935 (list index-reg)
936 (list (list index-reg (ash 2 ss))))))
937 (if (/= base #b101)
938 (list (nth base (register-set-by-mode :32-bit)))
939 (ecase mod
940 (#b00 nil)
941 ((#b01 #b10) (list :ebp))))))))
942 (ecase mod
943 (#b00 (case r/m
944 (#b100 (decode-sib))
945 (#b101 (code-call (decode-integer code '(uint 32))))
946 (t (list (nth r/m (register-set-by-mode :32-bit))))))
947 (#b01 (case r/m
948 (#b100 (nconc(decode-sib)
949 (list (code-call (decode-integer code '(sint 8))))))
950 (t (list (nth r/m (register-set-by-mode :32-bit))
951 (code-call (decode-integer code '(sint 8)))))))
952 (#b10 (case r/m
953 (#b100 (nconc (decode-sib)
954 (list (code-call (decode-integer code '(uint 32))))))
955 (t (list (nth r/m (register-set-by-mode :32-bit))
956 (code-call (decode-integer code '(uint 32))))))))))
957 code)))
958
959
960 (defmacro return-when (form)
961 `(let ((x ,form))
962 (when x (return-from operator x))))
963
964 (defmacro return-values-when (form)
965 `(let ((x (encode ,form)))
966 (when x (return-from operator x))))
967
968 (defmacro imm (imm-operand opcode imm-type &optional extra-operand &rest extras)
969 `(progn
970 (assembler
971 (when (and ,@(when extra-operand
972 (list (list* 'eql extra-operand)))
973 (immediate-p ,imm-operand))
974 (let ((immediate (resolve-operand ,imm-operand)))
975 (when (typep immediate ',imm-type)
976 (return-values-when
977 (encoded-values :opcode ,opcode
978 :immediate (encode-integer immediate ',imm-type)
979 :operand-size operator-mode
980 :rex default-rex
981 ,@extras))))))
982 (disassembler
983 ,(if extra-operand
984 `(define-disassembler (operator ,opcode operator-mode)
985 decode-imm-modrm
986 ',imm-type
987 (operand-ordering operand-formals
988 :imm ',imm-operand
989 :modrm ',(first extra-operand))
990 :fixed-modrm ',(second extra-operand))
991 `(define-disassembler (operator ,opcode operator-mode)
992 decode-imm-modrm
993 ',imm-type
994 '(:imm))))))
995
996 (defmacro imm-modrm (op-imm op-modrm opcode digit type)
997 `(progn
998 (assembler
999 (when (immediate-p ,op-imm)
1000 (let ((immediate (resolve-operand ,op-imm)))
1001 (when (typep immediate ',type)
1002 (return-values-when
1003 (merge-encodings (encoded-values :opcode ,opcode
1004 :reg ,digit
1005 :operand-size operator-mode
1006 :rex default-rex
1007 :immediate (encode-integer immediate ',type))
1008 (encode-reg/mem ,op-modrm operator-mode)))))))
1009 (disassembler
1010 (define-disassembler (operator ,opcode operator-mode ,digit)
1011 decode-imm-modrm
1012 ',type
1013 (operand-ordering operand-formals
1014 :imm ',op-imm
1015 :modrm ',op-modrm)))))
1016
1017
1018 (defun compute-extra-prefixes (operator pc size)
1019 (let ((ff (assoc operator *instruction-compute-extra-prefix-map*)))
1020 (when ff
1021 (funcall (cdr ff) pc size))))
1022
1023 (defun encode-pc-rel (operator legacy-prefixes opcode operand type &rest extras)
1024 (when (typep operand '(or pc-relative-operand symbol-reference))
1025 (let* ((estimated-code-size-no-extras (+ (length legacy-prefixes)
1026 (type-octet-size type)
1027 (opcode-octet-size opcode)))
1028 (estimated-extra-prefixes (compute-extra-prefixes operator *pc* estimated-code-size-no-extras))
1029 (estimated-code-size (+ estimated-code-size-no-extras
1030 (length estimated-extra-prefixes)))
1031 (offset (let ((*pc* (when *pc*
1032 (+ *pc* estimated-code-size))))
1033 (resolve-pc-relative operand))))
1034 (when (typep offset type)
1035 (let ((code (let ((*instruction-compute-extra-prefix-map* nil))
1036 (encode (apply #'encoded-values
1037 :opcode opcode
1038 :displacement (encode-integer offset type)
1039 extras)))))
1040 (if (= (length code)
1041 estimated-code-size-no-extras)
1042 (append estimated-extra-prefixes code)
1043 (let* ((code-size (length code))
1044 (extra-prefixes (compute-extra-prefixes operator *pc* code-size))
1045 (offset (let ((*pc* (when *pc*
1046 (+ *pc* code-size (length extra-prefixes)))))
1047 (resolve-pc-relative operand))))
1048 (when (typep offset type)
1049 (let ((code (let ((*instruction-compute-extra-prefix-map* nil))
1050 (encode (apply #'encoded-values
1051 :opcode opcode
1052 :displacement (encode-integer offset type)
1053 extras)))))
1054 (assert (= code-size (length code)))
1055 (append extra-prefixes code))))))))))
1056
1057 (defmacro pc-rel (opcode operand type &rest extras)
1058 `(progn
1059 (assembler
1060 (return-when (encode-pc-rel operator legacy-prefixes ,opcode ,operand ',type ,@extras)))
1061 (disassembler
1062 (define-disassembler (operator ,opcode operator-mode)
1063 decode-pc-rel
1064 ',type))))
1065
1066 (defmacro modrm (operand opcode digit)
1067 `(progn
1068 (assembler
1069 (when (typep ,operand '(or register-operand indirect-operand))
1070 (return-values-when
1071 (merge-encodings (encoded-values :opcode ,opcode
1072 :reg ,digit
1073 :operand-size operator-mode
1074 :rex default-rex)
1075 (encode-reg/mem ,operand operator-mode)))))
1076 (disassembler
1077 (define-disassembler (operator ,opcode operator-mode ,digit) decode-modrm))))
1078
1079 (defun encode-reg-modrm (operator legacy-prefixes op-reg op-modrm opcode operator-mode default-rex &optional reg/mem-mode &rest extras)
1080 (let* ((reg-map (ecase operator-mode
1081 (:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh))
1082 (:16-bit '(:ax :cx :dx :bx :sp :bp :si :di))
1083 (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi))
1084 (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15))
1085 (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7 :mm8))
1086 (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7))))
1087 (reg-index (position op-reg reg-map)))
1088 (when reg-index
1089 (encode (merge-encodings (apply #'encoded-values
1090 :opcode opcode
1091 :reg reg-index
1092 :operand-size operator-mode
1093 :rex default-rex
1094 extras)
1095 (encode-reg/mem op-modrm (or reg/mem-mode operator-mode)))))))
1096
1097 (defmacro reg-modrm (op-reg op-modrm opcode &optional reg/mem-mode &rest extras)
1098 `(progn
1099 (assembler
1100 (return-when (encode-reg-modrm operator legacy-prefixes ,op-reg ,op-modrm ,opcode
1101 operator-mode default-rex ,reg/mem-mode ,@extras)))
1102 (disassembler
1103 (define-disassembler (operator ,opcode operator-mode)
1104 decode-reg-modrm
1105 (operand-ordering operand-formals
1106 :reg ',op-reg
1107 :modrm ',op-modrm)))))
1108
1109 (defun encode-reg-cr (operator legacy-prefixes op-reg op-cr opcode operator-mode default-rex &rest extras)
1110 (let* ((reg-map (ecase operator-mode
1111 (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi))
1112 (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15))))
1113 (reg-index (position op-reg reg-map))
1114 (cr-index (position op-cr '(:cr0 :cr1 :cr2 :cr3 :cr4 :cr5 :cr6 :cr7))))
1115 (when (and reg-index
1116 cr-index)
1117 (encode (apply #'encoded-values
1118 :opcode opcode
1119 :mod #b11
1120 :rm reg-index
1121 :reg cr-index
1122 :operand-size (if (not (eq *cpu-mode* :64-bit))
1123 nil
1124 operator-mode)
1125 :rex default-rex
1126 extras)))))
1127
1128 (defmacro reg-cr (op-reg op-cr opcode &rest extras)
1129 `(return-when (encode-reg-cr operator legacy-prefixes ,op-reg ,op-cr ,opcode operator-mode default-rex ,@extras)))
1130
1131 (defmacro sreg-modrm (op-sreg op-modrm opcode)
1132 `(let* ((reg-map '(:es :cs :ss :ds :fs :gs))
1133 (reg-index (position ,op-sreg reg-map)))
1134 (when reg-index
1135 (return-values-when
1136 (merge-encodings (encoded-values :opcode ,opcode
1137 :reg reg-index
1138 :rex default-rex)
1139 (encode-reg/mem ,op-modrm operator-mode))))))
1140
1141 (defmacro moffset (opcode op-offset type fixed-operand)
1142 `(progn
1143 (assembler
1144 (when (and ,@(when fixed-operand
1145 `((eql ,@fixed-operand)))
1146 (indirect-operand-p ,op-offset))
1147 (multiple-value-bind (reg offsets reg2)
1148 (parse-indirect-operand ,op-offset)
1149 (when (and (not reg)
1150 (not reg2))
1151 (return-values-when
1152 (encoded-values :opcode ,opcode
1153 :displacement (encode-integer (reduce #'+ offsets
1154 :key #'resolve-operand)
1155 ',type)))))))
1156 (disassembler
1157 (define-disassembler (operator ,opcode operator-mode)
1158 decode-moffset
1159 ',type
1160 (operand-ordering operand-formals
1161 :moffset ',op-offset
1162 :fixed ',(first fixed-operand))
1163 ',(second fixed-operand)))))
1164
1165
1166
1167 (defmacro opcode (opcode &optional fixed-operand &rest extras)
1168 `(progn
1169 (assembler
1170 (when (and ,@(when fixed-operand
1171 `((eql ,@fixed-operand))))
1172 (return-values-when
1173 (encoded-values :opcode ,opcode
1174 ,@extras
1175 :operand-size operator-mode))))
1176 (disassembler
1177 (define-disassembler (operator ,opcode)
1178 decode-no-operands
1179 ,(second fixed-operand)))))
1180
1181 (defmacro opcode* (opcode &rest extras)
1182 `(return-values-when
1183 (encoded-values :opcode ,opcode
1184 ,@extras)))
1185
1186 (defun encode-opcode-reg (operator legacy-prefixes opcode op-reg operator-mode default-rex)
1187 (let* ((reg-map (ecase operator-mode
1188 (:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh))
1189 (:16-bit '(:ax :cx :dx :bx :sp :bp :si :di))
1190 (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi))
1191 (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15))
1192 (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7 :mm8))
1193 (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7))))
1194 (reg-index (position op-reg reg-map)))
1195 (when reg-index
1196 (encode (encoded-values :opcode (+ opcode (ldb (byte 3 0) reg-index))
1197 :operand-size operator-mode
1198 :rex (cond
1199 ((>= reg-index 8)
1200 (assert (eq :64-bit operator-mode))
1201 '(:rex.w :rex.r))
1202 (t default-rex)))))))
1203
1204 (defmacro opcode-reg (opcode op-reg &optional extra-operand)
1205 `(progn
1206 (assembler
1207 (when (and ,@(when extra-operand
1208 `((eql ,@extra-operand))))
1209 (return-when
1210 (encode-opcode-reg operator legacy-prefixes ,opcode ,op-reg operator-mode default-rex))))
1211 (disassembler
1212 (loop for reg from #b000 to #b111
1213 do ,(if (not extra-operand)
1214 `(define-disassembler (operator (logior ,opcode reg) operator-mode)
1215 decode-opcode-reg
1216 '(:reg)
1217 nil)
1218 `(define-disassembler (operator (logior ,opcode reg) operator-mode)
1219 decode-opcode-reg
1220 (operand-ordering operand-formals
1221 :reg ',op-reg
1222 :extra ',(first extra-operand))
1223 ',(second extra-operand)))))))
1224
1225 (defun encode-opcode-reg-imm (operator legacy-prefixes opcode op-reg op-imm type operator-mode default-rex)
1226 (when (immediate-p op-imm)
1227 (let ((immediate (resolve-operand op-imm)))
1228 (when (typep immediate type)
1229 (let* ((reg-map (ecase operator-mode
1230 (:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh))
1231 (:16-bit '(:ax :cx :dx :bx :sp :bp :si :di))
1232 (:32-bit '(:eax :ecx :edx :ebx :esp :ebp :esi :edi))
1233 (:64-bit '(:rax :rcx :rdx :rbx :rsp :rbp :rsi :rdi :r8 :r9 :r10 :r11 :r12 :r13 :r14 :r15))
1234 (:mm '(:mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7 :mm8))
1235 (:xmm '(:xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7))))
1236 (reg-index (position op-reg reg-map)))
1237 (when reg-index
1238 (encode (encoded-values :opcode (+ opcode (ldb (byte 3 0) reg-index))
1239 :operand-size operator-mode
1240 :immediate (encode-integer immediate type)
1241 :rex (cond
1242 ((>= reg-index 8)
1243 (assert (eq :64-bit operator-mode))
1244 '(:rex.w :rex.r))
1245 (t default-rex))))))))))
1246
1247 (defmacro opcode-reg-imm (opcode op-reg op-imm type)
1248 `(return-when
1249 (encode-opcode-reg-imm operator legacy-prefixes ,opcode ,op-reg ,op-imm ',type operator-mode default-rex)))
1250
1251 (defmacro far-pointer (opcode segment offset offset-type &rest extra)
1252 `(when (and (immediate-p ,segment)
1253 (indirect-operand-p ,offset)); FIXME: should be immediate-p, change in bootblock.lisp.
1254 (let ((segment (resolve-operand ,segment))
1255 (offset (resolve-operand (car ,offset))))
1256 (when (and (typep segment '(uint 16))
1257 (typep offset ',offset-type))
1258 (return-when (encode (encoded-values :opcode ,opcode
1259 :immediate (append (encode-integer offset ',offset-type)
1260 (encode-integer segment '(uint 16)))
1261 ,@extra)))))))
1262
1263
1264 ;;;;;;;;;;; Pseudo-instructions
1265
1266 (define-operator/none :% (op &rest form)
1267 (case op
1268 (:bytes
1269 (return-from operator
1270 (destructuring-bind (byte-size &rest data)
1271 form
1272 (loop for datum in data
1273 append (loop for b from 0 below byte-size by 8
1274 collect (ldb (byte 8 b)
1275 (resolve-operand datum)))))))
1276 (:funcall
1277 (return-from operator
1278 (destructuring-bind (function &rest args)
1279 form
1280 (apply function (mapcar #'resolve-operand args)))))
1281 (:fun
1282 (return-from operator
1283 (destructuring-bind (function &rest args)
1284 (car form)
1285 (loop for cbyte in (apply function (mapcar #'resolve-operand args))
1286 append (loop for octet from 0 below (imagpart cbyte)
1287 collect (ldb (byte 8 (* 8 octet))
1288 (realpart cbyte)))))))
1289 (:format
1290 (return-from operator
1291 (destructuring-bind (byte-size format-control &rest format-args)
1292 form
1293 (ecase byte-size
1294 (8 (let ((data (map 'list #'char-code
1295 (apply #'format nil format-control
1296 (mapcar #'resolve-operand format-args)))))
1297 (cons (length data)
1298 data)))))))
1299 (:align
1300 (return-from operator
1301 (destructuring-bind (alignment)
1302 form
1303 (let* ((offset (mod *pc* alignment)))
1304 (when (plusp offset)
1305 (make-list (- alignment offset)
1306 :initial-element 0))))))))
1307
1308 ;;;;;;;;;;; ADC
1309
1310 (define-operator/8 :adcb (src dst)
1311 (imm src #x14 (xint 8) (dst :al))
1312 (imm-modrm src dst #x80 2 (xint 8))
1313 (reg-modrm dst src #x12)
1314 (reg-modrm src dst #x10))
1315
1316 (define-operator* (:16 :adcw :32 :adcl :64 :adcr) (src dst)
1317 (imm-modrm src dst #x83 2 (sint 8))
1318 (imm src #x15 :int-16-32-64 (dst :ax-eax-rax))
1319 (imm-modrm src dst #x81 2 :int-16-32-64)
1320 (reg-modrm dst src #x13)
1321 (reg-modrm src dst #x11))
1322
1323 ;;;;;;;;;;; ADD
1324
1325 (define-operator/8 :addb (src dst)
1326 (imm src #x04 (xint 8) (dst :al))
1327 (imm-modrm src dst #x80 0 (xint 8))
1328 (reg-modrm dst src #x02)
1329 (reg-modrm src dst #x00))
1330
1331 (define-operator* (:16 :addw :32 :addl :64 :addr) (src dst)
1332 (imm-modrm src dst #x83 0 (sint 8))
1333 (imm src #x05 :int-16-32-64 (dst :ax-eax-rax))
1334 (imm-modrm src dst #x81 0 :int-16-32-64)
1335 (reg-modrm dst src #x03)
1336 (reg-modrm src dst #x01))
1337
1338 ;;;;;;;;;;; AND
1339
1340 (define-operator/8 :andb (mask dst)
1341 (imm mask #x24 (xint 8) (dst :al))
1342 (imm-modrm mask dst #x80 4 (xint 8))
1343 (reg-modrm dst mask #x22)
1344 (reg-modrm mask dst #x20))
1345
1346 (define-operator* (:16 :andw :32 :andl :64 :andr) (mask dst)
1347 (imm-modrm mask dst #x83 4 (sint 8))
1348 (imm mask #x25 :int-16-32-64 (dst :ax-eax-rax))
1349 (imm-modrm mask dst #x81 4 :int-16-32-64)
1350 (reg-modrm dst mask #x23)
1351 (reg-modrm mask dst #x21))
1352
1353 ;;;;;;;;;;; BOUND, BSF, BSR, BSWAP
1354
1355 (define-operator* (:16 :boundw :32 :bound) (bounds reg)
1356 (reg-modrm reg bounds #x62))
1357
1358 (define-operator* (:16 :bsfw :32 :bsfl :64 :bsfr) (src dst)
1359 (reg-modrm dst src #x0fbc))
1360
1361 (define-operator* (:16 :bsrw :32 :bsrl :64 :bsrr) (src dst)
1362 (reg-modrm dst src #x0fbd))
1363
1364 (define-operator* (:32 :bswap :64 :bswapr) (dst)
1365 (opcode-reg #x0fc8 dst))
1366
1367 ;;;;;;;;;;; BT, BTC, BTR, BTS
1368
1369 (define-operator* (:16 :btw :32 :btl :64 :btr) (bit src)
1370 (imm-modrm bit src #x0fba 4 (uint 8))
1371 (reg-modrm bit src #x0fa3))
1372
1373 (define-operator* (:16 :btcw :32 :btcl :64 :btcr) (bit src)
1374 (imm-modrm bit src #x0fba 7 (uint 8))
1375 (reg-modrm bit src #x0fbb))
1376
1377 (define-operator* (:16 :btrw :32 :btrl :64 :btrr) (bit src)
1378 (imm-modrm bit src #x0fba 6 (uint 8))
1379 (reg-modrm bit src #x0fb3))
1380
1381 (define-operator* (:16 :btsw :32 :btsl :64 :btsr) (bit src)
1382 (imm-modrm bit src #x0fba 5 (uint 8))
1383 (reg-modrm bit src #x0fab))
1384
1385 ;;;;;;;;;;; CALL
1386
1387 (define-operator* (:16 :callw :32 :calll :64 :callr :dispatch :call) (dest)
1388 (case *cpu-mode*
1389 (:16-bit
1390 (pc-rel #xe8 dest (sint 16)))
1391 (:32-bit
1392 (pc-rel #xe8 dest (sint 32))))
1393 (when (eq operator-mode *cpu-mode*)
1394 (modrm dest #xff 2)))
1395
1396 (define-operator/none :call-segment (dest)
1397 (modrm dest #xff 3))
1398
1399 ;;;;;;;;;;; CLC, CLD, CLI, CLTS, CMC
1400
1401 (define-operator/none :clc () (opcode #xf8))
1402 (define-operator/none :cld () (opcode #xfc))
1403 (define-operator/none :cli () (opcode #xfa))
1404 (define-operator/none :clts () (opcode #x0f06))
1405 (define-operator/none :cmc () (opcode #xf5))
1406
1407 ;;;;;;;;;;; CMOVcc
1408
1409 (define-operator* (:16 :cmovaw :32 :cmova :64 :cmovar) (src dst)
1410 (reg-modrm dst src #x0f47)) ; Move if above, CF=0 and ZF=0.
1411
1412 (define-operator* (:16 :cmovaew :32 :cmovae :64 :cmovaer) (src dst)
1413 (reg-modrm dst src #x0f43)) ; Move if above or equal, CF=0.
1414
1415 (define-operator* (:16 :cmovbw :32 :cmovb :64 :cmovbr) (src dst)
1416 (reg-modrm dst src #x0f42)) ; Move if below, CF=1.
1417
1418 (define-operator* (:16 :cmovbew :32 :cmovbe :64 :cmovber) (src dst)
1419 (reg-modrm dst src #x0f46)) ; Move if below or equal, CF=1 or ZF=1.
1420
1421 (define-operator* (:16 :cmovcw :32 :cmovc :64 :cmovcr) (src dst)
1422 (reg-modrm dst src #x0f42)) ; Move if carry, CF=1.
1423
1424 (define-operator* (:16 :cmovew :32 :cmove :64 :cmover) (src dst)
1425 (reg-modrm dst src #x0f44)) ; Move if equal, ZF=1.
1426
1427 (define-operator* (:16 :cmovgw :32 :cmovg :64 :cmovgr) (src dst)
1428 (reg-modrm dst src #x0f4f)) ; Move if greater, ZF=0 and SF=OF.
1429
1430 (define-operator* (:16 :cmovgew :32 :cmovge :64 :cmovger) (src dst)
1431 (reg-modrm dst src #x0f4d)) ; Move if greater or equal, SF=OF.
1432
1433 (define-operator* (:16 :cmovlw :32 :cmovl :64 :cmovlr) (src dst)
1434 (reg-modrm dst src #x0f4c))
1435
1436 (define-operator* (:16 :cmovlew :32 :cmovle :64 :cmovler) (src dst)
1437 (reg-modrm dst src #x0f4e)) ; Move if less or equal, ZF=1 or SF/=OF.
1438
1439 (define-operator* (:16 :cmovnaw :32 :cmovna :64 :cmovnar) (src dst)
1440 (reg-modrm dst src #x0f46)) ; Move if not above, CF=1 or ZF=1.
1441
1442 (define-operator* (:16 :cmovnaew :32 :cmovnae :64 :cmovnaer) (src dst)
1443 (reg-modrm dst src #x0f42)) ; Move if not above or equal, CF=1.
1444
1445 (define-operator* (:16 :cmovnbw :32 :cmovnb :64 :cmovnbr) (src dst)
1446 (reg-modrm dst src #x0f43)) ; Move if not below, CF=0.
1447
1448 (define-operator* (:16 :cmovnbew :32 :cmovnbe :64 :cmovnber) (src dst)
1449 (reg-modrm dst src #x0f47)) ; Move if not below or equal, CF=0 and ZF=0.
1450
1451 (define-operator* (:16 :cmovncw :32 :cmovnc :64 :cmovncr) (src dst)
1452 (reg-modrm dst src #x0f43)) ; Move if not carry, CF=0.
1453
1454 (define-operator* (:16 :cmovnew :32 :cmovne :64 :cmovner) (src dst)
1455 (reg-modrm dst src #x0f45)) ; Move if not equal, ZF=0.
1456
1457 (define-operator* (:16 :cmovngew :32 :cmovnge :64 :cmovnger) (src dst)
1458 (reg-modrm dst src #x0f4c)) ; Move if not greater or equal, SF/=OF.
1459
1460 (define-operator* (:16 :cmovnlw :32 :cmovnl :64 :cmovnlr) (src dst)
1461 (reg-modrm dst src #x0f4d)) ; Move if not less SF=OF.
1462
1463 (define-operator* (:16 :cmovnlew :32 :cmovnle :64 :cmovnler) (src dst)
1464 (reg-modrm dst src #x0f4f)) ; Move if not less or equal, ZF=0 and SF=OF.
1465
1466 (define-operator* (:16 :cmovnow :32 :cmovno :64 :cmovnor) (src dst)
1467 (reg-modrm dst src #x0f41)) ; Move if not overflow, OF=0.
1468
1469 (define-operator* (:16 :cmovnpw :32 :cmovnp :64 :cmovnpr) (src dst)
1470 (reg-modrm dst src #x0f4b)) ; Move if not parity, PF=0.
1471
1472 (define-operator* (:16 :cmovnsw :32 :cmovns :64 :cmovnsr) (src dst)
1473 (reg-modrm dst src #x0f49)) ; Move if not sign, SF=0.
1474
1475 (define-operator* (:16 :cmovnzw :32 :cmovnz :64 :cmovnzr) (src dst)
1476 (reg-modrm dst src #x0f45)) ; Move if not zero, ZF=0.
1477
1478 (define-operator* (:16 :cmovow :32 :cmovo :64 :cmovor) (src dst)
1479 (reg-modrm dst src #x0f40)) ; Move if overflow, OF=1.
1480
1481 (define-operator* (:16 :cmovpw :32 :cmovp :64 :cmovpr) (src dst)
1482 (reg-modrm dst src #x0f4a)) ; Move if parity, PF=1.
1483
1484 (define-operator* (:16 :cmovsw :32 :cmovs :64 :cmovsr) (src dst)
1485 (reg-modrm dst src #x0f48)) ; Move if sign, SF=1
1486
1487 (define-operator* (:16 :cmovzw :32 :cmovz :64 :cmovzr) (src dst)
1488 (reg-modrm dst src #x0f44)) ; Move if zero, ZF=1
1489
1490 ;;;;;;;;;;; CMP
1491
1492 (define-operator/8 :cmpb (src dst)
1493 (imm src #x3c (xint 8) (dst :al))
1494 (imm-modrm src dst #x80 7 (xint 8))
1495 (reg-modrm dst src #x3a)
1496 (reg-modrm src dst #x38))
1497
1498 (define-operator* (:16 :cmpw :32 :cmpl :64 :cmpr) (src dst)
1499 (imm-modrm src dst #x83 7 (sint 8))
1500 (imm src #x3d :int-16-32-64 (dst :ax-eax-rax))
1501 (imm-modrm src dst #x81 7 :int-16-32-64)
1502 (reg-modrm dst src #x3b)
1503 (reg-modrm src dst #x39))
1504
1505 ;;;;;;;;;;; CMPXCHG
1506
1507 (define-operator/8 :cmpxchgb (cmp-reg cmp-modrm al-dst)
1508 (when (eq al-dst :al)
1509 (reg-modrm cmp-reg cmp-modrm #x0fb0)))
1510
1511 (define-operator* (:16 :cmpxchgw :32 :cmpxchgl :64 :cmpxchgr) (cmp-reg cmp-modrm al-dst)
1512 (when (eq al-dst :ax-eax-rax)
1513 (reg-modrm cmp-reg cmp-modrm #x0fb1)))
1514
1515 ;;;;;;;;;;; CMPXCHG8B, CMPXCHG16B
1516
1517 (define-operator/32 :cmpxchg8b (address)
1518 (modrm address #x0fc7 1))
1519
1520 (define-operator/64 :cmpxchg16b (address)
1521 (modrm address #x0fc7 1))
1522
1523 ;;;;;;;;;;; CPUID
1524
1525 (define-operator/none :cpuid ()
1526 (opcode* #x0fa2))
1527
1528 ;;;;;;;;;;; CWD, CDQ
1529
1530 (define-operator/16 :cwd (reg1 reg2)
1531 (when (and (eq reg1 :ax)
1532 (eq reg2 :dx))
1533 (opcode #x99)))
1534
1535 (define-operator/32 :cdq (reg1 reg2)
1536 (when (and (eq reg1 :eax)
1537 (eq reg2 :edx))
1538 (opcode #x99)))
1539
1540 (define-operator/64 :cqo (reg1 reg2)
1541 (when (and (eq reg1 :rax)
1542 (eq reg2 :rdx))
1543 (opcode #x99)))
1544
1545 ;;;;;;;;;;; DEC
1546
1547 (define-operator/8 :decb (dst)
1548 (modrm dst #xfe 1))
1549
1550 (define-operator* (:16 :decw :32 :decl) (dst)
1551 (unless (eq *cpu-mode* :64-bit)
1552 (opcode-reg #x48 dst))
1553 (modrm dst #xff 1))
1554
1555 (define-operator* (:64 :decr) (dst)
1556 (modrm dst #xff 1))
1557
1558 ;;;;;;;;;;; DIV
1559
1560 (define-operator/8 :divb (divisor dividend)
1561 (when (eq dividend :ax)
1562 (modrm divisor #xf6 6)))
1563
1564 (define-operator* (:16 :divw :32 :divl :64 :divr) (divisor dividend1 dividend2)
1565 (when (and (eq dividend1 :ax-eax-rax)
1566 (eq dividend2 :dx-edx-rdx))
1567 (modrm divisor #xf7 6)))
1568
1569 ;;;;;;;;;;; HLT
1570
1571 (define-operator/none :halt ()
1572 (opcode #xf4))
1573
1574 ;;;;;;;;;;; IDIV
1575
1576 (define-operator/8 :idivb (divisor dividend1 dividend2)
1577 (when (and (eq dividend1 :al)
1578 (eq dividend2 :ah))
1579 (modrm divisor #xf6 7)))
1580
1581 (define-operator* (:16 :idivw :32 :idivl :64 :idivr) (divisor dividend1 dividend2)
1582 (when (and (eq dividend1 :ax-eax-rax)
1583 (eq dividend2 :dx-edx-rdx))
1584 (modrm divisor #xf7 7)))
1585
1586 ;;;;;;;;;;; IMUL
1587
1588 (define-operator/32 :imull (factor product1 &optional product2)
1589 (when (not product2)
1590 (reg-modrm product1 factor #x0faf))
1591 (when (and (eq product1 :eax)
1592 (eq product2 :edx))
1593 (modrm factor #xf7 5))
1594 (typecase factor
1595 ((sint 8)
1596 (reg-modrm product1 product2 #x6b
1597 nil
1598 :displacement (encode-integer factor '(sint 8))))
1599 ((sint 32)
1600 (reg-modrm product1 product2 #x69
1601 nil
1602 :displacement (encode-integer factor '(sint 32))))))
1603
1604 ;;;;;;;;;;; IN
1605
1606 (define-operator/8 :inb (port dst)
1607 (when (eq :al dst)
1608 (typecase port
1609 ((eql :dx)
1610 (opcode #xec))
1611 ((uint 8)
1612 (imm port #xe4 (uint 8) (dst :al))))))
1613
1614 (define-operator/16 :inw (port dst)
1615 (when (eq :ax dst)
1616 (typecase port
1617 ((eql :dx)
1618 (opcode #xed))
1619 ((uint 8)
1620 (imm port #xe5 (uint 8) (dst :ax))))))
1621
1622 (define-operator/32 :inl (port dst)
1623 (when (eq :eax dst)
1624 (typecase port
1625 ((eql :dx)
1626 (opcode #xed))
1627 ((uint 8)
1628 (imm port #xe5 (uint 8) (dst :eax))))))
1629
1630 ;;;;;;;;;;; INC
1631
1632 (define-operator/8 :incb (dst)
1633 (modrm dst #xfe 0))
1634
1635 (define-operator* (:16 :incw :32 :incl) (dst)
1636 (unless (eq *cpu-mode* :64-bit)
1637 (opcode-reg #x40 dst))
1638 (modrm dst #xff 0))
1639
1640 (define-operator* (:64 :incr) (dst)
1641 (modrm dst #xff 0))
1642
1643 ;;;;;;;;;;; INT
1644
1645 (define-operator/none :break ()
1646 (opcode #xcc))
1647
1648 (define-operator/none :int (vector)
1649 (imm vector #xcd (uint 8)))
1650
1651 (define-operator/none :into ()
1652 (opcode #xce))
1653
1654 ;;;;;;;;;;; INVLPG
1655
1656 (define-operator/none :invlpg (address)
1657 (modrm address #x0f01 7))
1658
1659 ;;;;;;;;;;; IRET
1660
1661 (define-operator* (:16 :iret :32 :iretd :64 :iretq) ()
1662 (opcode #xcf () :rex default-rex))
1663
1664 ;;;;;;;;;;; Jcc
1665
1666 (defmacro define-jcc (name opcode1 &optional (opcode2 (+ #x0f10 opcode1)))
1667 `(define-operator/none ,name (dst)
1668 (pc-rel ,opcode1 dst (sint 8))
1669 (when (or (and (eq *cpu-mode* :32-bit)
1670 *use-jcc-16-bit-p*)
1671 (eq *cpu-mode* :16-bit))
1672 (pc-rel ,opcode2 dst (sint 16)
1673 :operand-size :16-bit))
1674 (pc-rel ,opcode2 dst (sint 32)
1675 :operand-size (case *cpu-mode*
1676 ((:16-bit :32-bit)
1677 :32-bit)))))
1678
1679 (define-jcc :ja #x77)
1680 (define-jcc :jae #x73)
1681 (define-jcc :jb #x72)
1682 (define-jcc :jbe #x76)
1683 (define-jcc :jc #x72)
1684 (define-jcc :jecx #xe3)
1685 (define-jcc :je #x74)
1686 (define-jcc :jg #x7f)
1687 (define-jcc :jge #x7d)
1688 (define-jcc :jl #x7c)
1689 (define-jcc :jle #x7e)
1690 (define-jcc :jna #x76)
1691 (define-jcc :jnae #x72)
1692 (define-jcc :jnb #x73)
1693 (define-jcc :jnbe #x77)
1694 (define-jcc :jnc #x73)
1695 (define-jcc :jne #x75)
1696 (define-jcc :jng #x7e)
1697 (define-jcc :jnge #x7c)
1698 (define-jcc :jnl #x7d)
1699 (define-jcc :jnle #x7f)
1700 (define-jcc :jno #x71)
1701 (define-jcc :jnp #x7b)
1702 (define-jcc :jns #x79)
1703 (define-jcc :jnz #x75)
1704 (define-jcc :jo #x70)
1705 (define-jcc :jp #x7a)
1706 (define-jcc :jpe #x7a)
1707 (define-jcc :jpo #x7b)
1708 (define-jcc :js #x78)
1709 (define-jcc :jz #x74)
1710
1711 (define-operator* (:16 :jcxz :32 :jecxz :64 :jrcxz) (dst)
1712 (pc-rel #xe3 dst (sint 8)
1713 :operand-size operator-mode
1714 :rex default-rex))
1715
1716 ;;;;;;;;;;; JMP
1717
1718 (define-operator/none :jmp (seg-dst &optional dst)
1719 (cond
1720 (dst
1721 (when (eq *cpu-mode* :16-bit)
1722 (far-pointer #xea seg-dst dst (uint 16)))
1723 (when (eq *cpu-mode* :32-bit)
1724 (far-pointer #xea seg-dst dst (xint 32))))
1725 (t (let ((dst seg-dst))
1726 (pc-rel #xeb dst (sint 8))
1727 (when (or (and (eq *cpu-mode* :32-bit)
1728 *use-jcc-16-bit-p*)
1729 (eq *cpu-mode* :16-bit))
1730 (pc-rel #xe9 dst (sint 16)))
1731 (pc-rel #xe9 dst (sint 32))
1732 (when (or (not *position-independent-p*)
1733 (indirect-operand-p dst))
1734 (let ((operator-mode :32-bit))
1735 (modrm dst #xff 4)))))))
1736
1737 (define-operator* (:16 :jmpw-segment :32 :jmp-segment :64 :jmpr-segment) (addr)
1738 (modrm addr #xff 5))
1739
1740 ;;;;;;;;;;; LAHF, LAR
1741
1742 (define-operator/none :lahf ()
1743 (case *cpu-mode*
1744 ((:16-bit :32-bit)
1745 (opcode #x9f))))
1746
1747 (define-operator* (:16 :larw :32 :larl :64 :larr) (src dst)
1748 (reg-modrm dst src #x0f02))
1749
1750 ;;;;;;;;;;; LEA
1751
1752 (define-operator* (:16 :leaw :32 :leal :64 :lear) (addr dst)
1753 (reg-modrm dst addr #x8d))
1754
1755 ;;;;;;;;;;; LEAVE
1756
1757 (define-operator/none :leave ()
1758 (opcode #xc9))
1759
1760 ;;;;;;;;;;; LFENCE
1761
1762 (define-operator/none :lfence ()
1763 (opcode #x0faee8))
1764
1765 ;;;;;;;;;;; LGDT, LIDT
1766
1767 (define-operator* (:16 :lgdtw :32 :lgdtl :64 :lgdtr :dispatch :lgdt) (addr)
1768 (when (eq operator-mode *cpu-mode*)
1769 (modrm addr #x0f01 2)))
1770
1771 (define-operator* (:16 :lidtw :32 :lidt :64 :lidtr) (addr)
1772 (modrm addr #x0f01 3))
1773
1774 ;;;;;;;;;;; LMSW
1775
1776 (define-operator/16 :lmsw (src)
1777 (modrm src #x0f01 6))
1778
1779 ;;;;;;;;;;; LODS
1780
1781 (define-operator/8 :lodsb ()
1782 (opcode #xac))
1783
1784 (define-operator* (:16 :lodsw :32 :lodsl :64 :lodsr) ()
1785 (opcode #xad))
1786
1787 ;;;;;;;;;;; LOOP, LOOPE, LOOPNE
1788
1789 (define-operator/none :loop (dst)
1790 (pc-rel #xe2 dst (sint 8)))
1791
1792 (define-operator/none :loope (dst)
1793 (pc-rel #xe1 dst (sint 8)))
1794
1795 (define-operator/none :loopne (dst)
1796 (pc-rel #xe0 dst (sint 8)))
1797
1798 ;;;;;;;;;;; MOV
1799
1800 (define-operator/8 :movb (src dst)
1801 (moffset #xa2 dst (uint 8) (src :al))
1802 (moffset #xa0 src (uint 8) (dst :al))
1803 (opcode-reg-imm #xb0 dst src (xint 8))
1804 (imm-modrm src dst #xc6 0 (xint 8))
1805 (reg-modrm dst src #x8a)
1806 (reg-modrm src dst #x88))
1807
1808 (define-operator/16 :movw (src dst)
1809 (moffset #xa3 dst (uint 16) (src :ax))
1810 (moffset #xa0 src (uint 16) (dst :ax))
1811 (opcode-reg-imm #xb8 dst src (xint 16))
1812 (imm-modrm src dst #xc7 0 (xint 16))
1813 (sreg-modrm src dst #x8c)
1814 (sreg-modrm dst src #x8e)
1815 (reg-modrm dst src #x8b)
1816 (reg-modrm src dst #x89))
1817
1818 (define-operator/32 :movl (src dst)
1819 (moffset #xa3 dst (uint 32) (src :eax))
1820 (moffset #xa0 src (uint 32) (dst :eax))
1821 (opcode-reg-imm #xb8 dst src (xint 32))
1822 (imm-modrm src dst #xc7 0 (xint 32))
1823 (reg-modrm dst src #x8b)
1824 (reg-modrm src dst #x89))
1825
1826 ;;;;;;;;;;; MOVCR
1827
1828 (define-operator* (:32 :movcrl :64 :movcrr :dispatch :movcr) (src dst)
1829 (when (eq src :cr8)
1830 (reg-cr dst :cr0 #xf00f20
1831 :operand-size nil))
1832 (when (eq dst :cr8)
1833 (reg-cr src :cr0 #xf00f22
1834 :operand-size nil))
1835 (reg-cr src dst #x0f22
1836 :operand-size nil)
1837 (reg-cr dst src #x0f20
1838 :operand-size nil))
1839
1840 ;;;;;;;;;;; MOVS
1841
1842 (define-operator/8 :movsb ()
1843 (opcode #xa4))
1844
1845 (define-operator/16 :movsw ()
1846 (opcode #xa5))
1847
1848 (define-operator/32 :movsl ()
1849 (opcode #xa5))
1850
1851 ;;;;;;;;;;; MOVSX
1852
1853 (define-operator* (:32 :movsxb) (src dst)
1854 (reg-modrm dst src #x0fbe))
1855
1856 (define-operator* (:32 :movsxw) (src dst)
1857 (reg-modrm dst src #x0fbf))
1858
1859 ;;;;;;;;;;; MOVZX
1860
1861 (define-operator* (:16 :movzxbw :32 :movzxbl :dispatch :movzxb) (src dst)
1862 (reg-modrm dst src #x0fb6 :8-bit))
1863
1864 (define-operator* (:32 :movzxw) (src dst)
1865 (reg-modrm dst src #x0fb7))
1866
1867 ;;;;;;;;;;; MUL
1868
1869 (define-operator/32 :mull (factor product1 &optional product2)
1870 (when (and (eq product1 :eax)
1871 (eq product2 :edx))
1872 (modrm factor #xf7 4)))
1873
1874 ;;;;;;;;;;; NEG
1875
1876 (define-operator/8 :negb (dst)
1877 (modrm dst #xf6 3))
1878
1879 (define-operator* (:16 :negw :32 :negl :64 :negr) (dst)
1880 (modrm dst #xf7 3))
1881
1882 ;;;;;;;;;;;;;;;; NOP
1883
1884 (define-operator/none :nop ()
1885 (opcode #x90))
1886
1887 ;;;;;;;;;;; NOT
1888
1889 (define-operator/8 :notb (dst)
1890 (modrm dst #xf6 2))
1891
1892 (define-operator* (:16 :notw :32 :notl :64 :notr) (dst)
1893 (modrm dst #xf7 2))
1894
1895 ;;;;;;;;;;; OR
1896
1897 (define-operator/8 :orb (src dst)
1898 (imm src #x0c (xint 8) (dst :al))
1899 (imm-modrm src dst #x80 1 (xint 8))
1900 (reg-modrm dst src #x0a)
1901 (reg-modrm src dst #x08))
1902
1903 (define-operator* (:16 :orw :32 :orl :64 :orr) (src dst)
1904 (imm-modrm src dst #x83 1 (sint 8))
1905 (imm src #x0d :int-16-32-64 (dst :ax-eax-rax))
1906 (imm-modrm src dst #x81 1 :int-16-32-64)
1907 (reg-modrm dst src #x0b)
1908 (reg-modrm src dst #x09))
1909
1910 ;;;;;;;;;;; OUT
1911
1912 (define-operator/8 :outb (src port)
1913 (when (eq :al src)
1914 (typecase port
1915 ((eql :dx)
1916 (opcode #xee))
1917 ((uint 8)
1918 (imm port #xe6 (uint 8) (src :al))))))
1919
1920 (define-operator/16 :outw (src port)
1921 (when (eq :ax src)
1922 (typecase port
1923 ((eql :dx)
1924 (opcode #xef))
1925 ((uint 8)
1926 (imm port #xe7 (uint 8) (src :ax))))))
1927
1928 (define-operator/32 :outl (src port)
1929 (when (eq :eax src)
1930 (typecase port
1931 ((eql :dx)
1932 (opcode #xef))
1933 ((uint 8)
1934 (imm port #xe7 (uint 8) (src :eax))))))
1935
1936 ;;;;;;;;;;; POP
1937
1938 (define-operator* (:16 :popw :32 :popl) (dst)
1939 (opcode #x1f (dst :ds))
1940 (opcode #x07 (dst :es))
1941 (opcode #x17 (dst :ss))
1942 (opcode #x0fa1 (dst :fs))
1943 (opcode #x0fa9 (dst :gs))
1944 (opcode-reg #x58 dst)
1945 (modrm dst #x8f 0))
1946
1947 (define-operator/64* :popr (dst)
1948 (opcode-reg #x58 dst)
1949 (modrm dst #x8f 0))
1950
1951 ;;;;;;;;;;; POPF
1952
1953 (define-operator* (:16 :popfw :32 :popfl :64 :popfr) ()
1954 (opcode #x9d))
1955
1956 ;;;;;;;;;;; PRFETCH
1957
1958 (define-operator/none :prefetch-nta (m8)
1959 (modrm m8 #x0f18 0))
1960
1961 (define-operator/none :prefetch-t0 (m8)
1962 (modrm m8 #x0f18 1))
1963
1964 (define-operator/none :prefetch-t1 (m8)
1965 (modrm m8 #x0f18 2))
1966
1967 (define-operator/none :prefetch-t2 (m8)
1968 (modrm m8 #x0f18 3))
1969
1970 ;;;;;;;;;;; PUSH
1971
1972 (define-operator* (:16 :pushw :32 :pushl) (src)
1973 (opcode #x0e (src :cs))
1974 (opcode #x16 (src :ss))
1975 (opcode #x1e (src :ds))
1976 (opcode #x06 (src :es))
1977 (opcode #x0fa0 (src :fs))
1978 (opcode #x0fa8 (src :gs))
1979 (opcode-reg #x50 src)
1980 (imm src #x6a (sint 8))
1981 (imm src #x68 :int-16-32-64 () :operand-size operator-mode)
1982 (modrm src #xff 6))
1983
1984 (define-operator/64* :pushr (src)
1985 (opcode-reg #x50 src)
1986 (imm src #x6a (sint 8))
1987 (imm src #x68 (sint 16) () :operand-size :16-bit)
1988 (imm src #x68 (sint 32))
1989 (modrm src #xff 6))
1990
1991 ;;;;;;;;;;; PUSHF
1992
1993 (define-operator* (:16 :pushfw :32 :pushfl :64 :pushfr) ()
1994 (opcode #x9c))
1995
1996 ;;;;;;;;;;; RDTSC
1997
1998 (define-operator/none :rdtsc ()
1999 (opcode #x0f31))
2000
2001 ;;;;;;;;;;; RET
2002
2003 (define-operator/none :ret ()
2004 (opcode #xc3))
2005
2006 ;;;;;;;;;;; SAR
2007
2008 (define-operator/8 :sarb (count dst)
2009 (case count
2010 (1 (modrm dst #xd0 7))
2011 (:cl (modrm dst #xd2 7)))
2012 (imm-modrm count dst #xc0 7 (uint 8)))
2013
2014 (define-operator* (:16 :sarw :32 :sarl :64 :sarr) (count dst)
2015 (case count
2016 (1 (modrm dst #xd1 7))
2017 (:cl (modrm dst #xd3 7)))
2018 (imm-modrm count dst #xc1 7 (uint 8)))
2019
2020 ;;;;;;;;;;; SBB
2021
2022 (define-operator/8 :sbbb (subtrahend dst)
2023 (imm subtrahend #x1c (xint 8) (dst :al))
2024 (imm-modrm subtrahend dst #x80 3 (xint 8))
2025 (reg-modrm dst subtrahend #x1a)
2026 (reg-modrm subtrahend dst #x18))
2027
2028 (define-operator* (:16 :sbbw :32 :sbbl :64 :sbbr) (subtrahend dst)
2029 (imm-modrm subtrahend dst #x83 3 (sint 8))
2030 (imm subtrahend #x1d :int-16-32-64 (dst :ax-eax-rax))
2031 (imm-modrm subtrahend dst #x81 3 :int-16-32-64)
2032 (reg-modrm dst subtrahend #x1b)
2033 (reg-modrm subtrahend dst #x19))
2034
2035 ;;;;;;;;;;; SGDT
2036
2037 (define-operator/8 :sgdt (addr)
2038 (modrm addr #x0f01 0))
2039
2040 ;;;;;;;;;;; SHL
2041
2042 (define-operator/8 :shlb (count dst)
2043 (case count
2044 (1 (modrm dst #xd0 4))
2045 (:cl (modrm dst #xd2 4)))
2046 (imm-modrm count dst #xc0 4 (uint 8)))
2047
2048 (define-operator* (:16 :shlw :32 :shll :64 :shlr) (count dst)
2049 (case count
2050 (1 (modrm dst #xd1 4))
2051 (:cl (modrm dst #xd3 4)))
2052 (imm-modrm count dst #xc1 4 (uint 8)))
2053
2054 ;;;;;;;;;;; SHLD
2055
2056 (define-operator* (:16 :shldw :32 :shldl :64 :shldr) (count dst1 dst2)
2057 (when (eq :cl count)
2058 (reg-modrm dst1 dst2 #x0fa5))
2059 (when (immediate-p count)
2060 (let ((immediate (resolve-operand count)))
2061 (when (typep immediate '(uint #x8))
2062 (reg-modrm dst1 dst2 #x0fa4
2063 nil
2064 :immediate (encode-integer count '(uint 8)))))))
2065
2066 ;;;;;;;;;;; SHR
2067
2068 (define-operator/8 :shrb (count dst)
2069 (case count
2070 (1 (modrm dst #xd0 5))
2071 (:cl (modrm dst #xd2 5)))
2072 (imm-modrm count dst #xc0 5 (uint 8)))
2073
2074 (define-operator* (:16 :shrw :32 :shrl :64 :shrr) (count dst)
2075 (case count
2076 (1 (modrm dst #xd1 5))
2077 (:cl (modrm dst #xd3 5)))
2078 (imm-modrm count dst #xc1 5 (uint 8)))
2079
2080 ;;;;;;;;;;; SHRD
2081
2082 (define-operator* (:16 :shrdw :32 :shrdl :64 :shrdr) (count dst1 dst2)
2083 (when (eq :cl count)
2084 (reg-modrm dst1 dst2 #x0fad))
2085 (when (immediate-p count)
2086 (let ((immediate (resolve-operand count)))
2087 (when (typep immediate '(uint #x8))
2088 (reg-modrm dst1 dst2 #x0fac
2089 nil
2090 :immediate (encode-integer count '(uint 8)))))))
2091
2092
2093 ;;;;;;;;;;; STC, STD, STI
2094
2095 (define-operator/none :stc ()
2096 (opcode #xf9))
2097
2098 (define-operator/none :std ()
2099 (opcode #xfd))
2100
2101 (define-operator/none :sti ()
2102 (opcode #xfb))
2103
2104 ;;;;;;;;;;; SUB
2105
2106 (define-operator/8 :subb (subtrahend dst)
2107 (imm subtrahend #x2c (xint 8) (dst :al))
2108 (imm-modrm subtrahend dst #x80 5 (xint 8))
2109 (reg-modrm dst subtrahend #x2a)
2110 (reg-modrm subtrahend dst #x28))
2111
2112 (define-operator* (:16 :subw :32 :subl :64 :subr) (subtrahend dst)
2113 (imm-modrm subtrahend dst #x83 5 (sint 8))
2114 (imm subtrahend #x2d :int-16-32-64 (dst :ax-eax-rax))
2115 (imm-modrm subtrahend dst #x81 5 :int-16-32-64)
2116 (reg-modrm dst subtrahend #x2b)
2117 (reg-modrm subtrahend dst #x29))
2118
2119 ;;;;;;;;;;; TEST
2120
2121 (define-operator/8 :testb (mask dst)
2122 (imm mask #xa8 (xint 8) (dst :al))
2123 (imm-modrm mask dst #xf6 0 (xint 8))
2124 (reg-modrm mask dst #x84))
2125
2126 (define-operator* (:16 :testw :32 :testl :64 :testr) (mask dst)
2127 (imm mask #xa9 :int-16-32-64 (dst :ax-eax-rax))
2128 (imm-modrm mask dst #xf7 0 :int-16-32-64)
2129 (reg-modrm mask dst #x85))
2130
2131 ;;;;;;;;;;; WBINVD, WSRMSR
2132
2133 (define-operator/none :wbinvd ()
2134 (opcode #x0f09))
2135
2136 (define-operator/none :wrmsr ()
2137 (opcode #x0f30))
2138
2139 ;;;;;;;;;;; XCHG
2140
2141 (define-operator/8 :xchgb (x y)
2142 (reg-modrm y x #x86)
2143 (reg-modrm x y #x86))
2144
2145 (define-operator* (:16 :xchgw :32 :xchgl :64 :xchgr) (x y)
2146 (opcode-reg #x90 x (y :ax-eax-rax))
2147 (opcode-reg #x90 y (x :ax-eax-rax))
2148 (reg-modrm x y #x87)
2149 (reg-modrm y x #x87))
2150
2151 ;;;;;;;;;;; XOR
2152
2153 (define-operator/8 :xorb (src dst)
2154 (imm src #x34 (xint 8) (dst :al))
2155 (imm-modrm src dst #x80 6 (xint 8))
2156 (reg-modrm dst src #x32)
2157 (reg-modrm src dst #x30))
2158
2159 (define-operator* (:16 :xorw :32 :xorl :64 :xorr) (src dst)
2160 (imm-modrm src dst #x83 6 (sint 8))
2161 (imm src #x35 :int-16-32-64 (dst :ax-eax-rax))
2162 (imm-modrm src dst #x81 6 :int-16-32-64)
2163 (reg-modrm dst src #x33)
2164 (reg-modrm src dst #x31))
git repository of the movitz source code