[movitz-cvs] CVS movitz
ffjeld
ffjeld at common-lisp.net
Thu Jan 3 10:34:18 UTC 2008
Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv1564
Modified Files:
asm-x86.lisp
Log Message:
Some assembler work over christmas.
--- /project/movitz/cvsroot/movitz/asm-x86.lisp 2007/12/20 22:52:18 1.4
+++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/01/03 10:34:18 1.5
@@ -6,7 +6,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: asm-x86.lisp,v 1.4 2007/12/20 22:52:18 ffjeld Exp $
+;;;; $Id: asm-x86.lisp,v 1.5 2008/01/03 10:34:18 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -17,6 +17,7 @@
(defvar *symtab* nil)
(defvar *cpu-mode* :32-bit)
+(defvar *pc* nil "Current program counter.")
(defvar *instruction-encoders*
(make-hash-table :test 'eq))
@@ -81,22 +82,24 @@
(encode-to-parts instruction)
(unless opcode
(error "Unable to encode instruction ~S." instruction))
- (when (or (and (eq operand-size :16-bit)
- (eq *cpu-mode* :64-bit))
- (and (eq operand-size :16-bit)
- (eq *cpu-mode* :32-bit))
- (and (eq operand-size :32-bit)
- (eq *cpu-mode* :16-bit)))
- (pushnew :operand-size-override
- prefixes))
(when (or (and (eq address-size :32-bit)
(eq *cpu-mode* :64-bit))
(and (eq address-size :16-bit)
(eq *cpu-mode* :32-bit))
+ (and (eq address-size :64-bit)
+ (eq *cpu-mode* :32-bit))
(and (eq address-size :32-bit)
(eq *cpu-mode* :16-bit)))
(pushnew :address-size-override
prefixes))
+ (when (or (and (eq operand-size :16-bit)
+ (eq *cpu-mode* :64-bit))
+ (and (eq operand-size :16-bit)
+ (eq *cpu-mode* :32-bit))
+ (and (eq operand-size :32-bit)
+ (eq *cpu-mode* :16-bit)))
+ (pushnew :operand-size-override
+ prefixes))
(append (mapcar #'prefix-lookup (reverse prefixes))
(rex-encode rexes :rm rm)
(when (< 8(integer-length opcode))
@@ -206,8 +209,12 @@
(check-type operator keyword)
(let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator))))
`(progn
- (defun ,defun-name ,lambda-list (block operator
- , at body))
+ (defun ,defun-name ,lambda-list
+ (let ((operator-mode nil)
+ (default-rex nil))
+ (declare (ignorable operator-mode default-rex))
+ (block operator
+ , at body)))
(setf (gethash ',operator *instruction-encoders*)
',defun-name)
',operator)))
@@ -216,6 +223,7 @@
`(define-operator ,operator ,lambda-list
(let ((operator-mode :8-bit)
(default-rex nil))
+ (declare (ignorable operator-mode default-rex))
(macrolet ((yield (&rest args)
`(encoded-result :operand-size 8 , at args)))
, at body))))
@@ -232,6 +240,7 @@
`(define-operator ,operator ,lambda-list
(let ((operator-mode :32-bit)
(default-rex nil))
+ (declare (ignorable operator-mode))
(macrolet ((yield (&rest args)
`(encoded-result :operand-size operator-mode , at args)))
, at body))))
@@ -240,6 +249,7 @@
`(define-operator ,operator ,lambda-list
(let ((operator-mode :64-bit)
(default-rex '(:rex.w)))
+ (declare (ignorable operator-mode))
(macrolet ((yield (&rest args)
`(encoded-result :operand-size operator-mode , at args)))
, at body))))
@@ -250,15 +260,19 @@
(default-rex (case *cpu-mode*
(:64-bit nil)
(t '(:rex.w)))))
+ (declare (ignorable operator-mode))
, at body)))
(defmacro define-operator* ((&key |16| |32| |64|) args &body body)
(let ((body16 (subst '(xint 16) :int-16-32-64
- (subst :ax :ax-eax-rax body)))
+ (subst :dx :dx-edx-rdx
+ (subst :ax :ax-eax-rax body))))
(body32 (subst '(xint 32) :int-16-32-64
- (subst :eax :ax-eax-rax body)))
+ (subst :edx :dx-edx-rdx
+ (subst :eax :ax-eax-rax body))))
(body64 (subst '(sint 32) :int-16-32-64
- (subst :rax :ax-eax-rax body))))
+ (subst :rdx :dx-edx-rdx
+ (subst :rax :ax-eax-rax body)))))
`(progn
,(when |16|
`(define-operator/16 ,|16| ,args , at body16))
@@ -267,12 +281,6 @@
,(when |64|
`(define-operator/64 ,|64| ,args , at body64)))))
-
-(defmacro define-simple (operator opcode)
- (check-type opcode (unsigned-byte 16))
- `(define-operator ,operator ()
- (encoded-values :opcode ,opcode)))
-
(defun resolve (x)
(etypecase x
(integer
@@ -296,11 +304,13 @@
(t (error "Unresolved symbol ~S (size ~S)." x size)))
type))
-(defun encode-pc-relative (operand type)
- (when (typep operand '(cons (eql :pc+)))
- (encode-integer (reduce #'+ (cdr operand)
- :key #'resolve)
- type)))
+(defun resolve-pc-relative (operand)
+ (typecase operand
+ ((cons (eql :pc+))
+ (reduce #'+ (cdr operand)
+ :key #'resolve))
+ (symbol-reference
+ (- (resolve operand) *pc*))))
(defun encode-integer (i type)
(assert (typep i type))
@@ -340,8 +350,8 @@
(defun encode-reg/mem (operand mode)
- (check-type mode (member :8-bit :16-bit :32-bit :64-bit :mm :xmm))
- (if (keywordp operand)
+ (check-type mode (member nil :8-bit :16-bit :32-bit :64-bit :mm :xmm))
+ (if (and mode (keywordp operand))
(encoded-values :mod #b11
:rm (or (position operand (ecase mode
(:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh))
@@ -361,10 +371,18 @@
(let ((offset (reduce #'+ offsets
:key #'resolve)))
(cond
+ ((and (not reg)
+ (eq mode :16-bit)
+ (typep offset '(xint 16)))
+ (encoded-values :mod #b00
+ :rm #b110
+ :address-size :16-bit
+ :displacement (encode-integer offset '(xint 16))))
((and (not reg)
(typep offset '(xint 32)))
(encoded-values :mod #b00
:rm #b101
+ :address-size :32-bit
:displacement (encode-integer offset '(xint 32))))
((and (eq reg :sp)
(not reg2)
@@ -483,13 +501,27 @@
:rm register-index
:displacement (encode-integer offset '(sint 32))
:address-size address-size))
+ ((and (not reg2)
+ register-index
+ (if (eq :64-bit *cpu-mode*)
+ (typep offset '(sint 32))
+ (typep offset '(xint 32)))
+ (not (= #b100 register-index)))
+ (encoded-values :rm #b100
+ :mod #b00
+ :index register-index
+ :base #b101
+ :scale (or (position reg-scale '(1 2 4 8))
+ (error "Unknown register scale ~S." reg-scale))
+ :displacement (encode-integer offset '(xint 32))))
((and reg2
register-index
(zerop offset)
(not (= register-index #b100)))
(encoded-values :mod #b00
:rm #b100
- :scale (position reg-scale '(1 2 4 8))
+ :scale (or (position reg-scale '(1 2 4 8))
+ (error "Unknown register scale ~S." reg-scale))
:index register-index
:base (or (position reg2 map)
(error "unknown reg2 [A] ~S" reg2))
@@ -580,13 +612,13 @@
(declare (ignore prefixes prefix rex opcode mod reg rm scale index base displacement immediate operand-size address-size))
`(return-from operator (encoded-values , at args)))
-(defmacro imm (imm-operand condition opcode imm-type &rest extras)
- `(when (and ,(or condition t)
- (immediate-p ,imm-operand))
+(defmacro imm (imm-operand opcode imm-type &rest extras)
+ `(when (immediate-p ,imm-operand)
(let ((immediate (resolve ,imm-operand)))
(when (typep immediate ',imm-type)
(encoded-result :opcode ,opcode
:immediate (encode-integer immediate ',imm-type)
+ :operand-size operator-mode
:rex default-rex
, at extras)))))
@@ -597,29 +629,29 @@
(return-from operator
(merge-encodings (encoded-values :opcode ,opcode
:reg ,digit
- :operand-size (when (eq operator-mode :16-bit)
- :16-bit)
+ :operand-size operator-mode
:rex default-rex
:immediate (encode-integer immediate ',type))
(encode-reg/mem ,op-modrm operator-mode)))))))
-(defmacro pc-rel (opcode operand type)
- `(let ((offset (encode-pc-relative ,operand ',type)))
- (when offset
+(defmacro pc-rel (opcode operand type &rest extras)
+ `(let ((offset (resolve-pc-relative ,operand)))
+ (when (typep offset ',type)
(return-from operator
(encoded-values :opcode ,opcode
- :displacement offset)))))
+ :displacement (encode-integer offset ',type)
+ , at extras)))))
(defmacro modrm (operand opcode digit)
- `(return-from operator
- (merge-encodings (encoded-values :opcode ,opcode
- :reg ,digit
- :operand-size (when (eq operator-mode :16-bit)
- :16-bit)
- :rex default-rex)
- (encode-reg/mem ,operand operator-mode))))
+ `(when (typep ,operand '(or register-operand indirect-operand))
+ (return-from operator
+ (merge-encodings (encoded-values :opcode ,opcode
+ :reg ,digit
+ :operand-size operator-mode
+ :rex default-rex)
+ (encode-reg/mem ,operand operator-mode)))))
-(defmacro reg-modrm (op-reg op-modrm opcode)
+(defmacro reg-modrm (op-reg op-modrm opcode &rest extras)
`(let* ((reg-map (ecase operator-mode
(:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh))
(:16-bit '(:ax :cx :dx :bx :sp :bp :si :di))
@@ -632,9 +664,9 @@
(return-from operator
(merge-encodings (encoded-values :opcode ,opcode
:reg reg-index
- :operand-size (case operator-mode
- (:16-bit :16-bit))
- :rex default-rex)
+ :operand-size operator-mode
+ :rex default-rex
+ , at extras)
(encode-reg/mem ,op-modrm operator-mode))))))
(defmacro sreg-modrm (op-sreg op-modrm opcode)
@@ -659,6 +691,17 @@
:key #'resolve)
',type)))))))
+(defmacro opcode (opcode &rest extras)
+ `(return-from operator
+ (encoded-values :opcode ,opcode
+ , at extras
+ :operand-size operator-mode)))
+
+(defmacro opcode* (opcode &rest extras)
+ `(return-from operator
+ (encoded-values :opcode ,opcode
+ , at extras)))
+
(defmacro opcode-reg (opcode op-reg)
`(let* ((reg-map (ecase operator-mode
(:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh))
@@ -704,19 +747,22 @@
;;;;;;;;;;;;;;;;
-(define-simple :nop #x90)
+(define-operator :nop ()
+ (opcode #x90))
;;;;;;;;;;; ADC
(define-operator/8 :adcb (src dst)
- (imm src (eq dst :al) #x14 (xint 8))
+ (when (eq dst :al)
+ (imm src #x14 (xint 8)))
(imm-modrm src dst #x80 2 (xint 8))
(reg-modrm dst src #x12)
(reg-modrm src dst #x10))
(define-operator* (:16 :adcw :32 :adcl :64 :adcr) (src dst)
(imm-modrm src dst #x83 2 (sint 8))
- (imm src (eq dst :ax-eax-rax) #x15 :int-16-32-64)
+ (when (eq dst :ax-eax-rax)
+ (imm src #x15 :int-16-32-64))
(imm-modrm src dst #x81 2 :int-16-32-64)
(reg-modrm dst src #x13)
(reg-modrm src dst #x11))
@@ -724,14 +770,16 @@
;;;;;;;;;;; ADD
(define-operator/8 :addb (src dst)
- (imm src (eq dst :al) #x04 (xint 8))
+ (when (eq dst :al)
+ (imm src #x04 (xint 8)))
(imm-modrm src dst #x80 0 (xint 8))
(reg-modrm dst src #x02)
(reg-modrm src dst #x00))
(define-operator* (:16 :addw :32 :addl :64 :addr) (src dst)
(imm-modrm src dst #x83 0 (sint 8))
- (imm src (eq dst :ax-eax-rax) #x05 :int-16-32-64)
+ (when (eq dst :ax-eax-rax)
+ (imm src #x05 :int-16-32-64))
(imm-modrm src dst #x81 0 :int-16-32-64)
(reg-modrm dst src #x03)
(reg-modrm src dst #x01))
@@ -739,14 +787,16 @@
;;;;;;;;;;; AND
(define-operator/8 :andb (mask dst)
- (imm mask (eq dst :al) #x24 (xint 8))
+ (when (eq dst :al)
+ (imm mask #x24 (xint 8)))
(imm-modrm mask dst #x80 4 (xint 8))
(reg-modrm dst mask #x22)
(reg-modrm mask dst #x20))
(define-operator* (:16 :andw :32 :andl :64 :andr) (mask dst)
(imm-modrm mask dst #x83 4 (sint 8))
- (imm mask (eq dst :ax-eax-rax) #x25 :int-16-32-64)
+ (when (eq dst :ax-eax-rax)
+ (imm mask #x25 :int-16-32-64))
(imm-modrm mask dst #x81 4 :int-16-32-64)
(reg-modrm dst mask #x23)
(reg-modrm mask dst #x21))
@@ -798,11 +848,11 @@
;;;;;;;;;;; CLC, CLD, CLI, CLTS, CMC
-(define-simple :clc #xf8)
-(define-simple :cld #xfc)
-(define-simple :cli #xfa)
-(define-simple :clts #x0f06)
-(define-simple :cmc #xf5)
+(define-operator :clc () (opcode #xf8))
+(define-operator :cld () (opcode #xfc))
+(define-operator :cli () (opcode #xfa))
+(define-operator :clts () (opcode #x0f06))
+(define-operator :cmc () (opcode #xf5))
;;;;;;;;;;; CMOVcc
@@ -890,14 +940,16 @@
;;;;;;;;;;; CMP
(define-operator/8 :cmpb (src dst)
- (imm src (eq dst :al) #x3c (xint 8))
+ (when (eq dst :al)
+ (imm src #x3c (xint 8)))
(imm-modrm src dst #x80 7 (xint 8))
(reg-modrm dst src #x3a)
(reg-modrm src dst #x38))
(define-operator* (:16 :cmpw :32 :cmpl :64 :cmpr) (src dst)
(imm-modrm src dst #x83 7 (sint 8))
- (imm src (eq dst :ax-eax-rax) #x3d :int-16-32-64)
+ (when (eq dst :ax-eax-rax)
+ (imm src #x3d :int-16-32-64))
(imm-modrm src dst #x81 7 :int-16-32-64)
(reg-modrm dst src #x3b)
(reg-modrm src dst #x39))
@@ -962,6 +1014,234 @@
(when (eq al-dst :ax-eax-rax)
(reg-modrm cmp-reg cmp-modrm #x0fb1)))
[256 lines skipped]
More information about the Movitz-cvs
mailing list