gsc/_x86.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_x86.scm"
   4
   5 ;;; Copyright (c) 2010-2012 by Marc Feeley, All Rights Reserved.
   6
   7 ;;;============================================================================
   8
   9 ;;; This module implements the x86 instruction encoding.
  10
  11 (namespace ("_x86#") ("" include))
  12 (include "~~lib/gambit#.scm")
  13
  14 (include "_assert#.scm")
  15 (include "_asm#.scm")
  16 (include "_x86#.scm")
  17 (include "_codegen#.scm")
  18
  19 (x86-implement)
  20
  21 ;;;============================================================================
  22
  23 ;;; Architecture selection (either x86-32 or x86-64).
  24
  25 (define (x86-arch-set! cgc arch)
  26   (codegen-context-arch-set! cgc arch)
  27   (if (codegen-context-listing-format cgc)
  28       (asm-listing
  29        cgc
  30        (case (codegen-context-listing-format cgc)
  31          ((gnu)
  32           (list #\tab ".code" (x86-word-width cgc)))
  33          (else ;;(nasm)
  34           (list #\tab "bits " (x86-word-width cgc)))))))
  35
  36 (define (x86-64bit-mode? cgc)
  37   (eq? (codegen-context-arch cgc) 'x86-64))
  38
  39 (define (x86-word-width cgc)
  40   (if (x86-64bit-mode? cgc) 64 32))
  41
  42 (define-macro (x86-assert-64bit-mode cgc)
  43   `(assert (x86-64bit-mode? ,cgc)
  44            "instruction only valid for x86-64"))
  45
  46 (define-macro (x86-assert-32bit-mode cgc)
  47   `(assert (not (x86-64bit-mode? ,cgc))
  48            "instruction only valid for x86-32"))
  49
  50 ;;;----------------------------------------------------------------------------
  51
  52 ;;; Instruction operands.
  53
  54 (define (x86-force-width opnd width)
  55   ;; useful for formatting to get an operand with an explicit width
  56   (vector opnd width 'dummy))
  57
  58 (define (x86-force-width? x) (and (vector? x) (fx= (vector-length x) 3)))
  59 (define (x86-force-width-opnd x) (vector-ref x 0))
  60 (define (x86-force-width-width x) (vector-ref x 1))
  61
  62 (define (x86-imm? x) (pair? x))
  63
  64 (define (x86-imm-int value #!optional (width 32)) (cons width value))
  65 (define (x86-imm-int? x) (and (pair? x) (number? (cdr x))))
  66 (define (x86-imm-int-width x) (car x))
  67 (define (x86-imm-int-value x) (cdr x))
  68
  69 (define (x86-imm-lbl label #!optional (offset 0)) (cons offset label))
  70 (define (x86-imm-lbl? x) (and (pair? x) (vector? (cdr x))))
  71 (define (x86-imm-lbl-offset x) (car x))
  72 (define (x86-imm-lbl-label x) (cdr x))
  73
  74 (define (x86-imm-late handler width) (cons width handler))
  75 (define (x86-imm-late? x) (and (pair? x) (procedure? (cdr x))))
  76 (define (x86-imm-late-width x) (car x))
  77 (define (x86-imm-late-handler x) (cdr x))
  78
  79 ;;(define (x86-glo name #!optional (offset 0))
  80 ;;  (vector name offset))
  81 ;;
  82 ;;(define (x86-glo? x) (and (vector? x) (fx= (vector-length x) 2)))
  83 ;;(define (x86-glo-name x) (vector-ref x 0))
  84 ;;(define (x86-glo-offset x) (vector-ref x 1))
  85
  86 (define (x86-mem offset #!optional (reg1 #f) (reg2 #f) (scale 0))
  87   (vector offset reg1 reg2 scale))
  88
  89 (define (x86-mem? x) (and (vector? x) (fx= (vector-length x) 4)))
  90 (define (x86-mem-offset x) (vector-ref x 0))
  91 (define (x86-mem-reg1 x) (vector-ref x 1))
  92 (define (x86-mem-reg2 x) (vector-ref x 2))
  93 (define (x86-mem-scale x) (vector-ref x 3))
  94
  95 (define (x86-mem-abs? x)
  96   (and (not (x86-mem-reg1 x))
  97        (not (x86-mem-reg2 x))))
  98
  99 ;;;----------------------------------------------------------------------------
 100
 101 ;;; Listing generation.
 102
 103 (define (x86-offset->string offset)
 104   (cond ((fx= offset 0) "")
 105         ((fx< offset 0) (number->string offset))
 106         (else           (string-append "+" (number->string offset)))))
 107
 108 (define (x86-listing cgc mnemonic width . opnds)
 109
 110   (define (instr-format-gnu)
 111
 112     (define (opnd-format opnd)
 113       (cond ((x86-force-width? opnd)
 114              (opnd-format (x86-force-width-opnd opnd)))
 115             ((x86-reg? opnd)
 116              (list "%" (x86-register-name opnd)))
 117             ((x86-imm? opnd)
 118              (list "$"
 119                    (cond ((x86-imm-int? opnd)
 120                           (x86-imm-int-value opnd))
 121                          ((x86-imm-lbl? opnd)
 122                           (list (asm-label-name (x86-imm-lbl-label opnd))
 123                                 (x86-offset->string (x86-imm-lbl-offset opnd))))
 124                          ((x86-imm-late? opnd)
 125                           ((x86-imm-late-handler opnd) cgc 'listing))
 126                          (else
 127                           (error "unknown immediate" opnd)))))
 128             #;
 129             ((x86-glo? opnd);;;;;;;;;;
 130              (let ((name (x86-glo-name opnd))
 131                    (offset (x86-glo-offset opnd)))
 132                (list name
 133                      (x86-offset->string offset))))
 134             ((x86-mem? opnd)
 135              (let ((reg1 (x86-mem-reg1 opnd))
 136                    (reg2 (x86-mem-reg2 opnd))
 137                    (scale (x86-mem-scale opnd))
 138                    (offset (x86-mem-offset opnd)))
 139                (if reg1
 140                    (let ((x
 141                           (cons "("
 142                                 (cons (opnd-format reg1)
 143                                       (if reg2
 144                                           (cons ","
 145                                                 (cons (opnd-format reg2)
 146                                                       (if (fx= scale 0)
 147                                                           '(")")
 148                                                           (list ","
 149                                                                 (fxarithmetic-shift-left
 150                                                                  1
 151                                                                  scale)
 152                                                                 ")"))))
 153                                           '(")"))))))
 154                      (if (fx= offset 0) x (cons offset x)))
 155                    offset)))
 156             (else
 157              opnd)))
 158
 159     (let ((operands
 160            (asm-separated-list (map opnd-format (reverse opnds)) ",")))
 161       (cons #\tab
 162             (cons mnemonic
 163                   (if (fx>= width 0)
 164                       (cons (x86-width-suffix cgc width)
 165                             (if (pair? operands)
 166                                 (cons #\tab
 167                                       operands)
 168                                 '()))
 169                       (if (pair? operands)
 170                           (cons #\tab
 171                                 (cons "*"
 172                                       operands))
 173                           '()))))))
 174
 175   (define (instr-format-nasm)
 176
 177     (define (data-width-qualifier width)
 178       (case width
 179         ((8)  "byte ")
 180         ((16) "word ")
 181         ((32) "dword ")
 182         ((64) "qword ")
 183         ((1)  "short ") ;; special width for short jumps
 184         (else "")))
 185
 186     (define (opnd-format opnd)
 187       (cond ((x86-force-width? opnd)
 188              (list (data-width-qualifier (x86-force-width-width opnd))
 189                    (opnd-format (x86-force-width-opnd opnd))))
 190             ((x86-reg? opnd)
 191              (x86-register-name opnd))
 192             ((x86-imm? opnd)
 193              (cond ((x86-imm-int? opnd)
 194                     (let ((value (x86-imm-int-value opnd))
 195                           (opnd-width (x86-imm-int-width opnd)))
 196                       (if (or (fx= width 8)
 197                               (fx= width opnd-width)
 198                               (and (fx= width 64)
 199                                    (fx= opnd-width 32)
 200                                    (not (equal? mnemonic "mov"))))
 201                           value
 202                           (list (data-width-qualifier opnd-width) value))))
 203                    ((x86-imm-lbl? opnd)
 204                     (list (asm-label-name (x86-imm-lbl-label opnd))
 205                           (x86-offset->string (x86-imm-lbl-offset opnd))))
 206                    ((x86-imm-late? opnd)
 207                     ((x86-imm-late-handler opnd) cgc 'listing))
 208                    (else
 209                     (error "unknown immediate" opnd))))
 210             #;
 211             ((x86-glo? opnd);;;;;;;;;;
 212              (let ((name (x86-glo-name opnd))
 213                    (offset (x86-glo-offset opnd)))
 214                (list "["
 215                      name
 216                      (x86-offset->string offset)
 217                      "]")))
 218             ((x86-mem? opnd)
 219              (let ((offset (x86-mem-offset opnd))
 220                    (reg1 (x86-mem-reg1 opnd))
 221                    (reg2 (x86-mem-reg2 opnd))
 222                    (scale (x86-mem-scale opnd)))
 223                (list "["
 224                      (if reg1
 225                          (opnd-format reg1)
 226                          "")
 227                      (if reg2
 228                          (list "+"
 229                                (opnd-format reg2)
 230                                (if (fx= scale 0)
 231                                    ""
 232                                    (list "*"
 233                                          (fxarithmetic-shift-left 1 scale))))
 234                          "")
 235                      (x86-offset->string offset)
 236                      "]")))
 237             (else
 238              opnd)))
 239
 240     (cons #\tab
 241           (cons mnemonic
 242                 (if (pair? opnds)
 243                     (let ((width-implicit? #f))
 244
 245                       (define (opnd-fmt opnd)
 246                         (if (x86-reg? opnd)
 247                             (set! width-implicit? #t))
 248                         (opnd-format opnd))
 249
 250                       (let ((opnds-listing
 251                              (asm-separated-list (map opnd-fmt opnds) ",")))
 252                         (cons #\tab
 253                               (if width-implicit?
 254                                   opnds-listing
 255                                   (cons (data-width-qualifier width)
 256                                         opnds-listing)))))
 257                     '()))))
 258
 259   (asm-listing
 260    cgc
 261    (case (codegen-context-listing-format cgc)
 262      ((gnu)
 263       (instr-format-gnu))
 264      (else ;;(nasm)
 265       (instr-format-nasm)))))
 266
 267 (define (x86-width-suffix cgc width)
 268   (case (codegen-context-listing-format cgc)
 269     ((gnu)
 270      (cond ((fx= width 64) "q")
 271            ((fx= width 32) "l")
 272            ((fx= width 16) "w")
 273            ((fx= width 8)  "b")
 274            ((fx= width 1)  "")
 275            (else           "")))
 276     (else ;;(nasm)
 277      "")))
 278
 279 (define (x86-xmm-width-suffix cgc width)
 280   (case (codegen-context-listing-format cgc)
 281     ((gnu)
 282      (cond ((fx= width 64) "d")
 283            (else           "s")))
 284     (else ;;(nasm)
 285      "")))
 286
 287 ;; Escape opcode
 288
 289 (define (x86-esc-opcode cgc)
 290   (asm-8 cgc #x0f))
 291
 292 ;;;----------------------------------------------------------------------------
 293
 294 ;;; X86 operand encoding.
 295
 296 (define (x86-opnd-prefix-reg-opnd cgc reg opnd)
 297   (let* ((width
 298           (x86-reg-width reg))
 299          (field
 300           (x86-reg-field reg))
 301          (ext-lo8-reg?
 302           (and (fx= width 8)
 303                (fx>= field 4)
 304                (not (x86-reg8-h? reg)))))
 305     (if (x86-reg? opnd)
 306         (begin
 307           (let* ((field2
 308                   (x86-reg-field opnd))
 309                  (ext-lo8-reg2?
 310                   (and (fx= (x86-reg-width opnd) 8)
 311                        (fx>= field2 4)
 312                        (not (x86-reg8-h? opnd))))
 313                  (rex?
 314                   (x86-opnd-prefix cgc
 315                                    width
 316                                    field
 317                                    opnd
 318                                    (or ext-lo8-reg? ext-lo8-reg2?))))
 319             (assert (not (and rex?
 320                               (or (x86-reg8-h? reg)
 321                                   (x86-reg8-h? opnd))))
 322                     "cannot use high 8 bit register here" reg opnd)
 323             rex?))
 324         (x86-opnd-prefix cgc
 325                          width
 326                          field
 327                          opnd
 328                          ext-lo8-reg?))))
 329
 330 (define (x86-opnd-prefix-opnd cgc width opnd)
 331   (if (x86-reg? opnd)
 332       (let* ((field
 333               (x86-reg-field opnd))
 334              (ext-lo8-reg?
 335               (and (fx= width 8)
 336                    (fx>= field 4)
 337                    (not (x86-reg8-h? opnd)))))
 338         (x86-opnd-prefix cgc width 0 opnd ext-lo8-reg?))
 339       (x86-opnd-prefix cgc width 0 opnd #f)))
 340
 341 (define (x86-opnd-modrm/sib-reg-opnd cgc reg opnd)
 342   (x86-opnd-modrm/sib cgc (x86-reg-field reg) opnd))
 343
 344 (define (x86-opnd-prefix cgc width field opnd force-rex?)
 345   (let ((rex*
 346          (fx+ ;; if needed emit REX.W (64 bit operand size)
 347               (if (and (not (fx= width 0)) ;; implicit width?
 348                        (or (fx= width 64)
 349                            (and (x86-reg? opnd) (x86-reg64? opnd))))
 350                   8
 351                   0)
 352               ;; if needed emit REX.R (Extension of the ModR/M reg field)
 353               (fxarithmetic-shift-left
 354                (fxarithmetic-shift-right
 355                 field
 356                 3)
 357                2)
 358               (cond ((x86-reg? opnd)
 359                      ;; if needed emit REX.B (Extension of
 360                      ;; the ModR/M r/m field, SIB base field,
 361                      ;; or Opcode reg field)
 362                      (fxarithmetic-shift-right
 363                       (x86-reg-field opnd)
 364                       3))
 365                     #;
 366                     ((x86-glo? opnd);;;;;;;;;;
 367                      0)
 368                     ((x86-mem? opnd)
 369                      (let ((reg1 (x86-mem-reg1 opnd)))
 370                        (if reg1
 371                            (begin
 372                              (assert (or (x86-reg32? reg1)
 373                                          (and (x86-reg64? reg1)
 374                                               (x86-64bit-mode? cgc)))
 375                                      "invalid width base register" reg1)
 376                              (fx+ ;; if needed emit REX.B (Extension of
 377                                   ;; the ModR/M r/m field, SIB base field,
 378                                   ;; or Opcode reg field)
 379                                   (fxarithmetic-shift-right
 380                                    (x86-reg-field reg1)
 381                                    3)
 382                                   (let ((reg2 (x86-mem-reg2 opnd)))
 383                                     (if reg2
 384                                         (begin
 385                                           (assert (if (x86-reg32? reg1)
 386                                                       (x86-reg32? reg2)
 387                                                       (x86-reg64? reg2))
 388                                                   "index register must have same width as base" reg2)
 389                                           ;; if needed emit REX.X (Extension
 390                                           ;; of the SIB index field)
 391                                           (fxarithmetic-shift-left
 392                                            (fxarithmetic-shift-right
 393                                             (x86-reg-field reg2)
 394                                             3)
 395                                            1))
 396                                         0))))
 397                            0)))
 398                     (else
 399                      (error "unknown operand" opnd))))))
 400     (x86-opnd-size-override-prefix cgc width)
 401     (x86-addr-size-override-prefix cgc opnd)
 402     (if (or force-rex?
 403             (not (fx= rex* 0)))
 404         (begin
 405           (x86-assert-64bit-mode cgc)
 406           (asm-8 cgc (fx+ #x40 rex*)) ;; REX
 407           #t)
 408         #f)))
 409
 410 (define (x86-opnd-size-override-prefix cgc width)
 411   (if (fx= width 16)
 412       (asm-8 cgc #x66))) ;; operand size override prefix
 413
 414 (define (x86-addr-size-override-prefix cgc opnd)
 415   (if (and (x86-mem? opnd)
 416            (let ((reg1 (x86-mem-reg1 opnd)))
 417              (and reg1
 418                   (eq? (x86-64bit-mode? cgc)
 419                        (not (x86-reg64? reg1))))))
 420       (asm-8 cgc #x67))) ;; address size override prefix
 421
 422 (define (x86-abs-addr cgc label offset width)
 423
 424   (assert (fx= width 32)
 425           "x86-abs-addr expects width=32" width)
 426
 427   (let ((lbl (asm-make-label cgc 'fixup)))
 428
 429     (codegen-context-fixup-list-set!
 430      cgc
 431      (cons lbl
 432            (codegen-context-fixup-list cgc)))
 433
 434     (asm-label cgc lbl)
 435     (asm-at-assembly
 436
 437      cgc
 438
 439      (lambda (cgc self)
 440        4)
 441      (lambda (cgc self)
 442        (asm-32-le cgc (fx+ (asm-label-pos label) offset))))))
 443
 444 (define (x86-opnd-modrm/sib cgc field opnd)
 445   (let ((modrm-rf
 446          (fxarithmetic-shift-left (fxand 7 field) 3)))
 447
 448     (define (abs-addr)
 449       (if (x86-64bit-mode? cgc) ;; avoid RIP relative encoding?
 450           (begin
 451             (asm-8 cgc (fx+ modrm-rf 4)) ;; ModR/M
 452             (asm-8 cgc #x25))            ;; SIB
 453           (asm-8 cgc (fx+ modrm-rf 5)))) ;; ModR/M
 454
 455     (cond ((x86-reg? opnd)
 456            (let ((modrm*
 457                   (fx+ modrm-rf (fxand 7 (x86-reg-field opnd)))))
 458              (asm-8 cgc (fx+ #xc0 modrm*)))) ;; ModR/M
 459
 460           #;
 461           ((x86-glo? opnd);;;;;;;;;;
 462            (abs-addr)
 463            (let ((name (x86-glo-name opnd))
 464                  (offset (x86-glo-offset opnd)))
 465              (x86-abs-addr cgc (nat-global-lookup cgc name) offset 32)))
 466
 467           ((x86-mem? opnd)
 468            (let ((offset (x86-mem-offset opnd))
 469                  (reg1   (x86-mem-reg1 opnd)))
 470
 471              (if reg1
 472
 473                  (let* ((field1    (x86-reg-field reg1))
 474                         (field1-lo (fxand 7 field1))
 475                         (reg2      (x86-mem-reg2 opnd)))
 476
 477                    (if (or reg2 ;; need a SIB when using an index
 478                            (fx= field1-lo 4)) ;; register or base = RSP/R12
 479
 480                        ;; SIB needed
 481
 482                        (let ((modrm*
 483                               (fx+ modrm-rf 4))
 484                              (sib
 485                               (fx+ field1-lo
 486                                    (if reg2
 487                                        (let ((field2 (x86-reg-field reg2)))
 488                                          (assert (not (fx= field2 4))
 489                                                  "SP not allowed as index" reg2)
 490                                          (fx+ (fxarithmetic-shift-left
 491                                                (fxand 7 field2)
 492                                                3)
 493                                               (fxarithmetic-shift-left
 494                                                (x86-mem-scale opnd)
 495                                                6)))
 496                                        #x20)))) ;; no index and no scaling
 497
 498                          (if (asm-signed8? offset)
 499                              (if (or (not (fx= offset 0)) ;; non-null offset?
 500                                      (fx= field1 5))      ;; or RBP
 501                                  (begin ;; use 8 bit displacement
 502                                    (asm-8 cgc (fx+ #x40 modrm*)) ;; ModR/M
 503                                    (asm-8 cgc sib) ;; SIB
 504                                    (asm-8 cgc offset))
 505                                  (begin
 506                                    (asm-8 cgc (fx+ #x00 modrm*)) ;; ModR/M
 507                                    (asm-8 cgc sib))) ;; SIB
 508                              (begin ;; use 32 bit displacement
 509                                (asm-8 cgc (fx+ #x80 modrm*)) ;; ModR/M
 510                                (asm-8 cgc sib)               ;; SIB
 511                                (asm-32-le cgc offset))))
 512
 513                        ;; SIB not needed
 514
 515                        (let ((modrm*
 516                               (fx+ modrm-rf field1-lo)))
 517                          (if (asm-signed8? offset)
 518                              (if (or (not (fx= offset 0)) ;; non-null offset?
 519                                      (fx= field1-lo 5)) ;; or RBP/R13
 520                                  (begin ;; use 8 bit displacement
 521                                    (asm-8 cgc (fx+ #x40 modrm*)) ;; ModR/M
 522                                    (asm-8 cgc offset))
 523                                  (asm-8 cgc (fx+ #x00 modrm*))) ;; ModR/M
 524                              (begin ;; use 32 bit displacement
 525                                (asm-8 cgc (fx+ #x80 modrm*)) ;; ModR/M
 526                                (asm-32-le cgc offset))))))
 527
 528                  (begin ;; absolute address, use disp32 ModR/M
 529                    (abs-addr)
 530                    (asm-32-le cgc offset)))))
 531
 532           (else
 533            (error "unknown operand" opnd)))))
 534
 535 (define (x86-imm-encode cgc imm imm-width)
 536   (cond ((x86-imm-int? imm)
 537          (let* ((n1 (x86-imm-int-value imm))
 538                 (n2 (asm-int-le cgc n1 imm-width)))
 539            (assert (= n1 n2)
 540                    "immediate operand has been truncated" n1 imm-width)
 541            (x86-imm-int n2 imm-width)))
 542         ((x86-imm-lbl? imm)
 543          (x86-imm-lbl-encode cgc imm imm-width)
 544          imm)
 545         ((x86-imm-late? imm)
 546          ((x86-imm-late-handler imm) cgc 'encode))
 547         (else
 548          (error "unknown immediate"))))
 549
 550 (define (x86-imm-lbl-encode cgc imm-lbl imm-width)
 551   (let ((lbl (asm-make-label cgc 'fixup)))
 552     (codegen-context-fixup-list-set!
 553      cgc
 554      (cons (cons lbl imm-width)
 555            (codegen-context-fixup-list cgc)))
 556     (asm-label cgc lbl)
 557     (asm-at-assembly
 558
 559      cgc
 560
 561      (lambda (cb self)
 562        (fxarithmetic-shift-right imm-width 3))
 563
 564      (lambda (cb self)
 565        (let ((dist
 566               (fx+ (asm-label-pos (x86-imm-lbl-label imm-lbl))
 567                    (x86-imm-lbl-offset imm-lbl))))
 568          (asm-int-le cb dist imm-width))))))
 569
 570 ;;;----------------------------------------------------------------------------
 571
 572 ;;; X86 pseudo operations.
 573
 574 (define (x86-label cgc label)
 575   (asm-label cgc label)
 576   (if (codegen-context-listing-format cgc)
 577       (asm-listing cgc (list (asm-label-name label) ":"))))
 578
 579 (define (x86-db cgc . elems)
 580   (x86-data-elems cgc elems 8))
 581
 582 (define (x86-dw cgc . elems)
 583   (x86-data-elems cgc elems 16))
 584
 585 (define (x86-dd cgc . elems)
 586   (x86-data-elems cgc elems 32))
 587
 588 (define (x86-dq cgc . elems)
 589   (x86-data-elems cgc elems 64))
 590
 591 (define (x86-data-elems cgc elems width)
 592
 593   (define max-per-line 4)
 594
 595   (let ((v (list->vector elems)))
 596     (let loop1 ((i 0))
 597       (if (fx< i (vector-length v))
 598           (let ((lim (fxmin (fx+ i max-per-line) (vector-length v))))
 599             (let loop2 ((j i) (rev-lst '()))
 600               (if (fx< j lim)
 601                   (let ((x (vector-ref v j)))
 602                     (asm-int-le cgc x width)
 603                     (loop2 (fx+ j 1) (cons x rev-lst)))
 604                   (begin
 605                     (if (codegen-context-listing-format cgc)
 606                         (asm-listing
 607                          cgc
 608                          (list #\tab
 609                                (case (codegen-context-listing-format cgc)
 610                                  ((gnu)
 611                                   (cond ((fx= width 8)  ".byte")
 612                                         ((fx= width 16) ".word")
 613                                         ((fx= width 32) ".long")
 614                                         ((fx= width 64) ".quad")
 615                                         (else (error "unknown data width"))))
 616                                  (else ;;(nasm)
 617                                   (cond ((fx= width 8)  "db")
 618                                         ((fx= width 16) "dw")
 619                                         ((fx= width 32) "dd")
 620                                         ((fx= width 64) "dq")
 621                                         (else (error "unknown data width")))))
 622                                #\tab
 623                                (asm-separated-list (reverse rev-lst) ","))))
 624                     (loop1 lim)))))))))
 625
 626 ;;;----------------------------------------------------------------------------
 627
 628 ;;; X86 instructions: ADD, OR, ADC, SBB, AND, SUB, XOR, CMP, and MOV.
 629
 630 (define (x86-add cgc opnd1 opnd2 #!optional (width #f))
 631   (x86-op cgc opnd1 opnd2 width 0))
 632
 633 (define (x86-or cgc opnd1 opnd2 #!optional (width #f))
 634   (x86-op cgc opnd1 opnd2 width 1))
 635
 636 (define (x86-adc cgc opnd1 opnd2 #!optional (width #f))
 637   (x86-op cgc opnd1 opnd2 width 2))
 638
 639 (define (x86-sbb cgc opnd1 opnd2 #!optional (width #f))
 640   (x86-op cgc opnd1 opnd2 width 3))
 641
 642 (define (x86-and cgc opnd1 opnd2 #!optional (width #f))
 643   (x86-op cgc opnd1 opnd2 width 4))
 644
 645 (define (x86-sub cgc opnd1 opnd2 #!optional (width #f))
 646   (x86-op cgc opnd1 opnd2 width 5))
 647
 648 (define (x86-xor cgc opnd1 opnd2 #!optional (width #f))
 649   (x86-op cgc opnd1 opnd2 width 6))
 650
 651 (define (x86-cmp cgc opnd1 opnd2 #!optional (width #f))
 652   (x86-op cgc opnd1 opnd2 width 7))
 653
 654 (define (x86-mov cgc opnd1 opnd2 #!optional (width #f))
 655   (x86-op cgc opnd1 opnd2 width 17))
 656
 657 (define (x86-op cgc opnd1 opnd2 width op)
 658
 659   ;; opnd1 = destination, opnd2 = source
 660
 661   (define (listing width opnd1 opnd2)
 662     (if (codegen-context-listing-format cgc)
 663         (x86-listing cgc
 664                      (if (fx<= op 7)
 665                          (vector-ref
 666                           '#("add" "or" "adc" "sbb" "and" "sub" "xor" "cmp")
 667                           op)
 668                          "mov")
 669                      width
 670                      opnd1
 671                      opnd2)))
 672
 673   (define (mov-imm)
 674
 675     (define (register-mov-imm width)
 676       (x86-opnd-prefix-opnd cgc width opnd1) ;; prefix
 677       ;; opcode = #xb0-#xb7 (for 8 bit registers)
 678       ;;       or #xb8-#xbf (for 16/32/64 bit registers)
 679       (asm-8 cgc (fx+ (if (fx= width 8) #xb0 #xb8) ;; opcode
 680                       (fxand 7 (x86-reg-field opnd1))))
 681       (listing width
 682                opnd1
 683                (x86-imm-encode cgc opnd2 width)))
 684
 685     (define (general-mov-imm width imm-width)
 686       (x86-opnd-prefix-opnd cgc width opnd1)   ;; prefix
 687       (asm-8 cgc (if (fx= width 8) #xc6 #xc7)) ;; opcode
 688       (x86-opnd-modrm/sib cgc 0 opnd1)         ;; ModR/M
 689       (listing width
 690                opnd1
 691                (x86-imm-encode cgc opnd2 imm-width)))
 692
 693     (assert (if (x86-reg? opnd1)
 694                 (or (not width)
 695                     (fx= (x86-reg-width opnd1) width))
 696                 width)
 697             "missing or inconsistent operand width" width)
 698
 699     (assert (or (x86-reg? opnd1)
 700                 (not (fx= width 64))
 701                 (and (x86-imm-int? opnd2)
 702                      (asm-signed32? (x86-imm-int-value opnd2))))
 703             "move of a 64 bit immediate only possible with register")
 704
 705     (if (x86-reg? opnd1)
 706         (let ((width (x86-reg-width opnd1)))
 707           (if (and (fx= width 64)
 708                    (x86-imm-int? opnd2)
 709                    (asm-signed32? (x86-imm-int-value opnd2)))
 710               (general-mov-imm width 32)
 711               (register-mov-imm width)))
 712         (general-mov-imm width (fxmin width 32))))
 713
 714   (define (op-imm)
 715
 716     (define (accumulator-op-imm width)
 717       (x86-opnd-prefix-opnd cgc width opnd1) ;; prefix
 718       ;; opcode = #x04, #x0c, #x14, ..., #x3c (for AL)
 719       ;;       or #x05, #x0d, #x15, ..., #x3d (for AX/EAX/RAX)
 720       (asm-8 cgc (fx+ (if (fx= width 8) #x04 #x05) ;; opcode
 721                       (fxarithmetic-shift-left op 3)))
 722       (listing width
 723                opnd1
 724                (x86-imm-encode cgc opnd2 (fxmin 32 width))))
 725
 726     (define (general-op-imm width)
 727       (x86-opnd-prefix-opnd cgc width opnd1) ;; prefix
 728       (cond ((fx= width 8)
 729              (asm-8 cgc #x80) ;; opcode = 8 bit operation
 730              (x86-opnd-modrm/sib cgc op opnd1) ;; ModR/M
 731              (listing width
 732                       opnd1
 733                       (x86-imm-encode cgc opnd2 8)))
 734             ((and (x86-imm-int? opnd2)
 735                   (asm-signed8? (x86-imm-int-value opnd2)))
 736              (asm-8 cgc #x83) ;; opcode = sign extended 8 bit imm
 737              (x86-opnd-modrm/sib cgc op opnd1) ;; ModR/M
 738              (listing width
 739                       opnd1
 740                       (x86-imm-encode cgc opnd2 8)))
 741             (else
 742              (asm-8 cgc #x81) ;; opcode = sign extended 16/32 bit imm
 743              (x86-opnd-modrm/sib cgc op opnd1) ;; ModR/M
 744              (listing width
 745                       opnd1
 746                       (x86-imm-encode cgc opnd2 (fxmin 32 width))))))
 747
 748     (assert (if (x86-reg? opnd1)
 749                 (or (not width)
 750                     (fx= (x86-reg-width opnd1) width))
 751                 width)
 752             "missing or inconsistent operand width" width)
 753
 754     (if (x86-reg? opnd1)
 755         (let ((width (x86-reg-width opnd1))
 756               (field (x86-reg-field opnd1)))
 757           (if (and (fx= field 0)
 758                    (or (fx= width 8)
 759                        (not (x86-imm-int? opnd2))
 760                        (not (asm-signed8? (x86-imm-int-value opnd2)))))
 761               (accumulator-op-imm width)
 762               (general-op-imm width)))
 763         (general-op-imm width)))
 764
 765   (define (reg-op reg opnd swapped?)
 766
 767     (assert (or (not width)
 768                 (fx= (x86-reg-width reg) width))
 769             "inconsistent operand width" width)
 770
 771     (x86-opnd-prefix-reg-opnd cgc reg opnd) ;; prefix
 772
 773     (if (and (and #f ;; comment-out for consistency with system assembler
 774                   (not (x86-64bit-mode? cgc)))
 775              (fx= op 17)                 ;; move?
 776              (fx= (x86-reg-field reg) 0) ;; accumulator?
 777              (x86-mem? opnd)             ;; absolute address
 778              (x86-mem-abs? opnd))
 779         (begin
 780           ;; opcode = #xa0/#xa2 (for 8 bit registers)
 781           ;;       or #xa1/#xa3 (for 16/32/64 bit registers)
 782           (asm-8 cgc (fx+ (if swapped? #xa2 #xa0) ;; opcode
 783                           (if (x86-reg8? reg) 0 1)))
 784           (asm-32-le cgc (x86-mem-offset opnd)))
 785         (begin
 786           (asm-8 cgc (fx+ (fxarithmetic-shift-left op 3) ;; opcode
 787                           (if swapped? 0 2)
 788                           (if (x86-reg8? reg) 0 1)))
 789           (x86-opnd-modrm/sib-reg-opnd cgc reg opnd))) ;; ModR/M
 790
 791     (listing (x86-reg-width reg)
 792              (if swapped? opnd reg)
 793              (if swapped? reg opnd)))
 794
 795   (cond ((x86-imm? opnd2)
 796          (if (fx= op 17) ;; move?
 797              (mov-imm)
 798              (op-imm)))
 799         ((x86-reg? opnd2)
 800          (reg-op opnd2 opnd1 #t))
 801         ((x86-reg? opnd1)
 802          (reg-op opnd1 opnd2 #f))
 803         (else
 804          (error "invalid operand combination" opnd1 opnd2))))
 805
 806 ;;;----------------------------------------------------------------------------
 807
 808 ;;; X86 instructions: INC and DEC.
 809
 810 (define (x86-inc cgc opnd #!optional (width #f))
 811   (x86-inc-dec cgc opnd width #x40))
 812
 813 (define (x86-dec cgc opnd #!optional (width #f))
 814   (x86-inc-dec cgc opnd width #x48))
 815
 816 (define (x86-inc-dec cgc opnd width op)
 817
 818   ;; opnd = destination
 819
 820   (define (listing width)
 821     (if (codegen-context-listing-format cgc)
 822         (x86-listing cgc
 823                      (if (fx= op #x40) "inc" "dec")
 824                      width
 825                      opnd)))
 826
 827   (define (register width)
 828     (x86-opnd-prefix-opnd cgc width opnd) ;; prefix
 829     (let ((field (x86-reg-field opnd)))
 830       (asm-8 cgc (fx+ op field))) ;; opcode
 831     (listing width))
 832
 833   (define (general width)
 834     (x86-opnd-prefix-opnd cgc width opnd)                ;; prefix
 835     (asm-8 cgc (if (fx= width 8) #xfe #xff))             ;; opcode
 836     (x86-opnd-modrm/sib cgc (if (fx= op #x40) 0 1) opnd) ;; ModR/M
 837     (listing width))
 838
 839   (assert (if (x86-reg? opnd)
 840               (or (not width)
 841                   (fx= (x86-reg-width opnd) width))
 842               width)
 843           "missing or inconsistent operand width" width)
 844
 845   (if (x86-reg? opnd)
 846       (let ((width (x86-reg-width opnd)))
 847         (if (and (not (x86-64bit-mode? cgc))
 848                  (or (fx= width 16)
 849                      (fx= width 32)))
 850             (register width)
 851             (general width)))
 852       (general width)))
 853
 854 ;;;----------------------------------------------------------------------------
 855
 856 ;;; X86 instruction: LEA.
 857
 858 (define (x86-lea cgc reg opnd)
 859
 860   ;; reg = destination, opnd = source
 861
 862   (assert (not (x86-reg8? reg))
 863           "destination of lea must not be an 8 bit register" reg)
 864
 865   (x86-opnd-prefix-reg-opnd cgc reg opnd)    ;; prefix
 866   (asm-8 cgc #x8d)                           ;; opcode
 867   (x86-opnd-modrm/sib-reg-opnd cgc reg opnd) ;; ModR/M
 868
 869   (if (codegen-context-listing-format cgc)
 870       (x86-listing cgc
 871                    "lea"
 872                    (x86-reg-width reg)
 873                    reg
 874                    opnd)))
 875
 876 ;;;----------------------------------------------------------------------------
 877
 878 ;;; X86 instruction: RET.
 879
 880 (define (x86-ret cgc #!optional (n 0))
 881   (if (fx= n 0)
 882       (begin
 883         (asm-8 cgc #xc3) ;; opcode
 884         (if (codegen-context-listing-format cgc)
 885             (x86-listing cgc
 886                          "ret"
 887                          0)))
 888       (begin
 889         (asm-8 cgc #xc2) ;; opcode
 890         (asm-16-le cgc n)
 891         (if (codegen-context-listing-format cgc)
 892             (x86-listing cgc
 893                          "ret"
 894                          0
 895                          (x86-imm-int n 0))))))
 896
 897 ;;;----------------------------------------------------------------------------
 898
 899 ;;; X86 instruction: ENTER.
 900
 901 (define (x86-enter cgc size level)
 902   (let* ((size-opnd (x86-imm-int size 16))
 903          (level-opnd (x86-imm-int level 8)))
 904     (asm-8 cgc #xc8) ;; opcode
 905     (x86-imm-encode cgc size-opnd 16)
 906     (x86-imm-encode cgc level-opnd 8)
 907
 908     (if (codegen-context-listing-format cgc)
 909         (case (codegen-context-listing-format cgc)
 910           ((gnu)
 911            (x86-listing cgc
 912                         "enter"
 913                         0
 914                         level-opnd
 915                         size-opnd))
 916           (else ;;(nasm)
 917            (x86-listing cgc
 918                         "enter"
 919                         0
 920                         (number->string size)
 921                         (number->string level)))))))
 922
 923 ;;;----------------------------------------------------------------------------
 924
 925 ;;; X86 instructions: NOP, LEAVE, HLT, CMC, CLC, STC, CLI, STI, CLD, and STD.
 926
 927 (define (x86-nop cgc) (x86-no-opnd-instr cgc #x90))
 928 (define (x86-leave cgc) (x86-no-opnd-instr cgc #xc9))
 929 (define (x86-hlt cgc) (x86-no-opnd-instr cgc #xf4))
 930 (define (x86-cmc cgc) (x86-no-opnd-instr cgc #xf5))
 931 (define (x86-clc cgc) (x86-no-opnd-instr cgc #xf8))
 932 (define (x86-stc cgc) (x86-no-opnd-instr cgc #xf9))
 933 (define (x86-cli cgc) (x86-no-opnd-instr cgc #xfa))
 934 (define (x86-sti cgc) (x86-no-opnd-instr cgc #xfb))
 935 (define (x86-cld cgc) (x86-no-opnd-instr cgc #xfc))
 936 (define (x86-std cgc) (x86-no-opnd-instr cgc #xfd))
 937
 938 (define (x86-no-opnd-instr cgc opcode)
 939
 940   (asm-8 cgc opcode) ;; opcode
 941
 942   (if (codegen-context-listing-format cgc)
 943       (x86-listing cgc
 944                    (cond ((fx= opcode #x90)
 945                           "nop")
 946                          ((fx= opcode #xc9)
 947                           "leave")
 948                          (else
 949                           (vector-ref
 950                            '#("hlt" "cmc" "???" "???" "clc" "stc"
 951                               "cli" "sti" "cld" "std")
 952                            (fx- opcode #xf4))))
 953                    0)))
 954
 955 ;;;----------------------------------------------------------------------------
 956
 957 ;;; X86 instructions: SYSCALL, SYSRET, WRMSR, RDTSC, RDMSR, RDPMC,
 958 ;;; and CPUID.
 959
 960 (define (x86-syscall cgc) (x86-no-opnd-instr-esc cgc #x05))
 961 (define (x86-sysret cgc)  (x86-no-opnd-instr-esc cgc #x07))
 962 (define (x86-wrmsr cgc) (x86-no-opnd-instr-esc cgc #x30))
 963 (define (x86-rdtsc cgc) (x86-no-opnd-instr-esc cgc #x31))
 964 (define (x86-rdmsr cgc) (x86-no-opnd-instr-esc cgc #x32))
 965 (define (x86-rdpmc cgc) (x86-no-opnd-instr-esc cgc #x33))
 966 (define (x86-cpuid cgc) (x86-no-opnd-instr-esc cgc #xa2))
 967
 968 (define (x86-no-opnd-instr-esc cgc opcode)
 969
 970   (x86-esc-opcode cgc) ;; escape opcode
 971   (asm-8 cgc opcode)   ;; opcode
 972
 973   (if (codegen-context-listing-format cgc)
 974       (x86-listing cgc
 975                    (cond ((fx= opcode #x05)
 976                           "syscall")
 977                          ((fx= opcode #x07)
 978                           "sysret")
 979                          ((fx= opcode #xa2)
 980                           "cpuid")
 981                          (else ;; (fx<= opcode #x33)
 982                           (vector-ref
 983                            '#("wrmsr" "rdtsc" "rdmsr" "rdpmc")
 984                            (fx- opcode #x30))))
 985                    0)))
 986
 987 ;;;----------------------------------------------------------------------------
 988
 989 ;;; X86 instructions: JMP, CALL, JO, JNO, JB, JAE, JE, JNE, JBE, JA,
 990 ;;; JS, JNS, JP, JNP, JL, JGE, JLE, and JG.
 991
 992 ;; Unconditional jump/call opcodes
 993
 994 (define x86-jmp-rel8-opcode   #xeb)
 995 (define x86-jmp-rel32-opcode  #xe9)
 996 (define x86-call-rel32-opcode #xe8)
 997
 998 ;; Conditional jump opcodes (for the rel32 kind, add #x10 with #x0f opcode)
 999
1000 (define x86-jo-rel8-opcode   #x70)
1001 (define x86-jno-rel8-opcode  #x71)
1002 (define x86-jb-rel8-opcode   #x72)
1003 ;;(define x86-jnae-rel8-opcode x86-jb-rel8-opcode)
1004 ;;(define x86-jc-rel8-opcode   x86-jb-rel8-opcode)
1005 (define x86-jae-rel8-opcode  #x73)
1006 ;;(define x86-jnb-rel8-opcode  x86-jae-rel8-opcode)
1007 ;;(define x86-jnc-rel8-opcode  x86-jae-rel8-opcode)
1008 (define x86-je-rel8-opcode   #x74)
1009 ;;(define x86-jz-rel8-opcode   x86-je-rel8-opcode)
1010 (define x86-jne-rel8-opcode  #x75)
1011 ;;(define x86-jnz-rel8-opcode  x86-jne-rel8-opcode)
1012 (define x86-jbe-rel8-opcode  #x76)
1013 ;;(define x86-jna-rel8-opcode  x86-jbe-rel8-opcode)
1014 (define x86-ja-rel8-opcode   #x77)
1015 ;;(define x86-jnbe-rel8-opcode x86-ja-rel8-opcode)
1016 (define x86-js-rel8-opcode   #x78)
1017 (define x86-jns-rel8-opcode  #x79)
1018 (define x86-jp-rel8-opcode   #x7a)
1019 ;;(define x86-jpe-rel8-opcode  x86-jp-rel8-opcode)
1020 (define x86-jnp-rel8-opcode  #x7b)
1021 ;;(define x86-jpo-rel8-opcode  x86-jnp-rel8-opcode)
1022 (define x86-jl-rel8-opcode   #x7c)
1023 ;;(define x86-jnge-rel8-opcode x86-jl-rel8-opcode)
1024 (define x86-jge-rel8-opcode  #x7d)
1025 ;;(define x86-jnl-rel8-opcode  x86-jge-rel8-opcode)
1026 (define x86-jle-rel8-opcode  #x7e)
1027 ;;(define x86-jng-rel8-opcode  x86-jle-rel8-opcode)
1028 (define x86-jg-rel8-opcode   #x7f)
1029 ;;(define x86-jnle-rel8-opcode x86-jg-rel8-opcode)
1030
1031 (define (x86-jmp cgc opnd)
1032   (if (asm-label? opnd)
1033       (x86-jump-label cgc opnd x86-jmp-rel8-opcode)
1034       (x86-jump-general cgc opnd 4)))
1035
1036 (define (x86-call cgc opnd)
1037   (if (asm-label? opnd)
1038       (x86-jump-label cgc opnd x86-call-rel32-opcode)
1039       (x86-jump-general cgc opnd 2)))
1040
1041 (define (x86-jo cgc label)  (x86-jump-label cgc label x86-jo-rel8-opcode))
1042 (define (x86-jno cgc label) (x86-jump-label cgc label x86-jno-rel8-opcode))
1043 (define (x86-jb cgc label)  (x86-jump-label cgc label x86-jb-rel8-opcode))
1044 (define (x86-jae cgc label) (x86-jump-label cgc label x86-jae-rel8-opcode))
1045 (define (x86-je cgc label)  (x86-jump-label cgc label x86-je-rel8-opcode))
1046 (define (x86-jne cgc label) (x86-jump-label cgc label x86-jne-rel8-opcode))
1047 (define (x86-jbe cgc label) (x86-jump-label cgc label x86-jbe-rel8-opcode))
1048 (define (x86-ja cgc label)  (x86-jump-label cgc label x86-ja-rel8-opcode))
1049 (define (x86-js cgc label)  (x86-jump-label cgc label x86-js-rel8-opcode))
1050 (define (x86-jns cgc label) (x86-jump-label cgc label x86-jns-rel8-opcode))
1051 (define (x86-jp cgc label)  (x86-jump-label cgc label x86-jp-rel8-opcode))
1052 (define (x86-jnp cgc label) (x86-jump-label cgc label x86-jnp-rel8-opcode))
1053 (define (x86-jl cgc label)  (x86-jump-label cgc label x86-jl-rel8-opcode))
1054 (define (x86-jge cgc label) (x86-jump-label cgc label x86-jge-rel8-opcode))
1055 (define (x86-jle cgc label) (x86-jump-label cgc label x86-jle-rel8-opcode))
1056 (define (x86-jg cgc label)  (x86-jump-label cgc label x86-jg-rel8-opcode))
1057
1058 (define (x86-jump-label cgc label opcode)
1059
1060   (define (listing width)
1061     (if (codegen-context-listing-format cgc)
1062         (x86-listing cgc
1063                      (cond ((fx= opcode x86-jmp-rel8-opcode)
1064                             "jmp")
1065                            ((fx= opcode x86-call-rel32-opcode)
1066                             "call")
1067                            (else
1068                             (vector-ref
1069                              '#("jo" "jno" "jb" "jae" "je" "jne" "jbe" "ja"
1070                                 "js" "jns" "jp" "jnp" "jl" "jge" "jle" "jg")
1071                              (fx- opcode x86-jo-rel8-opcode))))
1072                      width
1073                      (asm-label-name label))))
1074
1075   (define (label-dist label self offset)
1076     (fx- (asm-label-pos label)
1077          (fx+ self offset)))
1078
1079   (asm-at-assembly
1080
1081    cgc
1082
1083    ;; short displacement (-128..127 bytes)
1084
1085    (if (fx= opcode x86-call-rel32-opcode)
1086        (lambda (cb self)
1087          #f)
1088        (lambda (cb self)
1089          (let ((dist (label-dist label self 2)))
1090            (if (asm-signed8? dist)
1091                2
1092                #f))))
1093    (lambda (cb self)
1094      (let ((dist (label-dist label self 2)))
1095        (asm-8 cb opcode)              ;; opcode
1096        (asm-8 cb (fxand 255 dist)))   ;; 8 bit distance
1097      (listing 1))
1098
1099    ;; 32 bit relative address
1100
1101    (lambda (cb self)
1102      (cond ((or (fx= opcode x86-jmp-rel8-opcode)
1103                 (fx= opcode x86-call-rel32-opcode))
1104             5)
1105            (else
1106             6)))
1107    (lambda (cb self)
1108      (let ((dist (label-dist label self 5)))
1109        (cond ((fx= opcode x86-jmp-rel8-opcode)
1110               (asm-8 cb x86-jmp-rel32-opcode) ;; opcode
1111               (asm-32-le cb dist))            ;; 32 bit distance
1112              ((fx= opcode x86-call-rel32-opcode)
1113               (asm-8 cb opcode)      ;; opcode
1114               (asm-32-le cb dist))   ;; 32 bit distance
1115              (else
1116               ;; opcode is for a conditional jump
1117               (x86-esc-opcode cb)            ;; escape opcode
1118               (asm-8 cb (fx+ #x10 opcode))   ;; opcode = #x80, #x81, etc
1119               (asm-32-le cb (fx- dist 1))))) ;; 32 bit distance
1120      (listing 0))))
1121
1122 (define (x86-jump-general cgc opnd field)
1123
1124   (assert (or (not (x86-reg? opnd))
1125               (fx= (x86-reg-width opnd)
1126                    (x86-word-width cgc)))
1127           "invalid width register" opnd)
1128
1129   (x86-opnd-prefix cgc 0 0 opnd #f)   ;; prefix (width is implicit)
1130   (asm-8 cgc #xff)                    ;; opcode
1131   (x86-opnd-modrm/sib cgc field opnd) ;; ModR/M
1132
1133   (if (codegen-context-listing-format cgc)
1134       (x86-listing cgc
1135                    (if (fx= field 4) "jmp" "call")
1136                    -1
1137                    opnd)))
1138
1139 ;;;----------------------------------------------------------------------------
1140
1141 ;;; X86 instructions: PUSH and POP.
1142
1143 (define (x86-push cgc opnd)
1144   (x86-push-pop cgc opnd #x50))
1145
1146 (define (x86-pop cgc opnd)
1147   (x86-push-pop cgc opnd #x58))
1148
1149 (define (x86-push-pop cgc opnd op) ;; width is always width of stack pointer
1150
1151   (define (listing opnd)
1152     (if (codegen-context-listing-format cgc)
1153         (x86-listing cgc
1154                      (if (fx= op #x50) "push" "pop")
1155                      (x86-word-width cgc)
1156                      (if (and #f ;; comment-out to avoid duplicate width qualifier in nasm format
1157                               (x86-imm-int? opnd))
1158                          (x86-imm-int (x86-imm-int-value opnd) 0)
1159                          opnd))))
1160
1161   (define (immediate)
1162     (if (and (x86-imm-int? opnd)
1163              (asm-signed8? (x86-imm-int-value opnd)))
1164         (begin
1165           (asm-8 cgc #x6a) ;; opcode = #x6a
1166           (listing (x86-imm-encode cgc opnd 8)))
1167         (begin
1168           (asm-8 cgc #x68) ;; opcode = #x68
1169           (listing (x86-imm-encode cgc opnd 32)))))
1170
1171   (define (register)
1172     (let ((field (x86-reg-field opnd)))
1173
1174       (if (x86-reg32? opnd)
1175           (begin
1176             (x86-assert-32bit-mode cgc)
1177             (assert (fx< field 8)
1178                     "cannot push/pop extended registers in 32 bit mode"))
1179           (begin
1180             (x86-assert-64bit-mode cgc)
1181             (if (fx>= field 8)
1182                 (asm-8 cgc #x41)))) ;; REX
1183
1184       (asm-8 cgc (fx+ op ;; opcode = #x50-#x5f
1185                       (fxand 7 field))))
1186
1187     (listing opnd))
1188
1189   (define (general)
1190
1191     (x86-opnd-prefix cgc 0 0 opnd #f) ;; prefix (width is implicit)
1192
1193     (let ((field
1194            (if (fx= op #x50) ;; push?
1195                (begin
1196                  (asm-8 cgc #xff) ;; opcode = #xff
1197                  6)
1198                (begin
1199                  (asm-8 cgc #x8f) ;; opcode = #x8f
1200                  0))))
1201       (x86-opnd-modrm/sib cgc field opnd)) ;; ModR/M
1202
1203     (listing opnd))
1204
1205   (cond ((and (fx= op #x50) ;; push?
1206               (x86-imm-int? opnd))
1207          (immediate))
1208         ((x86-reg? opnd)
1209          (register))
1210         (else
1211          (general))))
1212
1213 ;;;----------------------------------------------------------------------------
1214
1215 ;;; X86 instructions: CWDE, CDQ, CBW, CWD, CDQE, and CQO.
1216
1217 (define (x86-cwde cgc) (x86-widen cgc 0))
1218 (define (x86-cdq  cgc) (x86-widen cgc 1))
1219 (define (x86-cbw  cgc) (x86-widen cgc 2))
1220 (define (x86-cwd  cgc) (x86-widen cgc 3))
1221 (define (x86-cdqe cgc) (x86-widen cgc 4))
1222 (define (x86-cqo  cgc) (x86-widen cgc 5))
1223
1224 (define (x86-widen cgc op)
1225
1226   (define (listing)
1227     (if (codegen-context-listing-format cgc)
1228         (x86-listing cgc
1229                      (vector-ref
1230                       '#("cwde" "cdq" "cbw" "cwd" "cdqe" "cqo")
1231                       op)
1232                      0))) ;; implicit width
1233
1234   (cond ((fx>= op 4)
1235          (x86-assert-64bit-mode cgc)
1236          (asm-8 cgc #x48)) ;; REX prefix
1237         ((fx>= op 2)
1238          (asm-8 cgc #x66))) ;; operand size override prefix
1239
1240   (asm-8 cgc (fx+ #x98 (fxand op 1)))
1241
1242   (listing))
1243
1244 ;;;----------------------------------------------------------------------------
1245
1246 ;;; X86 instructions: ROL, ROR, RCL, RCR, SHL, SHR, and SAR.
1247
1248 (define (x86-rol cgc opnd1 opnd2 #!optional (width #f))
1249   (x86-shift cgc opnd1 opnd2 width 0))
1250
1251 (define (x86-ror cgc opnd1 opnd2 #!optional (width #f))
1252   (x86-shift cgc opnd1 opnd2 width 1))
1253
1254 (define (x86-rcl cgc opnd1 opnd2 #!optional (width #f))
1255   (x86-shift cgc opnd1 opnd2 width 2))
1256
1257 (define (x86-rcr cgc opnd1 opnd2 #!optional (width #f))
1258   (x86-shift cgc opnd1 opnd2 width 3))
1259
1260 (define (x86-shl cgc opnd1 opnd2 #!optional (width #f))
1261   (x86-shift cgc opnd1 opnd2 width 4))
1262
1263 (define (x86-shr cgc opnd1 opnd2 #!optional (width #f))
1264   (x86-shift cgc opnd1 opnd2 width 5))
1265
1266 (define (x86-sar cgc opnd1 opnd2 #!optional (width #f))
1267   (x86-shift cgc opnd1 opnd2 width 7))
1268
1269 (define (x86-shift cgc opnd1 opnd2 width op)
1270
1271   (define (listing width)
1272     (if (codegen-context-listing-format cgc)
1273         (x86-listing cgc
1274                      (vector-ref
1275                       '#("rol" "ror" "rcl" "rcr" "shl" "shr" "???" "sar")
1276                       op)
1277                      width
1278                      opnd1
1279                      (x86-force-width
1280                       (if (x86-imm-int? opnd2)
1281                           (x86-imm-int (x86-imm-int-value opnd2) width)
1282                           opnd2)
1283                       0))))
1284
1285   (define (general width)
1286     (x86-opnd-prefix-opnd cgc width opnd1) ;; prefix
1287     (cond ((x86-imm-int? opnd2)
1288            (let ((n (x86-imm-int-value opnd2)))
1289              (assert (and (>= n 0)
1290                           (<= n 255))
1291                      "immediate shift count out of range" n)
1292              (asm-8 cgc (fx+ (if (fx= n 1) #xd0 #xc0) ;; opcode
1293                              (if (fx= width 8) 0 1)))
1294              (x86-opnd-modrm/sib cgc op opnd1) ;; ModR/M
1295              (if (not (fx= n 1))
1296                  (asm-8 cgc n))))
1297           ((eqv? opnd2 (x86-cl))
1298            (asm-8 cgc (fx+ #xd2 ;; opcode
1299                            (if (fx= width 8) 0 1)))
1300            (x86-opnd-modrm/sib cgc op opnd1)) ;; ModR/M
1301           (else
1302            (error "invalid shift count operand" opnd2)))
1303     (listing width))
1304
1305   (assert (if (x86-reg? opnd1)
1306               (or (not width)
1307                   (fx= (x86-reg-width opnd1) width))
1308               width)
1309           "missing or inconsistent operand width" width)
1310
1311   (general (or width (x86-reg-width opnd1))))
1312
1313 ;;;----------------------------------------------------------------------------
1314
1315 ;;; X86 instructions: NOT and NEG.
1316
1317 (define (x86-not cgc opnd #!optional (width #f))
1318   (x86-negate cgc opnd width 2))
1319
1320 (define (x86-neg cgc opnd #!optional (width #f))
1321   (x86-negate cgc opnd width 3))
1322
1323 (define (x86-negate cgc opnd width op)
1324
1325   (define (listing width)
1326     (if (codegen-context-listing-format cgc)
1327         (x86-listing cgc
1328                      (if (fx= op 2) "not" "neg")
1329                      width
1330                      opnd)))
1331
1332   (define (general width)
1333     (x86-opnd-prefix-opnd cgc width opnd)    ;; prefix
1334     (asm-8 cgc (if (fx= width 8) #xf6 #xf7)) ;; opcode
1335     (x86-opnd-modrm/sib cgc op opnd)         ;; ModR/M
1336     (listing width))
1337
1338   (assert (if (x86-reg? opnd)
1339               (or (not width)
1340                   (fx= (x86-reg-width opnd) width))
1341               width)
1342           "missing or inconsistent operand width" width)
1343
1344   (general (or width (x86-reg-width opnd))))
1345
1346 ;;;----------------------------------------------------------------------------
1347
1348 ;;; X86 instruction: TEST.
1349
1350 (define (x86-test cgc opnd1 opnd2 #!optional (width #f))
1351
1352   (define (listing width opnd1 opnd2)
1353     (if (codegen-context-listing-format cgc)
1354         (x86-listing cgc
1355                      "test"
1356                      width
1357                      opnd1
1358                      opnd2)))
1359
1360   (define (accumulator-imm width)
1361     (x86-opnd-prefix-opnd cgc width opnd1)   ;; prefix
1362     (asm-8 cgc (if (fx= width 8) #xa8 #xa9)) ;; opcode
1363     (listing width
1364              opnd1
1365              (x86-imm-encode cgc opnd2 (fxmin 32 width))))
1366
1367   (define (general-imm width)
1368     (x86-opnd-prefix-opnd cgc width opnd1)   ;; prefix
1369     (asm-8 cgc (if (fx= width 8) #xf6 #xf7)) ;; opcode
1370     (x86-opnd-modrm/sib cgc 0 opnd1)         ;; ModR/M
1371     (listing width
1372              opnd1
1373              (x86-imm-encode cgc opnd2 (fxmin 32 width))))
1374
1375   (define (general-reg width)
1376     (x86-opnd-prefix-reg-opnd cgc opnd2 opnd1)    ;; prefix
1377     (asm-8 cgc (if (fx= width 8) #x84 #x85))      ;; opcode
1378     (x86-opnd-modrm/sib-reg-opnd cgc opnd2 opnd1) ;; ModR/M
1379     (listing width
1380              opnd1
1381              opnd2))
1382
1383   (assert (cond ((x86-reg? opnd2)
1384                  (and (or (not width)
1385                           (fx= (x86-reg-width opnd2) width))
1386                       (or (not (x86-reg? opnd1))
1387                           (fx= (x86-reg-width opnd2) (x86-reg-width opnd1)))))
1388                 ((x86-reg? opnd1)
1389                  (or (not width)
1390                      (fx= (x86-reg-width opnd1) width)))
1391                 (else
1392                  width))
1393           "missing or inconsistent operand width" width)
1394
1395   (if (x86-reg? opnd2)
1396       (general-reg (x86-reg-width opnd2))
1397       (begin
1398         (assert (x86-imm-int? opnd2)
1399                 "second operand must be a register or an immediate" opnd2)
1400         (if (x86-reg? opnd1)
1401             (let ((width (x86-reg-width opnd1))
1402                   (field (x86-reg-field opnd1)))
1403               (if (fx= field 0)
1404                   (accumulator-imm width)
1405                   (general-imm width)))
1406             (general-imm width)))))
1407
1408 ;;;----------------------------------------------------------------------------
1409
1410 ;;; X86 instruction: XCHG.
1411
1412 (define (x86-xchg cgc opnd1 opnd2)
1413
1414   ;; opnd1 = source/destination1, opnd2 = source/destination2
1415
1416   (define (listing width reg opnd swapped?)
1417     (if (codegen-context-listing-format cgc)
1418         (x86-listing cgc
1419                      "xchg"
1420                      width
1421                      (if swapped? opnd reg)
1422                      (if swapped? reg opnd))))
1423
1424   (define (accumulator-reg width acc reg swapped?)
1425     (let ((field (x86-reg-field reg)))
1426       (if (or #t ;; comment-out to avoid encoding "xchg eax,eax" as "nop" on x86-64
1427               (not (and (fx= width 32)
1428                         (fx= field 0)
1429                         (x86-64bit-mode? cgc))))
1430           (begin
1431             (x86-opnd-prefix-reg-opnd cgc acc reg) ;; prefix
1432             (asm-8 cgc (fx+ #x90 (fxand 7 field))) ;; opcode
1433             (listing width acc reg swapped?))
1434           (general-reg width acc reg swapped?)))) ;; don't generate nop
1435
1436   (define (general-reg width reg opnd swapped?)
1437     (x86-opnd-prefix-reg-opnd cgc reg opnd)    ;; prefix
1438     (asm-8 cgc (if (fx= width 8) #x86 #x87))   ;; opcode
1439     (x86-opnd-modrm/sib-reg-opnd cgc reg opnd) ;; ModR/M
1440     (listing width reg opnd swapped?))
1441
1442   (define (reg-op reg opnd swapped?)
1443     (let ((field (x86-reg-field reg))
1444           (width (x86-reg-width reg)))
1445       (if (x86-reg? opnd)
1446           (let ((field2 (x86-reg-field opnd)))
1447             (assert (fx= width (x86-reg-width opnd)))
1448             (cond ((and (not (fx= width 8)) (fx= field 0)) ;; AX/EAX/RAX
1449                    (accumulator-reg width reg opnd swapped?))
1450                   ((and (not (fx= width 8)) (fx= field2 0)) ;; AX/EAX/RAX
1451                    (accumulator-reg width opnd reg (not swapped?)))
1452                   (else
1453                    (if (or #t ;; comment-out for consistency with gnu assembler
1454                            (not (eq? (codegen-context-listing-format cgc) 'gnu)))
1455                        (general-reg width reg opnd swapped?)
1456                        (general-reg width opnd reg (not swapped?))))))
1457           (general-reg width reg opnd swapped?))))
1458
1459   (cond ((x86-reg? opnd1)
1460          (reg-op opnd1 opnd2 #f))
1461         ((x86-reg? opnd2)
1462          (reg-op opnd2 opnd1 #t))
1463         (else
1464          (error "one of the two operands must be a register" opnd1 opnd2))))
1465
1466 ;;;----------------------------------------------------------------------------
1467
1468 ;;; X86 instructions: MUL, IMUL, DIV, and IDIV.
1469
1470 (define (x86-mul cgc opnd #!optional (width #f))
1471   (x86-multiply-divide cgc opnd #f #f width 4))
1472
1473 (define (x86-imul cgc opnd1 #!optional (opnd2 #f) (opnd3 #f) (width #f))
1474   (x86-multiply-divide cgc opnd1 opnd2 opnd3 width 5))
1475
1476 (define (x86-div cgc opnd #!optional (width #f))
1477   (x86-multiply-divide cgc opnd #f #f width 6))
1478
1479 (define (x86-idiv cgc opnd #!optional (width #f))
1480   (x86-multiply-divide cgc opnd #f #f width 7))
1481
1482 (define (x86-multiply-divide cgc opnd1 opnd2 opnd3 width op)
1483
1484   (define (listing width opnd1 opnd2 opnd3)
1485     (if (codegen-context-listing-format cgc)
1486         (let ((mnemonic
1487                (vector-ref '#("mul" "imul" "div" "idiv") (fx- op 4))))
1488           (cond (opnd3
1489                  (x86-listing cgc
1490                               mnemonic
1491                               width
1492                               opnd1
1493                               opnd2
1494                               opnd3))
1495                 (opnd2
1496                  (x86-listing cgc
1497                               mnemonic
1498                               width
1499                               opnd1
1500                               opnd2))
1501                 (else
1502                  (x86-listing cgc
1503                               mnemonic
1504                               width
1505                               opnd1))))))
1506
1507   (define (general-1-opnd width)
1508     (x86-opnd-prefix-opnd cgc width opnd1)    ;; prefix
1509     (asm-8 cgc (if (fx= width 8) #xf6 #xf7))  ;; opcode
1510     (x86-opnd-modrm/sib cgc op opnd1)         ;; ModR/M
1511     (listing width opnd1 #f #f))
1512
1513   (define (register-2-opnds width)
1514     (assert (not (fx= width 8))
1515             "8 bit wide multiply not possible")
1516     (assert (or (not (x86-reg? opnd2))
1517                 (fx= width (x86-reg-width opnd2)))
1518             "inconsistent width operands")
1519     (x86-opnd-prefix-reg-opnd cgc opnd1 opnd2)    ;; prefix
1520     (x86-esc-opcode cgc)                          ;; escape opcode
1521     (asm-8 cgc #xaf)                              ;; opcode
1522     (x86-opnd-modrm/sib-reg-opnd cgc opnd1 opnd2) ;; ModR/M
1523     (listing width opnd1 opnd2 #f))
1524
1525   (define (register-3-opnds width)
1526     (let ((imm-width
1527            (if (and (x86-imm-int? opnd3)
1528                     (asm-signed8? (x86-imm-int-value opnd3)))
1529                8
1530                (fxmin 32 width))))
1531       (x86-opnd-prefix-reg-opnd cgc opnd1 opnd2)    ;; prefix
1532       (asm-8 cgc (if (fx= imm-width 8) #x6b #x69))  ;; opcode
1533       (x86-opnd-modrm/sib-reg-opnd cgc opnd1 opnd2) ;; ModR/M
1534       (listing width
1535                opnd1
1536                opnd2
1537                (x86-imm-encode cgc opnd3 imm-width))))
1538
1539   (assert (if (x86-reg? opnd1)
1540               (or (not width)
1541                   (fx= (x86-reg-width opnd1) width))
1542               width)
1543           "missing or inconsistent operand width" width)
1544
1545   (if (x86-reg? opnd1)
1546       (let ((width (x86-reg-width opnd1)))
1547         (cond (opnd3
1548                (register-3-opnds width))
1549               (opnd2
1550                (register-2-opnds width))
1551               (else
1552                (general-1-opnd width))))
1553       (general-1-opnd width)))
1554
1555 ;;;----------------------------------------------------------------------------
1556
1557 ;;; X86 instructions: MOVZX, MOVSX, and MOVSXD.
1558
1559 (define (x86-movzx cgc reg opnd #!optional (width #f))
1560   (x86-move-extended cgc reg opnd width #xb6))
1561
1562 (define (x86-movsx cgc reg opnd #!optional (width #f))
1563   (x86-move-extended cgc reg opnd width #xbe))
1564
1565 ;; Note: use x86-movsx instead of x86-movsxd
1566 ;;(define (x86-movsxd cgc reg opnd #!optional (width #f))
1567 ;;  (x86-move-extended cgc reg opnd width #xbe))
1568
1569 (define (x86-move-extended cgc reg opnd width op)
1570
1571   ;; reg = destination, opnd = source
1572
1573   (define (listing width-opnd)
1574     (if (codegen-context-listing-format cgc)
1575         (x86-listing cgc
1576                      (case (codegen-context-listing-format cgc)
1577                        ((gnu)
1578                         (if (fx= width-opnd 32)
1579                             "movsl"
1580                             (list (if (fx= op #xb6)
1581                                       "movz"
1582                                       "movs")
1583                                   (x86-width-suffix cgc width-opnd))))
1584                        (else ;;(nasm)
1585                         (if (fx= width-opnd 32)
1586                             "movsxd"
1587                             (if (fx= op #xb6)
1588                                 "movzx"
1589                                 "movsx"))))
1590                      (x86-reg-width reg)
1591                      reg
1592                      (if (x86-reg? opnd)
1593                          opnd
1594                          (x86-force-width opnd width-opnd)))))
1595
1596   (assert (x86-reg? reg)
1597           "destination of movzx/movsx/movsxd must be a register" reg)
1598
1599   (assert (not (x86-reg8? reg))
1600           "destination of movzx/movsx/movsxd must not be an 8 bit register" reg)
1601
1602   (assert (if (x86-reg? opnd)
1603               (or (not width)
1604                   (fx= (x86-reg-width opnd) width))
1605               width)
1606           "missing or inconsistent operand width" width)
1607
1608   (let ((width-reg (x86-reg-width reg))
1609         (width-opnd (or width (x86-reg-width opnd))))
1610
1611     (assert (or (fx= width-opnd 8)
1612                 (fx= width-opnd 16)
1613                 (and (fx= op #xbe) ;; movsxd?
1614                      (fx= width-opnd 32)))
1615             "invalid combination of operands" reg opnd)
1616
1617     (x86-opnd-prefix-reg-opnd cgc reg opnd)    ;; prefix
1618     (if (fx= width-opnd 32)
1619         (asm-8 cgc #x63)                       ;; opcode for movsxd
1620         (begin
1621           (x86-esc-opcode cgc)                 ;; escape opcode
1622           (asm-8 cgc (fx+ op (if (fx= width-opnd 8) 0 1))))) ;; opcode
1623     (x86-opnd-modrm/sib-reg-opnd cgc reg opnd) ;; ModR/M
1624
1625     (listing width-opnd)))
1626
1627 ;;;----------------------------------------------------------------------------
1628
1629 ;;; X86 instructions: BT, BTS, BTR, BTC, BSF, and BSR.
1630
1631 (define (x86-bt cgc opnd1 opnd2 #!optional (width #f))
1632   (x86-bit-op cgc opnd1 opnd2 width 0)) ;; 0f a3    0f ba /4
1633
1634 (define (x86-bts cgc opnd1 opnd2 #!optional (width #f))
1635   (x86-bit-op cgc opnd1 opnd2 width 1)) ;; 0f ab    0f ba /5
1636
1637 (define (x86-btr cgc opnd1 opnd2 #!optional (width #f))
1638   (x86-bit-op cgc opnd1 opnd2 width 2)) ;; 0f b3    0f ba /6
1639
1640 (define (x86-btc cgc opnd1 opnd2 #!optional (width #f))
1641   (x86-bit-op cgc opnd1 opnd2 width 3)) ;; 0f bb    0f ba /7
1642
1643 (define (x86-bit-op cgc opnd1 opnd2 width op)
1644
1645   (define (listing width)
1646     (if (codegen-context-listing-format cgc)
1647         (x86-listing cgc
1648                      (vector-ref
1649                       '#("bt" "bts" "btr" "btc")
1650                       op)
1651                      width
1652                      opnd1
1653                      (if (x86-imm-int? opnd2)
1654                          (x86-imm-int (x86-imm-int-value opnd2) width)
1655                          opnd2))))
1656
1657   (define (general width)
1658     (cond ((x86-imm-int? opnd2)
1659            (let ((n (x86-imm-int-value opnd2)))
1660              (assert (and (>= n 0)
1661                           (< n width))
1662                      "immediate bit position out of range" n)
1663              (x86-opnd-prefix-opnd cgc width opnd1) ;; prefix
1664              (x86-esc-opcode cgc)                   ;; escape opcode
1665              (asm-8 cgc #xba)                       ;; opcode
1666              (x86-opnd-modrm/sib cgc (fx+ op 4) opnd1) ;; ModR/M
1667              (asm-8 cgc n)))                        ;; immediate bit position
1668           ((x86-reg? opnd2)
1669            (x86-opnd-prefix-reg-opnd cgc opnd2 opnd1)     ;; prefix
1670            (x86-esc-opcode cgc)                           ;; escape opcode
1671            (asm-8 cgc (fx+ #xa3 (fxarithmetic-shift-left op 3))) ;; opcode
1672            (x86-opnd-modrm/sib-reg-opnd cgc opnd2 opnd1)) ;; ModR/M
1673           (else
1674            (error "invalid bit position operand" opnd2)))
1675     (listing width))
1676
1677   (assert (and (or (not (x86-reg? opnd1))
1678                    (not width)
1679                    (fx= (x86-reg-width opnd1) width))
1680                (or (not (x86-reg? opnd2))
1681                    (not width)
1682                    (fx= (x86-reg-width opnd2) width))
1683                (or (not (x86-reg? opnd1))
1684                    (not (x86-reg? opnd2))
1685                    (fx= (x86-reg-width opnd1) (x86-reg-width opnd2))))
1686           "missing or inconsistent operand width" width)
1687
1688   (cond ((x86-reg? opnd1)
1689          (general (x86-reg-width opnd1)))
1690         ((x86-reg? opnd2)
1691          (general (x86-reg-width opnd2)))
1692         (else
1693          (general width))))
1694
1695 ;;;============================================================================