From df219d434a3effd6fee8da1748f1aa33a6266bd7 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Tue, 11 Aug 1992 02:20:16 +0000 Subject: [PATCH] Replace by the real thing. --- v7/src/compiler/machines/i386/dassm3.scm | 965 ++++++++++++++++++++++- 1 file changed, 963 insertions(+), 2 deletions(-) diff --git a/v7/src/compiler/machines/i386/dassm3.scm b/v7/src/compiler/machines/i386/dassm3.scm index 0034adf50..2361f6d03 100644 --- a/v7/src/compiler/machines/i386/dassm3.scm +++ b/v7/src/compiler/machines/i386/dassm3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/dassm3.scm,v 1.2 1992/02/28 20:22:42 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/dassm3.scm,v 1.3 1992/08/11 02:20:16 jinx Exp $ Copyright (c) 1992 Massachusetts Institute of Technology @@ -37,4 +37,965 @@ MIT in each case. |# (declare (usual-integrations)) -'NOT-YET-WRITTEN \ No newline at end of file +;; IMPORTANT: This disassembler currently does not handle +;; operand size and address size modifiers. +;; Thus it is "stuck" in 32-bit mode, just like the assembler. + +;; These really depend on the current operand size + +(define next-word next-32-bit-word) +(define next-unsigned-word next-unsigned-32-bit-word) + +;; This really depends on the current address size + +(define next-offset next-word) + + +(define-integrable (high-nibble byte) + (fix:lsh byte -4)) + +(define-integrable (low-nibble byte) + (fix:and byte #xf)) + +(define-integrable (low-three-bits byte) + (fix:and byte #x7)) + +(define-integrable (modr/m-mod modr/m-byte) + (fix:and (fix:lsh modr/m-byte -6) #x3)) + +(define-integrable (modr/m-reg modr/m-byte) + (fix:and (fix:lsh modr/m-byte -3) #x7)) + +(define-integrable (modr/m-base modr/m-byte) + (fix:and modr/m-byte #x7)) + +(define-integrable (sib-base sib-byte) + (fix:and sib-byte #x7)) + +(define-integrable (sib-index sib-byte) + (fix:and (fix:lsh sib-byte -3) #x7)) + +(define (sib-scale sib-byte) + (vector-ref '#(1 2 4 8) (fix:and (fix:lsh sib-byte -6) #x3))) + +(define (pc-relative prefix offset) + (cond ((find-label (+ *current-offset offset)) + => + (lambda (label) + `(,@prefix (@PCR ,label)))) + (else + `(,@prefix (@PCO ,offset))))) + +(define (@R reg) + (let ((operand `(@R ,reg))) + (or (and disassembler/symbolize-output? + (interpreter-register? operand)) + operand))) + +(define (@RO size reg offset) + (let ((operand `(@RO ,size ,reg ,offset))) + (or (and disassembler/symbolize-output? + (interpreter-register? operand)) + operand))) + +(define (immediate-byte) + `(& ,(next-byte))) + +(define (immediate-word) + `(& ,(next-word))) + +(define (decode-r/m-32 byte) + (let ((base (modr/m-base byte))) + (define (ea size next-offset) + (cond ((fix:= base 4) ; esp + (let ((sib (next-unsigned-byte))) + (let ((base (sib-base sib)) + (index (sib-index sib)) + (scale (sib-scale sib))) + (if (fix:= index 4) ; esp + (cond ((and (fix:= base 5) + (fix:= scale 1)) + (if (not size) + `(@ 0) ; ??? + `(@ ,(next-offset)))) + ((not size) + (@R base)) + (else + (@RO size base (next-offset)))) + (cond ((and (fix:= base 5) + (fix:= scale 1)) + (if (not size) + (@R index) + (@RO size index offset))) + ((not size) + `(@RI ,base ,index ,scale)) + (else + `(@ROI ,size ,base ,(next-offset) + ,index ,scale))))))) + ((not size) + (@R base)) + (else + (@RO size base (next-offset))))) + + (case (modr/m-mod byte) + ((0) + (if (fix:= base 5) ; ebp + `(@ ,(next-32-bit-word)) + (ea #f (lambda () 0)))) + ((1) + (ea 'B next-byte)) + ((2) + (ea 'W next-32-bit-word)) + ((3) + `(R ,base)) + (else + (error "decode-r/m: bad mode" byte))))) + +(define (decode-r/m-16 byte) + (let ((base (modr/m-base byte))) + (define (ea size offset) + (if (fix:< base 4) + (let ((base (if (fix:> base 1) 5 3)) + (index (fix:+ 6 (fix:and base 1)))) + (if size + `(@RI ,base ,index 1) + `(@ROI ,size ,base ,offset ,index 1))) + (let ((reg (vector-ref '#(6 7 5 3) (fix:- base 4)))) + (if size + (@RO size reg offset) + (@R reg))))) + + (case (modr/m-mod byte) + ((0) + (if (fix:= base 6) + `(@ ,(next-16-bit-word)) + (ea #f 0))) + + ((1) + (ea 'B (next-byte))) + ((2) + (ea 'W (next-16-bit-word))) + ((3) + `(R ,base)) + (else + (error "decode-r/m: bad mode" byte))))) + +(define decode-r/m decode-r/m-32) + +(define (make-modr/m-decoder receiver) + (lambda (opcode-byte) + opcode-byte ; ignored + (let* ((modr/m-byte (next-unsigned-byte)) + (ea (decode-r/m modr/m-byte))) + (receiver (modr/m-reg modr/m-byte) ea)))) + +(define (decode-E prefix reg-value) + (lambda (opcode-byte) + (let ((modr/m-byte (next-unsigned-byte))) + (if (not (= (modr/m-reg modr/m-byte) reg-value)) + (unknown-inst opcode-byte modr/m-byte) + `(,@prefix ,(decode-r/m modr/m-byte)))))) + +(define (decode-E/G prefix) + (make-modr/m-decoder + (lambda (reg ea) + `(,@prefix ,ea (R ,reg))))) + +(define (decode-G/E prefix) + (make-modr/m-decoder + (lambda (reg ea) + `(,@prefix (R ,reg) ,ea)))) + +(define (decode-E/I prefix next) + (make-modr/m-decoder + (lambda (reg ea) + reg ; ignored, should be checked + `(,@prefix ,ea (& ,(next)))))) + +(define (decode-G/E/I prefix next) + (make-modr/m-decoder + (lambda (reg ea) + `(,@prefix (R ,reg) ,ea ,(next))))) + +(define (decode-E/G/I prefix next) + (make-modr/m-decoder + (lambda (reg ea) + `(,@prefix ,ea (R ,reg) ,(next))))) + +(define (decode-G/M prefix) + ;; This should check that we are dealing with a memory EA! + (make-modr/m-decoder + (lambda (reg ea) + `(,@prefix (R ,reg) ,ea)))) + +(define (decode-E/X prefix reg-kind) + (make-modr/m-decoder + (lambda (reg ea) + `(,@prefix ,ea (,reg-kind ,reg))))) + +(define (decode-X/E prefix reg-kind) + (make-modr/m-decoder + (lambda (reg ea) + `(,@prefix (,reg-kind ,reg) ,ea)))) + +(define (decode-@ prefix) + (lambda (opcode-byte) + opcode-byte ; ignored + (let ((offset (next-offset))) + `(,@prefix (@ ,offset))))) + +(define (decode-Ap prefix) + (lambda (opcode-byte) + opcode-byte ; ignored + (let ((offset (next-offset))) + `(,@prefix (SEGMENT ,(next-unsigned-16-bit-word)) + (OFFSET ,offset))))) + +(define (decode-Ib prefix) + (lambda (opcode-byte) + opcode-byte ; ignored + `(,@prefix (& ,(next-byte))))) + +(define (decode-I16 prefix) + (lambda (opcode-byte) + opcode-byte ; ignored + `(,@prefix (& ,(next-16-bit-word))))) + +(define (decode-Iw prefix) + (lambda (opcode-byte) + opcode-byte ; ignored + `(,@prefix (& ,(next-word))))) + +(define (decode-ENTER opcode-byte) + opcode-byte ; ignored + (let ((first (next-unsigned-16-bit-word))) + `(ENTER (& ,first) (& ,(next-unsigned-byte))))) + +(define (decode-pcrb prefix) + (lambda (opcode-byte) + opcode-byte ; ignored + (pc-relative prefix (next-byte)))) + +(define (decode-pcrw prefix) + (lambda (opcode-byte) + opcode-byte ; ignored + (pc-relative prefix (next-offset)))) + +(define (unknown-inst opcode-byte . more-bytes) + (set! *valid? false) ; re-synch. + `(BYTE U ,opcode-byte ,@more-bytes)) + +(define-integrable (simple-inst inst) + (lambda (opcode-byte) + opcode-byte ; ignored + inst)) + +(define (backwards handler) + (lambda (opcode-byte) + (let ((result (handler opcode-byte))) + (let ((back (reverse result))) + (reverse (cons* (cadr back) + (cons (car back) + (cddr back)))))))) + +(define-integrable (register-op prefix) + (lambda (opcode-byte) + `(,@prefix (R ,(fix:and opcode-byte #x7))))) + +(define jcc-opcodes + '#( + JO JNO JB JNB + JZ JNZ JBE JNBE + JS JNS JP JNP + JL JNL JLE JNLE)) + +(define setcc-opcodes + '#( + SETO SETNO SETB SETNB + SETZ SETNZ SETBE SETNBE + SETS SETNS SETP SETNP + SETL SETNL SETLE SETNLE)) + +(define (group-1&2 opcodes size get-operand) + (lambda (opcode-byte) + opcode-byte ; ignored + (let ((modr/m-byte (next-unsigned-byte))) + (let ((operand (decode-r/m modr/m-byte)) + (opcode (vector-ref opcodes (modr/m-reg modr/m-byte)))) + `(,opcode ,size ,operand ,(get-operand)))))) + +(define (group-3 size read-operand) + (lambda (opcode-byte) + opcode-byte ; ignored + (let* ((modr/m-byte (next-unsigned-byte)) + (operand (decode-r/m modr/m-byte))) + (let ((dispatch (modr/m-reg modr/m-byte))) + (cond ((< dispatch 2) + `(TEST ,size ,operand (& ,(read-operand)))) + ((< dispatch 4) + `(,(if (= dispatch 2) 'NOT 'NEG) ,size ,operand)) + (else + `(,(vector-ref '#(MUL IMUL DIV IDIV) (- dispatch 4)) + ,size + (R 0) + ,operand))))))) + +(define (group-4 size) + (lambda (opcode-byte) + (let* ((modr/m-byte (next-unsigned-byte)) + (operand (lambda () (decode-r/m modr/m-byte)))) + (case (modr/m-reg modr/m-byte) + ((0) + `(INC ,size ,(operand))) + ((1) + `(DEC ,size ,(operand))) + (else + (unknown-inst opcode-byte modr/m-byte)))))) + +(define (group-5 size) + (lambda (opcode-byte) + (let* ((modr/m-byte (next-unsigned-byte)) + (operand (lambda () (decode-r/m modr/m-byte)))) + (case (modr/m-reg modr/m-byte) + ((0) + `(INC ,size ,(operand))) + ((1) + `(DEC ,size ,(operand))) + ((2) + `(CALL ,(operand))) + ((3) + `(CALL F ,(operand))) + ((4) + `(JMP ,(operand))) + ((5) + `(JMP F ,(operand))) + ((6) + `(PUSH ,(operand))) + (else + (unknown-inst opcode-byte modr/m-byte)))))) + +(define (group-6&7 opcodes) + (lambda (second-byte) + (let* ((modr/m-byte (next-unsigned-byte)) + (op (vector-ref opcodes (modr/m-reg modr/m-byte)))) + (if (not op) + (unknown-inst #x0f second-byte modr/m-byte) + `(,op ,(decode-r/m modr/m-byte)))))) + +(define group-8 + (let ((opcodes '#(#f #f #f #f BT BTS BTR BTC))) + (lambda (second-byte) + (let* ((modr/m-byte (next-unsigned-byte)) + (op (vector-ref opcodes (modr/m-reg modr/m-byte)))) + (if (not op) + (unknown-inst #x0f second-byte modr/m-byte) + `(,op ,(decode-r/m modr/m-byte) (& ,(next-byte)))))))) + +;;; Utilities for the main dispatchers + +(define (dispatch-on-bit low high) + (lambda (opcode-byte) + ((if (fix:= (fix:and opcode-byte #x8) 0) low high) + opcode-byte))) + +(define (dispatch-on-low-bits mask opcodes) + (lambda (opcode-byte) + ((vector-ref opcodes (fix:and opcode-byte mask)) + opcode-byte))) + +(define (dispatch-on-low-nibble . cases) + (if (not (= (length cases) 16)) + (error "dispatch-on-low-nibble: Wrong number of cases" + cases)) + (dispatch-on-low-bits #xf (list->vector cases))) + +(define (dispatch-on-low-three-bits . cases) + (if (not (= (length cases) 8)) + (error "dispatch-on-low-three-bits: Wrong number of cases" + cases)) + (dispatch-on-low-bits #x7 (list->vector cases))) + +;;; Floating-point instructions + +(define (fp-table-maker fields->index) + (lambda (cases) + (let ((table (make-vector 64 #f))) + (for-each + (lambda (a-case) + (let ((opcode (car a-case)) + (next (cadr a-case))) + (let ((index (fields->index opcode next))) + (cond ((not index) + (error "make-table-1-3: Bad fields" a-case)) + ((vector-ref table index) + (error "make-table-1-3: Duplicate case" + (vector-ref table index) a-case))) + (vector-set! table index (cddr a-case))))) + cases) + table))) + +(define make-table-1-3 + (fp-table-maker + (lambda (opcode next) + (and (fix:< opcode 8) + (fix:< next 8) + (fix:or (fix:lsh next 3) opcode))))) + +(define make-table-4&5 + (fp-table-maker + (lambda (opcode next) + (and (or (fix:= opcode 1) (fix:= opcode 3)) + (fix:< next #x20) + (fix:or (fix:lsh (fix:- opcode 1) 4) + next))))) + +(define decode-fp + (let-syntax ((IN (macro (body . bindings) + `(LET ,bindings + ,body)))) + (IN + (lambda (opcode-byte) + (let* ((next (next-unsigned-byte)) + (disc (fix:and opcode-byte #x7)) + (index (fix:or (fix:and next #x38) disc))) + + (cond ((not (fix:= (modr/m-mod next) 3)) ; register op + (let ((prefix (vector-ref table-1&2 index))) + (if (not prefix) + (maybe-special opcode-byte next) + `(,@prefix ,(decode-r/m next))))) + ((or (fix:= disc 3) + (and (fix:= disc 1) + (fix:= (fix:and next #x20) #x20))) + (let ((inst (vector-ref + table-4&5 + (fix:or (fix:lsh (fix:- disc 1) 4) + (fix:and next #x1f))))) + (if (not inst) + (maybe-special opcode-byte next) + inst))) + (else + (let ((spec (vector-ref table-3 index)) + (loc (fix:and next #x7))) + (cond ((not spec) + (maybe-special opcode-byte next)) + ((null? (cdr spec)) + `(,(car spec) (ST ,loc))) + ((cadr spec) ; reverse ops + `(,(car spec) (ST ,loc) (ST 0))) + (else + `(,(car spec) (ST 0) (ST ,loc))))))))) + + (maybe-special + (let ((special '( + (#xe0df FNSTSW (R 0)) + (#xd0d9 FNOP) + ))) + (lambda (opcode-byte next) + (let* ((word (fix:or (fix:lsh next 8) opcode-byte)) + (place (assq word special))) + (if place + (cdr place) + (unknown-inst opcode-byte next)))))) + + + (table-4&5 + (make-table-4&5 + '( + (1 4 FTST) + (1 5 FXAM) + (1 #xe FLDZ) + (1 8 FLD1) + (1 #xb FLDPI) + (1 9 FLD2T) + (1 #xa FLD2E) + (1 #xc FLDG2) + (1 #xd FLDLN2) + (1 #x1a FSQRT) + (1 #x1d FSCALE) + (1 #x14 FXTRACT) + (1 #x18 FPREM) + (1 #x15 FPREM1) + (1 #x1c FRNDINT) + (1 1 FABS) + (1 0 FCHS) + (1 #x1f FCOS) + (1 #x12 FPTAN) + (1 #x13 FPATAN) + (1 #x1e FSIN) + (1 #x1b FSINCOS) + (1 #x10 F2XM1) + (1 #x11 FYL2X) + (1 #x19 FYL2XP1) + (3 3 FNINIT) + (3 2 FCLEX) + (1 #x17 FINCSTP) + (1 #x16 FDECSTP)))) + + + (table-3 + (make-table-1-3 + '( + (1 0 FLD) + (5 2 FST) + (5 3 FSTP) ; i486 book has 5 1 + (1 1 FXCH #f) + (0 2 FCOM #f) + (0 3 FCOMP #f) + (6 3 FCOMPP #f) ; really only with (ST 1) + (5 4 FUCOM #f) + (5 5 FUCOMP #f) + (2 5 FUCOMPP #f) ; really only with (ST 1) + (0 0 FADD #f) + (4 0 FADD #t) + (0 5 FSUB #f) + (4 5 FSUB #t) + (6 5 FSUBP #t) + (0 4 FSUBR #f) + (4 4 FSUBR #t) + (6 4 FSUBRP #t) + (0 1 FMUL #f) + (4 1 FMUL #t) + (6 1 FMULP #t) + (0 7 FDIV #f) + (4 7 FDIV #t) + (6 7 FDIVP #t) + (0 6 FDIVR #f) + (4 6 FDIVR #t) + (6 6 FDIVRP #t) + (5 0 FFREE)))) + + (table-1&2 + (make-table-1-3 + '( + (1 0 FLD S) + (5 0 FLD D) + (3 5 FLD X) + (7 0 FILD H) + (3 0 FILD L) + (7 5 FILD Q) + (7 4 FBLD) + (1 2 FST S) + (5 2 FST D) + (1 3 FSTP S) ; i486 book has 3 3 like FISTP + (5 3 FSTP D) + (3 7 FSTP X) + (7 2 FIST H) + (3 2 FIST L) + (7 3 FISTP H) + (3 3 FISTP L) + (7 7 FISTP Q) + (7 6 FBSTP) + (0 2 FCOM S (ST 0)) + (4 2 FCOM D (ST 0)) + (0 3 FCOMP S (ST 0)) + (4 3 FCOMP D (ST 0)) + (6 2 FICOM H) + (2 2 FICOM L) + (6 3 FICOMP H) + (2 3 FICOMP L) + (0 0 FADD S) + (4 0 FADD D) + (0 4 FSUB S) + (4 4 FSUB D) + (0 5 FSUBR S) + (4 5 FSUBR D) + (0 1 FMUL S) + (4 1 FMUL D) + (0 6 FDIV S) + (4 6 FDIV D) ; i486 manual has 4 4 like FSUB + (0 7 FDIVR S) + (4 7 FDIVR D) + (6 0 FIADD H) + (2 0 FIADD L) + (6 4 FISUB H) + (2 4 FISUB L) + (6 5 FISUBR H) + (2 5 FISUBR L) + (6 1 FIMUL H) + (2 1 FIMUL L) + (6 6 FIDIV H) + (2 6 FIDIV L) + (6 7 FIDIVR H) + (2 7 FIDIVR L) + (5 7 FNSTSW) + (1 5 FLDCW) + (1 7 FNSTCW) + (1 6 FNSTENV) + (1 4 FLDENV) + (5 6 FNSAVE) + (5 4 FRSTOR))))))) + +(define dispatch/0f + (let* ((unknown-inst + (lambda (second-byte) + (unknown-inst #x0f second-byte))) + (table + (vector + (dispatch-on-low-nibble ; 0 + (group-6&7 '#(SLDT STR LLDT LTR VERR VERW #f #f)) + (group-6&7 '#(SGDT SIDT LGDT LIDT SMSW #f LMSW #f)) + (decode-G/E '(LAR)) + (decode-G/E '(LSL)) + unknown-inst + unknown-inst + (simple-inst '(CLTS)) + unknown-inst + + (simple-inst '(INVD)) + (simple-inst '(WBINVD)) + unknown-inst + unknown-inst + unknown-inst + unknown-inst + unknown-inst + unknown-inst) + + unknown-inst ; 1 + + (dispatch-on-bit ; 2 + (dispatch-on-low-three-bits + (decode-X/E '(MOV) 'CR) + (decode-X/E '(MOV) 'DR) + (decode-E/X '(MOV) 'CR) + (decode-E/X '(MOV) 'DR) + (decode-X/E '(MOV) 'TR) + unknown-inst + (decode-E/X '(MOV) 'TR) + unknown-inst) + unknown-inst) + + unknown-inst ; 3 + + unknown-inst ; 4 + + unknown-inst ; 5 + + unknown-inst ; 6 + + unknown-inst ; 7 + + (lambda (opcode-byte) ; 8 + ((decode-pcrw + `(,(vector-ref jcc-opcodes (low-nibble opcode-byte)) + W)) + opcode-byte)) + + (lambda (opcode-byte) ; 9 + ((decode-E + `(,(vector-ref setcc-opcodes (low-nibble opcode-byte)))) + opcode-byte)) + + (dispatch-on-low-nibble ; A + (simple-inst '(PUSH FS)) + (simple-inst '(POP FS)) + unknown-inst + (decode-E/G '(BT)) + (decode-E/G/I '(SHLD) immediate-byte) + (decode-E/G/I '(SHLD) (lambda () '(R 1))) + (decode-E/G '(CMPXCHG B)) + (decode-E/G '(CMPXCHG W)) + + (simple-inst '(PUSH GS)) + (simple-inst '(POP GS)) + unknown-inst + (decode-E/G '(BTS)) + (decode-E/G/I '(SHRD) immediate-byte) + (decode-E/G/I '(SHRD) (lambda () '(R 1))) + unknown-inst + (decode-G/E '(IMUL W))) + + (dispatch-on-low-nibble ; B + unknown-inst + unknown-inst + (decode-G/M '(LSS)) + (decode-E/G '(BTR)) + (decode-G/M '(LFS)) + (decode-G/M '(LGS)) + (decode-G/E '(MOVZX B)) + (decode-G/E '(MOVZX W)) + + unknown-inst + unknown-inst + group-8 + (decode-E/G '(BTC)) + (decode-G/E '(BSF)) + (decode-G/E '(BSR)) + (decode-G/E '(MOVSX B)) + (decode-G/E '(MOVSX W))) + + (dispatch-on-bit ; C + (dispatch-on-low-three-bits + (decode-E/G '(XADD B)) + (decode-E/G '(XADD W)) + unknown-inst + unknown-inst + unknown-inst + unknown-inst + unknown-inst + unknown-inst) + (register-op '(BSWAP))) + + unknown-inst ; D + + unknown-inst ; E + + unknown-inst))) ; F + + (lambda (opcode-byte) + opcode-byte ; ignored + (let ((next (next-unsigned-byte))) + ((vector-ref table (high-nibble next)) + next))))) + +(define disassemble-next-instruction + (let* ((arith-opcodes + '#(ADD OR ADC SBB AND SUB XOR CMP)) + (shift-opcodes + '#(ROL ROR RCL RCR SHL SHR SAL SAR)) + (table + (vector + (dispatch-on-low-nibble ; 0 + (decode-E/G '(ADD B)) + (decode-E/G '(ADD W)) + (decode-G/E '(ADD B)) + (decode-G/E '(ADD W)) + (decode-Ib '(ADD B (R 0))) + (decode-Iw '(ADD W (R 0))) + (simple-inst '(PUSH ES)) + (simple-inst '(POP ES)) + + (decode-E/G '(OR B)) + (decode-E/G '(OR W)) + (decode-G/E '(OR B)) + (decode-G/E '(OR W)) + (decode-Ib '(OR B (R 0))) + (decode-Iw '(OR W (R 0))) + (simple-inst '(PUSH CS)) + dispatch/0f) + + (dispatch-on-low-nibble ; 1 + (decode-E/G '(ADC B)) + (decode-E/G '(ADC W)) + (decode-G/E '(ADC B)) + (decode-G/E '(ADC W)) + (decode-Ib '(ADC B (R 0))) + (decode-Iw '(ADC W (R 0))) + (simple-inst '(PUSH SS)) + (simple-inst '(POP SS)) + + (decode-E/G '(SBB B)) + (decode-E/G '(SBB W)) + (decode-G/E '(SBB B)) + (decode-G/E '(SBB W)) + (decode-Ib '(SBB B (R 0))) + (decode-Iw '(SBB W (R 0))) + (simple-inst '(PUSH DS)) + (simple-inst '(POP DS))) + + (dispatch-on-low-nibble ; 2 + (decode-E/G '(AND B)) + (decode-E/G '(AND W)) + (decode-G/E '(AND B)) + (decode-G/E '(AND W)) + (decode-Ib '(AND B (R 0))) + (decode-Iw '(AND W (R 0))) + (simple-inst '(ESSEG)) + (simple-inst '(DAA)) + + (decode-E/G '(SUB B)) + (decode-E/G '(SUB W)) + (decode-G/E '(SUB B)) + (decode-G/E '(SUB W)) + (decode-Ib '(SUB B (R 0))) + (decode-Iw '(AND W (R 0))) + (simple-inst '(CSSEG)) + (simple-inst '(DAS))) + + (dispatch-on-low-nibble ; 3 + (decode-E/G '(XOR B)) + (decode-E/G '(XOR W)) + (decode-G/E '(XOR B)) + (decode-G/E '(XOR W)) + (decode-Ib '(XOR B (R 0))) + (decode-Iw '(XOR W (R 0))) + (simple-inst '(SSSEG)) + (simple-inst '(AAA)) + + (decode-E/G '(CMP B)) + (decode-E/G '(CMP W)) + (decode-G/E '(CMP B)) + (decode-G/E '(CMP W)) + (decode-Ib '(CMP B (R 0))) + (decode-Iw '(CMP W (R 0))) + (simple-inst '(DSSEG)) + (simple-inst '(AAS))) + + (dispatch-on-bit ; 4 + (register-op '(INC)) + (register-op '(DEC))) + + (dispatch-on-bit ; 5 + (register-op '(PUSH)) + (register-op '(POP))) + + (dispatch-on-low-nibble ; 6 + (simple-inst '(PUSHA)) + (simple-inst '(POPA)) + (decode-G/M '(BOUND)) + (decode-E/G '(ARPL)) + (simple-inst '(FSSEG)) + (simple-inst '(GSSEG)) + (simple-inst '(OPSIZE)) + (simple-inst '(ADSIZE)) + + (decode-Iw '(PUSH W)) + (decode-G/E/I '(IMUL W) immediate-word) + (decode-Ib '(PUSH B)) + (decode-G/E/I '(IMUL B) immediate-byte) + (simple-inst '(INS B)) + (simple-inst '(INS W)) + (simple-inst '(OUTS B)) + (simple-inst '(OUTS W))) + + (lambda (opcode-byte) ; 7 + ((decode-pcrb + `(,(vector-ref jcc-opcodes (low-nibble opcode-byte)) + B)) + opcode-byte)) + + (dispatch-on-low-nibble ; 8 + (group-1&2 arith-opcodes 'B immediate-byte) + (group-1&2 arith-opcodes 'W immediate-word) + (decode-Ib '(MOV B (R 0))) + (group-1&2 arith-opcodes 'W immediate-byte) + (decode-E/G '(TEST B)) + (decode-E/G '(TEST W)) + (decode-E/G '(XCHG B)) + (decode-E/G '(XCHG W)) + + (decode-E/G '(MOV B)) + (decode-E/G '(MOV W)) + (decode-G/E '(MOV B)) + (decode-G/E '(MOV W)) + (decode-E/X '(MOV) 'SR) + (decode-G/M '(LEA)) + (decode-X/E '(MOV) 'SR) + (decode-E '(POP) 0)) + + (dispatch-on-bit ; 9 + (register-op '(XCHG W (R 0))) + (dispatch-on-low-three-bits + (simple-inst '(CBW)) + (simple-inst '(CWDE)) + (decode-Ap '(CALL F)) + (simple-inst '(WAIT)) + (simple-inst '(PUSHF)) + (simple-inst '(POPF)) + (simple-inst '(SAHF)) + (simple-inst '(LAHF)))) + + (dispatch-on-low-nibble ; A + (decode-@ '(MOV B (R 0))) + (decode-@ '(MOV W (R 0))) + (backwards + (decode-@ '(MOV B (R 0)))) + (backwards + (decode-@ '(MOV W (R 0)))) + (simple-inst '(MOVSB)) + (simple-inst '(MOVSW)) + (simple-inst '(CMPSB)) + (simple-inst '(CMPSW)) + + (decode-Ib '(TEST B (R 0))) + (decode-Iw '(TEST W (R 0))) + (simple-inst '(STOS B)) + (simple-inst '(STOS W)) + (simple-inst '(LODS B)) + (simple-inst '(LODS W)) + (simple-inst '(SCAS B)) + (simple-inst '(SCAS W))) + + (dispatch-on-bit ; B + (lambda (opcode) + ((decode-Ib + `(MOV B (R ,(fix:and opcode #x7)))) + opcode)) + (lambda (opcode) + ((decode-Iw + `(MOV W (R ,(fix:and opcode #x7)))) + opcode))) + + (dispatch-on-low-nibble ; C + (group-1&2 shift-opcodes 'B immediate-byte) + (group-1&2 shift-opcodes 'W immediate-byte) + (decode-I16 '(RET)) + (simple-inst '(RET)) + (decode-G/M '(LES)) + (decode-G/M '(LDS)) + (decode-E/I '(MOV B) next-byte) + (decode-E/I '(MOV W) next-word) + + decode-ENTER + (simple-inst '(LEAVE)) + (decode-I16 '(RET F)) + (simple-inst '(RET F)) + (simple-inst '(INT 3)) + (decode-Ib '(INT)) + (simple-inst '(INTO)) + (simple-inst '(IRET))) + + (dispatch-on-bit ; D + (dispatch-on-low-three-bits + (group-1&2 shift-opcodes 'B (lambda () '(& 1))) + (group-1&2 shift-opcodes 'W (lambda () '(& 1))) + (group-1&2 shift-opcodes 'B (lambda () '(R 1))) + (group-1&2 shift-opcodes 'W (lambda () '(R 1))) + (simple-inst '(AAM)) + (simple-inst '(AAD)) + unknown-inst + (simple-inst '(XLAT))) + decode-fp) + + (dispatch-on-low-nibble ; E + (decode-pcrb '(LOOPNE)) + (decode-pcrb '(LOOPE)) + (decode-pcrb '(LOOP)) + (decode-pcrb '(JCXZ)) + (decode-Ib '(IN B (R 0))) + (decode-Iw '(IN W (R 0))) + (backwards (decode-Ib '(OUT B (R 0)))) + (backwards (decode-IW '(OUT W (R 0)))) + + (decode-pcrw '(CALL)) + (decode-pcrw '(JMP W)) + (decode-ap '(JMP F)) + (decode-pcrb '(JMP B)) + (simple-inst '(IN B (R 0) (R 2))) + (simple-inst '(IN W (R 0) (R 2))) + (simple-inst '(OUT B (R 2) (R 0))) + (simple-inst '(OUT W (R 2) (R 0)))) + + (dispatch-on-low-nibble ; F + (simple-inst '(LOCK)) + unknown-inst + (simple-inst '(REPNE)) + (simple-inst '(REPE)) + (simple-inst '(HLT)) + (simple-inst '(CMC)) + (group-3 'B next-byte) + (group-3 'W next-word) + + (simple-inst '(CLC)) + (simple-inst '(STC)) + (simple-inst '(CLI)) + (simple-inst '(STI)) + (simple-inst '(CLD)) + (simple-inst '(STD)) + (group-4 'B) + (group-5 'W))))) + + (lambda () + (let ((opcode-byte (next-unsigned-byte))) + ((vector-ref table (high-nibble opcode-byte)) + opcode-byte))))) \ No newline at end of file -- 2.25.1