def-instr.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 20012000, 2003-2004, Frode Vatved Fjeld
   4 ;;;;
   5 ;;;; Filename:      def-instr.lisp
   6 ;;;; Description:
   7 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   8 ;;;; Created at:    Thu May  4 16:41:20 2000
   9 ;;;; Distribution:  See the accompanying file COPYING.
  10 ;;;;
  11 ;;;; $Id: def-instr.lisp,v 1.3 2004/02/10 00:03:19 ffjeld Exp $
  12 ;;;;
  13 ;;;;------------------------------------------------------------------
  14
  15 (in-package #:ia-x86)
  16
  17 (defvar *instr-definitions* (make-hash-table))
  18
  19 (defmacro def-instr-template (&rest args)
  20   `(pushnew ',args
  21             (gethash ',(car args) *instr-definitions*)
  22             :test #'equalp))
  23
  24 (defun init-instruction-tables ()
  25   (template-forget-all)
  26   (maphash (lambda (name instr-specs)
  27              (let ((templates (loop for instr-spec in instr-specs
  28                                   collect (make-instr-template instr-spec))))
  29                (templates-remember name templates)))
  30            *instr-definitions*)
  31   (table-stats "ia-x86:     " *template-table*)
  32   (table-stats "ia-x86 2op: " *template-table-0f*))
  33
  34 (defun make-instr-template (instr-spec)
  35   (destructuring-bind (base-class
  36                        ((match-numo match-val match-mask ; template
  37                                     &optional not-list ; ((not-value not-mask) ...)
  38                                     (req-prefixes '())
  39                                     (not-prefixes '()))
  40                         (&optional (modr/m-p nil)
  41                                    (sib-p nil)
  42                                    (disp-numo 0) ; format
  43                                    (imm-numo 0)
  44                                    (opcode-numo 1)))
  45                        operand-types
  46                        operand-encoding-set
  47                        &key priority
  48                             (cpu-mode :any-mode)
  49                             (operand-mode :any-mode)
  50                             (addressing-mode :any-mode))
  51       instr-spec
  52     (check-type not-list list)
  53     (check-type cpu-mode (member :16-bit :32-bit :any-mode))
  54     (check-type operand-mode (member :16-bit :32-bit :any-mode))
  55     (check-type addressing-mode (member :16-bit :32-bit :any-mode))
  56     (assert (null (intersection req-prefixes not-prefixes))
  57         (req-prefixes not-prefixes)
  58       "def-instr-template ~A has overlapping match-prefix-sets: [~A] ~~[~A]"
  59       base-class
  60       req-prefixes
  61       not-prefixes)
  62     (let ((operand-classes
  63            (when operand-encoding-set
  64              (mapcar #'(lambda (ot)
  65                          (let ((encodings (gethash ot *operand-encoding-by-type*)))
  66                            (unless encodings
  67                              (warn "Operand-type ~A has no encodings." ot)
  68                              (return-from make-instr-template nil))
  69                            (let ((c (intersection encodings
  70                                                   (union operand-encoding-set
  71                                                          '(immediate-constant
  72                                                            register-constant)))))
  73                              (case (length c)
  74                                ((0) (warn "[~A] No match for ~A in ~A"
  75                                           base-class encodings operand-encoding-set)
  76                                     (return-from make-instr-template nil)) ; inconsistent template
  77                                ((1) (find-operand-class (first c) ot))
  78                                (t   (error
  79                                      "Operand set intersection for ot ~A too big (was ~A)"
  80                                      ot c))))))
  81                      operand-types))))
  82       (make-instance 'instr-template
  83         'value match-val
  84         'mask match-mask
  85         'priority (or priority +template-default-priority+)
  86         'numo match-numo
  87         'not-list not-list
  88         'cpu-mode cpu-mode
  89         'operand-mode operand-mode
  90         'addressing-mode addressing-mode
  91         'req-prefixes req-prefixes
  92         'not-prefixes not-prefixes
  93         'instr-numo (+ (if modr/m-p 1 0)
  94                        (if sib-p 1 0)
  95                        disp-numo
  96                        imm-numo
  97                        opcode-numo)
  98         'instr-classname base-class
  99         'instr-operand-types operand-types
 100         'instr-operand-classes operand-classes
 101         'instr-operand-base-classes (mapcar #'operand-class-base-class
 102                                             operand-classes)
 103         ;; instruction format
 104         'modr/m-p modr/m-p
 105         'sib-p sib-p
 106         'displacement-numo disp-numo
 107         'immediate-numo imm-numo
 108         'opcode-numo opcode-numo))))
 109
 110
 111 #+ignore
 112 (defmacro def-instr-template (base-class
 113                               ((match-numo match-val match-mask ; template
 114                                 &optional not-list ; ((not-value not-mask) ...)
 115                                           (req-prefixes '())
 116                                           (not-prefixes '()))
 117                                (&optional (modr/m-p nil)
 118                                           (sib-p nil)
 119                                           (disp-numo 0) ; format
 120                                           (imm-numo 0)
 121                                           (opcode-numo 1)))
 122                               operand-types
 123                               operand-encoding-set
 124                               &key priority
 125                                    (cpu-mode :any-mode)
 126                                    (operand-mode :any-mode)
 127                                    (addressing-mode :any-mode))
 128   (check-type not-list list)
 129   (check-type cpu-mode (member :16-bit :32-bit :any-mode))
 130   (check-type operand-mode (member :16-bit :32-bit :any-mode))
 131   (check-type addressing-mode (member :16-bit :32-bit :any-mode))
 132   (assert (null (intersection req-prefixes not-prefixes))
 133       (req-prefixes not-prefixes)
 134     "def-instr-template ~A has overlapping match-prefix-sets: [~A] ~~[~A]"
 135     base-class
 136     req-prefixes
 137     not-prefixes)
 138   (let ((operand-classes
 139          (when operand-encoding-set
 140            (mapcar #'(lambda (ot)
 141                        (let ((encodings (gethash ot *operand-encoding-by-type*)))
 142                          (unless encodings
 143                            (warn "Operand-type ~A has no encodings." ot)
 144                            (return-from def-instr-template nil))
 145                          (let ((c (intersection encodings
 146                                                 (union operand-encoding-set
 147                                                        '(immediate-constant
 148                                                          register-constant)))))
 149                            (case (length c)
 150                              ((0) (warn "[~A] No match for ~A in ~A"
 151                                         base-class encodings operand-encoding-set)
 152                                   (return-from def-instr-template nil)) ; inconsistent template
 153                              ((1) (find-operand-class (first c) ot))
 154                              (t   (error
 155                                    "Operand set intersection for ot ~A too big (was ~A)"
 156                                    ot c))))))
 157                    operand-types))))
 158
 159     `(make-instance 'instr-template
 160        'value ,match-val
 161        'mask ,match-mask
 162        'priority ,(or priority +template-default-priority+)
 163        'numo ,match-numo
 164        'not-list ',not-list
 165        'cpu-mode ,cpu-mode
 166        'operand-mode ,operand-mode
 167        'addressing-mode ,addressing-mode
 168        'req-prefixes ',req-prefixes
 169        'not-prefixes ',not-prefixes
 170        'instr-numo ,(+ (if modr/m-p 1 0)
 171                        (if sib-p 1 0)
 172                        disp-numo
 173                        imm-numo
 174                        opcode-numo)
 175        'instr-classname ',base-class
 176        'instr-operand-types ',operand-types
 177        'instr-operand-classes ',operand-classes
 178        'instr-operand-base-classes (mapcar #'operand-class-base-class
 179                                            ',operand-classes)
 180        ;; instruction format
 181        'modr/m-p ,modr/m-p
 182        'sib-p ,sib-p
 183        'displacement-numo ,disp-numo
 184        'immediate-numo ,imm-numo
 185        'opcode-numo ,opcode-numo)))
 186
 187
 188 ;;; ----------------------------------------------------------------
 189 ;;;     Instruction format:      /r and /digit
 190 ;;; ----------------------------------------------------------------
 191
 192
 193 (defparameter +operand-table-indirect+
 194     '(((register-reg indirect-register-mod00) ; 00  modR/M
 195        nil (nil 0) 1 #x00 #xc0 #x04 #x06)
 196       ((register-reg indirect-register-00-sib) ; 00  modR/M + SIB, index/=4 base/=5
 197        nil (t   0) 2 #x0400 #xc700 #x0005 #x0007 #x0020 #x0038)
 198       ((register-reg indirect-register-00-sib-base5) ; 00  modR/M + SIB + disp32,
 199        nil (t   4) 2 #x0405 #xc707 #x0020 #x0038) ;  index/=4 base=5
 200       ((register-reg indirect-register-00-sib-index4)
 201        nil (t   0) 2 #x0420 #xc738 #x0005 #x0007) ; index=4, base/=5
 202       ((register-reg indirect-pointer-00-sib-index4-base5)
 203        nil (t   4) 2 #x0425 #xc73f)     ; 00  modR/M + SIB + disp32, index=4, base=5
 204       ((register-reg indirect-pointer-00)
 205        nil (nil 4) 1 #x05 #xc7)         ; 00  modR/M + disp32
 206       ((register-reg indirect-register-01)
 207        nil (nil 1) 1 #x40 #xc0 #x04 #x07) ; 01 modR/M + disp8
 208       ((register-reg indirect-register-01-sib)
 209        nil (t   1) 2 #x4400 #xc700 #x0020 #x0038) ; 01 modR/M + SIB + disp8
 210       ((register-reg indirect-register-01-sib-index4)
 211        nil (t   1) 2 #x4420 #xc738)     ; 01 modR/M + SIB + disp8
 212       ((register-reg indirect-register-10)
 213        nil (nil 4) 1 #x80 #xc0 #x04 #x07) ; 10 modR/M + disp32
 214       ((register-reg indirect-register-10-sib)
 215        nil (t   4) 2 #x8400 #xc700 #x0020 #x0038) ; 10 modR/M + SIB + disp32
 216       ((register-reg indirect-register-10-sib-index4)
 217        nil (t   4) 2 #x8420 #xc738)
 218       ;; 16-bit [IISR table 1: "16-bit addressing forms"]
 219       ((register-reg 16bit-indirect-register-mod00)
 220        t   (nil 0) 1 #x00 #xc0 #x06 #x07) ; 00
 221       ((register-reg 16bit-indirect-pointer)
 222        t   (nil 2) 1 #x06 #xc7)         ; 00
 223       ((register-reg 16bit-indirect-register-mod01)
 224        t   (nil 1) 1 #x40 #xc0)         ; 01
 225       ((register-reg 16bit-indirect-register-mod10)
 226        t   (nil 2) 1 #x80 #xc0)))               ; 10
 227
 228 (defparameter +operand-table-direct+
 229     '(((register-reg register-r/m)
 230        dont-care (nil 0) 1 #xc0 #xc0))) ; 11 -- same for 16 and 32-bit
 231 ;;;      ((register-reg register-r/m) ; same as 32-bit.
 232 ;;;       t   (nil 0) 1 #xc0 #xc0)))    ; 11)
 233
 234
 235 (eval-when (:compile-toplevel :load-toplevel :execute)
 236   (defun canonical-opcode (byte)
 237     (cond
 238      ((complexp byte)
 239       byte)
 240      ((and (integerp byte)
 241            (<= #x00 byte #xff))
 242       (complex byte 1))
 243      ((and (integerp byte)
 244            (<= #x0f00 byte #x0fff))
 245       (complex byte 2))
 246      (t (error "Illegal opcode byte ~A" byte)))))
 247
 248 (defmacro def-instr/r-and-/digit (class opcode-byte-spec
 249                                   (&optional (imm-numo 0) (digit nil))
 250                                   operand-types
 251                                   &key req-prefixes not-prefixes
 252                                        (operand-mode :any-mode)
 253                                        (cpu-mode :any-mode)
 254                                        priority
 255                                        (indirect nil) ; only indirect operands?
 256                                        (direct nil)) ; only direct operands?
 257   (assert (not (and indirect direct))
 258       (indirect direct)
 259     "An instruction can't be both direct and indirect-only.")
 260   (unless (typep digit '(or (unsigned-byte 3) null))
 261     (error "def-instr/r-and-/digit: digit <~A> must be of 3-bit value." digit))
 262   (let ((opcode-byte (canonical-opcode opcode-byte-spec))
 263         forms)
 264     (dolist                             ; 32-bit [IISR table 2: "32-bits addressing forms"]
 265         (efmt (append (and (not direct) +operand-table-indirect+)
 266                       (and (not indirect) +operand-table-direct+)))
 267       (destructuring-bind (operand-encodings 16-bit-addr-p fmt match-numo match-value match-mask
 268                            &rest not-list-flat)
 269           efmt
 270         (push `(def-instr-template ,class
 271                    ((,(+ (imagpart opcode-byte) ; prepend opcode-byte to match-value and mask..
 272                          match-numo)
 273                      ,(dpb (realpart opcode-byte) ; match-value
 274                            (byte (* 8 (imagpart opcode-byte))
 275                                  (* 8 match-numo))
 276                            (dpb (or digit 0)
 277                                 (byte 3 (- (* 8 match-numo) 5))
 278                                 match-value))
 279                      ,(dpb -1           ; match-mask
 280                            (byte (* 8 (imagpart opcode-byte))
 281                                  (* 8 match-numo))
 282                            (dpb (if digit #b111 #b000)
 283                                 (byte 3 (- (* 8 match-numo) 5))
 284                                 match-mask))
 285                      ,(loop for i on not-list-flat by #'cddr ; unflatten not-list by twos.
 286                           collect (subseq i 0 2))
 287                      ,req-prefixes
 288                      ,not-prefixes)
 289                     (t ,@fmt ,imm-numo ,(imagpart opcode-byte)))
 290                  ,operand-types
 291                  ,(if (zerop imm-numo)
 292                       operand-encodings
 293                     (cons 'immediate
 294                           operand-encodings))
 295                  :priority ,priority
 296                  :cpu-mode ,cpu-mode
 297                  :operand-mode ,operand-mode
 298                  :addressing-mode ,(ecase 16-bit-addr-p
 299                                      ((t) :16-bit)
 300                                      ((nil) :32-bit)
 301                                      ((dont-care) :any-mode)))
 302               forms)))
 303     (values (cons 'list (nreverse forms)))))
 304
 305 (defmacro def-instr/r (class opcode-byte operand-types &rest key-args)
 306   `(def-instr/r-and-/digit ,class ,opcode-byte ()
 307                            ,operand-types
 308                            ,@key-args))
 309
 310 (defmacro def-instr/r-imm (class opcode-byte imm-numo operand-types
 311                            &rest key-args)
 312   `(def-instr/r-and-/digit ,class ,opcode-byte (,imm-numo)
 313                            ,operand-types
 314                            ,@key-args))
 315
 316 (defmacro def-instr/digit (class (opcode-byte digit) imm-numo operand-types
 317                            &rest key-args)
 318   `(def-instr/r-and-/digit ,class ,opcode-byte (,imm-numo ,digit)
 319                            ,operand-types
 320                            ,@key-args))
 321
 322 ;;; ----------------------------------------------------------------
 323 ;;;                  Instruction format: moffs
 324 ;;; ----------------------------------------------------------------
 325
 326 (defmacro def-instr/moffs (base-class opcode operand-types)
 327   (multiple-value-bind (addressing-mode disp-numo)
 328       (cond
 329        ((member 'moffs8 operand-types)
 330         (values :any-mode 1))
 331        ((member 'moffs16 operand-types)
 332         (values :16-bit 2))
 333        ((member 'moffs32 operand-types)
 334         (values :32-bit 4))
 335        (t (error "No moffsXX operand-type in specification of moffs instruction ~A."
 336                  base-class)))
 337     `(list (def-instr-template ,base-class
 338                ((1 ,opcode #xff () () ())
 339                 (nil nil ,disp-numo 0))
 340              ,operand-types
 341              (abs-pointer-moffs)
 342              :addressing-mode ,addressing-mode))))
 343
 344 ;;; ----------------------------------------------------------------
 345 ;;;                  Instruction format: /+
 346 ;;; ----------------------------------------------------------------
 347
 348 (defmacro def-instr/+ (class opcode-spec imm-numo operand-types
 349                        &key req-prefixes not-prefixes
 350                             (operand-mode :any-mode)
 351                             (addressing-mode :any-mode))
 352   (let ((opcode-byte (canonical-opcode opcode-spec)))
 353     (assert (zerop (ldb (byte 3 0) (realpart opcode-byte)))
 354         (opcode-byte)
 355       "The 3 lower bits of the opcode of a +rX-type instruction must be zero")
 356     `(list (def-instr-template ,class
 357                ((,(imagpart opcode-byte)
 358                  ,(realpart opcode-byte)
 359                  -8 () ,req-prefixes ,not-prefixes) (nil nil 0 ,imm-numo ,(imagpart opcode-byte)))
 360              ,operand-types
 361              (register-plus immediate)
 362              :operand-mode ,operand-mode
 363              :addressing-mode ,addressing-mode))))
 364
 365 ;;; ----------------------------------------------------------------
 366 ;;;                  Instruction format: "plain"
 367 ;;; ----------------------------------------------------------------
 368
 369 (defmacro def-instr/plain (class opcode-spec (disp-numo imm-numo) operand-types
 370                            &key req-prefixes not-prefixes priority
 371                                 (cpu-mode :any-mode)
 372                                 (operand-mode :any-mode)
 373                                 (addressing-mode :any-mode))
 374   (let ((opcode-byte (canonical-opcode opcode-spec)))
 375     `(list (def-instr-template ,class
 376          ((,(imagpart opcode-byte) ,(realpart opcode-byte) -1 () ,req-prefixes ,not-prefixes)
 377           (nil nil ,disp-numo ,imm-numo ,(imagpart opcode-byte)))
 378        ,operand-types
 379        (immediate-constant register-constant
 380         ,@(unless (zerop imm-numo)
 381             '(immediate imm8 simm8 imm16-8 imm8-0))
 382           ,@(unless (zerop disp-numo)
 383               '(plain-displacement pc-relative ptr16-16 ptr16-32)))
 384        :priority ,priority
 385        :cpu-mode ,cpu-mode
 386        :operand-mode ,operand-mode
 387        :addressing-mode ,addressing-mode))))
 388
 389 (defmacro def-instr/simple (class-name opcode
 390                             &key req-prefixes not-prefixes priority
 391                                  (operands ())
 392                                  (operand-mode :any-mode)
 393                                  (addressing-mode :any-mode))
 394   `(def-instr/plain ,class-name ,opcode (0 0) ,operands
 395                     :req-prefixes ,req-prefixes
 396                     :not-prefixes ,not-prefixes
 397                     :priority ,priority
 398                     :operand-mode ,operand-mode
 399                     :addressing-mode ,addressing-mode))
 400
 401
 402 (defmacro def-instr/simple-fp (class-name opcode
 403                                &key req-prefixes not-prefixes)
 404   `(def-instr/simple ,class-name ,opcode
 405      :req-prefixes ,req-prefixes
 406      :not-prefixes ,not-prefixes))
 407
 408
 409 (defmacro def-instr/jcc (name opcode &rest rest-args)
 410   `(def-instr/plain ,name ,opcode (1 0) (rel8) ,@rest-args))
 411
 412 (defmacro def-instr/jcc2 (name opcode &rest rest-args)
 413   `(progn
 414      (def-instr/plain ,name ,(cl:complex (cl:logior #x0f00 opcode) 2)
 415        (4 0) (rel32) :operand-mode :32-bit ,@rest-args)
 416      (def-instr/plain ,name ,(cl:complex (cl:logior #x0f00 opcode) 2)
 417        (2 0) (rel16) :operand-mode :16-bit ,@rest-args)))
 418 ;;;     (:plain ,opcode (1 0) (rel8) ,@rest-args)))
 419 ;;;     (def-instr/plain ,name ,(cl:complex (cl:logior #x0f00 opcode) 2)
 420 ;;;       (2 0) (rel16) :operand-mode :16-bit ,@rest-args)
 421
 422
 423 (defmacro def-instr/set (name opcode &key priority)
 424   `(def-instr/r ,name ,opcode (r/m8) :indirect nil :priority ,priority))
 425
 426 (defmacro def-instr (name supers &rest specs)
 427   `(progn
 428      (defclass ,name ,supers ())
 429      ,@(loop for spec in specs
 430            collecting
 431              (let ((form (ecase (first spec)
 432                            ((:r) 'def-instr/r)
 433                            ((:r-imm) 'def-instr/r-imm)
 434                            ((:digit) 'def-instr/digit)
 435                            ((:plain) 'def-instr/plain)
 436                            ((:simple) 'def-instr/simple)
 437                            ((:+) 'def-instr/+)
 438                            ((:moffs) 'def-instr/moffs)
 439                            ((:jcc) 'def-instr/jcc)
 440                            ((:jcc2) 'def-instr/jcc2)
 441                            ((:set) 'def-instr/set)
 442                            ((:simple-fp) 'def-instr/simple-fp)
 443                            )))
 444                (list* form name (rest spec))))
 445      ',name))
 446
 447