asm-x86.lisp

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