[movitz-cvs] CVS movitz
ffjeld
ffjeld at common-lisp.net
Sat Feb 16 18:01:09 UTC 2008
Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv25557
Modified Files:
asm-x86.lisp
Log Message:
More disassembler development.
--- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/14 21:56:36 1.21
+++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/16 18:01:07 1.22
@@ -2,11 +2,11 @@
;;;;
;;;; Copyright (C) 2007 Frode V. Fjeld
;;;;
-;;;; Description: x86 assembler for 32 and 64-bit.
+;;;; Description: x86 assembler for 16, 32, and 64-bit modes.
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: asm-x86.lisp,v 1.21 2008/02/14 21:56:36 ffjeld Exp $
+;;;; $Id: asm-x86.lisp,v 1.22 2008/02/16 18:01:07 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -216,7 +216,7 @@
(cond
((atom body)
nil)
- ((member (car body) '(reg-modrm))
+ ((member (car body) '(reg-modrm modrm opcode imm-modrm imm))
(list body))
(t (mapcan #'find-forms body)))))
(let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator))))
@@ -240,7 +240,9 @@
(assembler (&body body)
(declare (ignore body))))
(let ((operator ',operator)
- (operator-mode ',operator-mode))
+ (operator-mode ',operator-mode)
+ (operand-formals ',lambda-list))
+ (declare (ignorable operand-formals))
,@(find-forms body)))
',operator))))
@@ -248,6 +250,7 @@
`(define-operator ,name nil ,lambda-list , at body))
(deftype list-of (&rest elements)
+ "A list with elements of specified type(s)."
(labels ((make-list-of (elements)
(if (null elements)
'null
@@ -255,6 +258,15 @@
,(make-list-of (cdr elements))))))
(make-list-of elements)))
+(deftype list-of* (&rest elements)
+ "A list starting with elements of specified type(s)."
+ (labels ((make-list-of (elements)
+ (if (null elements)
+ 'list
+ `(cons ,(car elements)
+ ,(make-list-of (cdr elements))))))
+ (make-list-of elements)))
+
(defparameter *opcode-disassemblers-16*
(make-array 256 :initial-element nil))
@@ -265,7 +277,7 @@
(make-array 256 :initial-element nil))
(deftype disassembly-decoder ()
- '(list-of keyword (or keyword null) symbol))
+ '(list-of* keyword (or keyword null) symbol))
(defun (setf opcode-disassembler) (decoder opcode operator-mode)
(check-type decoder disassembly-decoder)
@@ -297,7 +309,7 @@
(set-it *opcode-disassemblers-32* opcode)
(set-it *opcode-disassemblers-64* opcode)))))
-(defun disassemble-code (code &optional override-operand-size override-address-size rex)
+(defun disassemble-instruction (code &optional override-operand-size override-address-size rex)
(labels ((lookup-decoder (table opcode)
(let* ((datum (pop-code code))
(opcode (logior (ash opcode 8)
@@ -306,7 +318,7 @@
(typecase decoder
((simple-vector 256)
(lookup-decoder decoder opcode))
- ((list-of keyword (or keyword null) symbol)
+ (disassembly-decoder
(values decoder
opcode))
(t (error "No disassembler registered for opcode #x~X." opcode))))))
@@ -316,30 +328,40 @@
(:32-bit *opcode-disassemblers-32*)
(:64-bit *opcode-disassemblers-64*))
0)
- (destructuring-bind (operator operand-size decoder-function)
+ (destructuring-bind (operator operand-size decoder-function &rest extra-args)
decoder
- (values (code-call (funcall decoder-function
- code
- operator
- opcode
- (or operand-size override-operand-size)
- (or override-address-size *cpu-mode*)
- rex))
+ (warn "extraS: ~S" extra-args)
+ (values (code-call (apply decoder-function
+ code
+ operator
+ opcode
+ (or operand-size override-operand-size)
+ (or override-address-size *cpu-mode*)
+ rex
+ extra-args))
code)))))
-(defmacro define-disassembler ((operator opcode &optional cpu-mode) lambda-list &body body)
- (if (and (symbolp lambda-list)
- (null body))
- `(setf (opcode-disassembler ',opcode ,cpu-mode) (list ,operator ,cpu-mode ',lambda-list))
- (let ((defun-name (intern (format nil "~A-~A-~X~@[-~A~]" 'disassembler operator opcode cpu-mode))))
- `(progn
- (defun ,defun-name ,lambda-list , at body)
- (setf (opcode-disassembler ',opcode ',cpu-mode) (list ,operator ',cpu-mode ',defun-name))
- ',defun-name))))
+(defmacro define-disassembler ((operator opcode &optional cpu-mode (digit nil digit-p)) lambda-list &body body)
+ (cond
+ (digit-p
+ `(loop for mod from #b00 to #b11
+ do (loop for r/m from #b000 to #b111
+ as ext-opcode = (logior (ash ,opcode 8)
+ (ash ,digit 3)
+ (ash mod 6)
+ r/m)
+ do (define-disassembler (,operator ext-opcode ,cpu-mode) ,lambda-list , at body))))
+ ((symbolp lambda-list)
+ `(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,operator ,cpu-mode ',lambda-list , at body)))
+ (t (let ((defun-name (intern (format nil "~A-~A-~X~@[-~A~]" 'disassembler operator opcode cpu-mode))))
+ `(progn
+ (defun ,defun-name ,lambda-list , at body)
+ (setf (opcode-disassembler ,opcode ',cpu-mode) (list ,operator ',cpu-mode ',defun-name))
+ ',defun-name)))))
(defun disassemble-simple-prefix (code operator opcode operand-size address-size rex)
(declare (ignore opcode rex))
- (let ((instruction (code-call (disassemble-code code operand-size address-size nil))))
+ (let ((instruction (code-call (disassemble-instruction code operand-size address-size nil))))
(values (if (consp (car instruction))
(list* (list* operator (car instruction))
(cdr instruction))
@@ -359,19 +381,19 @@
(define-disassembler (:operand-size-override #x66 :32-bit) (code operator opcode operand-size address-size rex)
(declare (ignore operator opcode operand-size rex))
- (disassemble-code code :16-bit address-size nil))
+ (disassemble-instruction code :16-bit address-size nil))
(define-disassembler (:address-size-override #x67 :32-bit) (code operator opcode operand-size address-size rex)
(declare (ignore operator opcode operand-size rex))
- (disassemble-code code operand-size :16-bit nil))
+ (disassemble-instruction code operand-size :16-bit nil))
(define-disassembler (:operand-size-override #x66 :16-bit) (code operator opcode operand-size address-size rex)
(declare (ignore operator opcode operand-size rex))
- (disassemble-code code :32-bit address-size nil))
+ (disassemble-instruction code :32-bit address-size nil))
(define-disassembler (:address-size-override #x67 :16-bit) (code operator opcode operand-size address-size rex)
(declare (ignore operator opcode operand-size rex))
- (disassemble-code code operand-size :32-bit nil))
+ (disassemble-instruction code operand-size :32-bit nil))
(defmacro define-operator/8 (operator lambda-list &body body)
`(define-operator ,operator :8-bit ,lambda-list
@@ -778,12 +800,23 @@
:displacement (encode-integer offset '(xint 16))))
(t (error "Huh? reg: ~S, reg2: ~S, scale: ~S, offset: ~S" reg reg2 reg-scale offset)))))))))))))
+(defun operand-ordering (formals &rest arrangement)
+ (loop with rarrangement = (reverse arrangement)
+ for formal in formals
+ when (getf rarrangement formal)
+ collect it))
+
+(defun order-operands (ordering &rest operands)
+ (loop for key in ordering
+ collect (or (getf operands key)
+ (error "No operand ~S in ~S." key operands))))
+
(defmacro pop-code (code-place &optional context)
`(let ((x (pop ,code-place)))
(check-type x (unsigned-byte 8) ,(format nil "an octet (context: ~A)" context))
x))
-(defmacro code-call (form &optional (code-place (case (car form) (funcall (third form)) (t (second form)))))
+(defmacro code-call (form &optional (code-place (case (car form) ((funcall apply) (third form)) (t (second form)))))
"Execute form, then 'magically' update the code binding with the secondary return value from form."
`(let (tmp)
(setf (values tmp ,code-place) ,form)))
@@ -800,78 +833,107 @@
(1+ (lognot unsigned-integer)))))
code)))
-(defun decode-reg-modrm (code operator opcode operand-size address-size rex)
+(defun decode-no-operands (code operator opcode operand-size address-size rex)
+ (declare (ignore opcode operand-size address-size rex))
+ (values (list operator)
+ code))
+
+(defun decode-reg-modrm (code operator opcode operand-size address-size rex operand-ordering)
(declare (ignore opcode rex))
- (ecase address-size
- (:32-bit
- (decode-reg-modrm-32 code operator operand-size))
- (:16-bit
- (decode-reg-modrm-16 code operator operand-size))))
+ (values (list* operator
+ (order-operands operand-ordering
+ :reg (nth (ldb (byte 3 3) (car code))
+ (register-set-by-mode operand-size))
+ :modrm (ecase address-size
+ (:32-bit
+ (code-call (decode-reg-modrm-32 code operand-size)))
+ (:16-bit
+ (code-call (decode-reg-modrm-16 code operand-size))))))
+ code))
+
+
+(defun decode-modrm (code operator opcode operand-size address-size rex)
+ (values (list operator
+ (ecase address-size
+ (:32-bit
+ (code-call (decode-reg-modrm-32 code operand-size)))
+ (:16-bit
+ (code-call (decode-reg-modrm-16 code operand-size)))))
+ code))
+
+(defun decode-imm-modrm (code operator opcode operand-size address-size rex imm-type operand-ordering &key fixed-modrm)
+ (values (list* operator
+ (order-operands operand-ordering
+ :modrm (or fixed-modrm
+ (when (member :modrm operand-ordering)
+ (ecase address-size
+ (:32-bit
+ (code-call (decode-reg-modrm-32 code operand-size)))
+ (:16-bit
+ (code-call (decode-reg-modrm-16 code operand-size))))))
+ :imm (code-call (decode-integer code imm-type))))
+ code))
-(defun decode-reg-modrm-16 (code operator operand-size)
+(defun decode-reg-modrm-16 (code operand-size)
(let* ((modrm (pop-code code mod/rm))
(mod (ldb (byte 2 6) modrm))
(reg (ldb (byte 3 3) modrm))
(r/m (ldb (byte 3 0) modrm)))
- (values (list operator
- (nth reg (register-set-by-mode operand-size))
- (if (= mod #b11)
- (nth reg (register-set-by-mode operand-size))
- (flet ((operands (i)
- (nth i '((:bx :si) (:bx :di) (:bp :si) (:bp :di) (:si) (:di) (:bp) (:bx)))))
- (ecase mod
- (#b00
- (case r/m
- (#b110 (code-call (decode-integer code '(uint 16))))
- (t (operands r/m))))
- (#b01
- (append (operands r/m)
- (code-call (decode-integer code '(sint 8)))))
- (#b10
- (append (operands r/m)
- (code-call (decode-integer code '(uint 16)))))))))
+ (values (if (= mod #b11)
+ (nth reg (register-set-by-mode operand-size))
+ (flet ((operands (i)
+ (nth i '((:bx :si) (:bx :di) (:bp :si) (:bp :di) (:si) (:di) (:bp) (:bx)))))
+ (ecase mod
+ (#b00
+ (case r/m
+ (#b110 (code-call (decode-integer code '(uint 16))))
+ (t (operands r/m))))
+ (#b01
+ (append (operands r/m)
+ (code-call (decode-integer code '(sint 8)))))
+ (#b10
+ (append (operands r/m)
+ (code-call (decode-integer code '(uint 16))))))))
code)))
-(defun decode-reg-modrm-32 (code operator operand-size)
+(defun decode-reg-modrm-32 (code operand-size)
"Return a list of the REG, and the MOD/RM operands."
(let* ((modrm (pop-code code mod/rm))
(mod (ldb (byte 2 6) modrm))
(reg (ldb (byte 3 3) modrm))
(r/m (ldb (byte 3 0) modrm)))
- (values (list operator
- (nth reg (register-set-by-mode operand-size))
- (if (= mod #b11)
- (nth r/m (register-set-by-mode operand-size))
- (flet ((decode-sib ()
- (let* ((sib (pop-code code sib))
- (ss (ldb (byte 2 6) sib))
- (index (ldb (byte 3 3) sib))
- (base (ldb (byte 3 0) sib)))
- (nconc (unless (= index #b100)
- (let ((index-reg (nth index (register-set-by-mode :32-bit))))
- (if (= ss #b00)
- (list index-reg)
- (list (list index-reg (ash 2 ss))))))
- (if (/= base #b101)
- (list (nth base (register-set-by-mode :32-bit)))
- (ecase mod
- (#b00 nil)
- ((#b01 #b10) (list :ebp))))))))
- (ecase mod
- (#b00 (case r/m
- (#b100 (decode-sib))
- (#b101 (code-call (decode-integer code '(uint 32))))
- (t (list (nth r/m (register-set-by-mode :32-bit))))))
- (#b01 (case r/m
- (#b100 (nconc(decode-sib)
- (list (code-call (decode-integer code '(sint 8))))))
- (t (list (nth r/m (register-set-by-mode :32-bit))
- (code-call (decode-integer code '(sint 8)))))))
- (#b10 (case r/m
- (#b100 (nconc (decode-sib)
- (list (code-call (decode-integer code '(uint 32))))))
- (t (list (nth r/m (register-set-by-mode :32-bit))
- (code-call (decode-integer code '(uint 32)))))))))))
+ (values (if (= mod #b11)
+ (nth r/m (register-set-by-mode operand-size))
+ (flet ((decode-sib ()
+ (let* ((sib (pop-code code sib))
+ (ss (ldb (byte 2 6) sib))
+ (index (ldb (byte 3 3) sib))
+ (base (ldb (byte 3 0) sib)))
+ (nconc (unless (= index #b100)
+ (let ((index-reg (nth index (register-set-by-mode :32-bit))))
+ (if (= ss #b00)
+ (list index-reg)
+ (list (list index-reg (ash 2 ss))))))
+ (if (/= base #b101)
+ (list (nth base (register-set-by-mode :32-bit)))
+ (ecase mod
+ (#b00 nil)
+ ((#b01 #b10) (list :ebp))))))))
+ (ecase mod
+ (#b00 (case r/m
+ (#b100 (decode-sib))
+ (#b101 (code-call (decode-integer code '(uint 32))))
+ (t (list (nth r/m (register-set-by-mode :32-bit))))))
+ (#b01 (case r/m
+ (#b100 (nconc(decode-sib)
+ (list (code-call (decode-integer code '(sint 8))))))
+ (t (list (nth r/m (register-set-by-mode :32-bit))
+ (code-call (decode-integer code '(sint 8)))))))
+ (#b10 (case r/m
+ (#b100 (nconc (decode-sib)
+ (list (code-call (decode-integer code '(uint 32))))))
+ (t (list (nth r/m (register-set-by-mode :32-bit))
+ (code-call (decode-integer code '(uint 32))))))))))
code)))
@@ -883,28 +945,54 @@
`(let ((x (encode ,form)))
(when x (return-from operator x))))
-(defmacro imm (imm-operand opcode imm-type &rest extras)
- `(when (immediate-p ,imm-operand)
- (let ((immediate (resolve-operand ,imm-operand)))
- (when (typep immediate ',imm-type)
- (return-values-when
- (encoded-values :opcode ,opcode
- :immediate (encode-integer immediate ',imm-type)
- :operand-size operator-mode
- :rex default-rex
- , at extras))))))
+(defmacro imm (imm-operand opcode imm-type &optional extra-operand &rest extras)
+ `(progn
+ (assembler
+ (when (and ,@(when extra-operand
+ (list (list* 'eql extra-operand)))
+ (immediate-p ,imm-operand))
+ (let ((immediate (resolve-operand ,imm-operand)))
+ (when (typep immediate ',imm-type)
+ (return-values-when
+ (encoded-values :opcode ,opcode
+ :immediate (encode-integer immediate ',imm-type)
+ :operand-size operator-mode
+ :rex default-rex
+ , at extras))))))
+ (disassembler
+ ,(if extra-operand
+ `(define-disassembler (operator ,opcode operator-mode)
+ decode-imm-modrm
+ ',imm-type
+ (operand-ordering operand-formals
+ :imm ',imm-operand
+ :modrm ',(first extra-operand))
+ :fixed-modrm ',(second extra-operand))
+ `(define-disassembler (operator ,opcode operator-mode)
[333 lines skipped]
More information about the Movitz-cvs
mailing list