[movitz-cvs] CVS movitz
ffjeld
ffjeld at common-lisp.net
Mon Feb 4 21:03:40 UTC 2008
Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv32467
Modified Files:
asm-x86.lisp
Log Message:
Various bits and pieces, movitz now compiles (but won't boot).
--- /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 12:11:00 1.16
+++ /project/movitz/cvsroot/movitz/asm-x86.lisp 2008/02/04 21:03:35 1.17
@@ -6,7 +6,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: asm-x86.lisp,v 1.16 2008/02/04 12:11:00 ffjeld Exp $
+;;;; $Id: asm-x86.lisp,v 1.17 2008/02/04 21:03:35 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -182,19 +182,28 @@
address-size))
(defun encode-instruction (instruction)
- (multiple-value-bind (legacy-prefixes instruction)
+ (multiple-value-bind (instruction legacy-prefixes options)
(if (listp (car instruction))
- (values (car instruction)
- (cdr instruction))
- (values nil
- instruction))
+ (values (cdr instruction)
+ (remove-if #'listp (car instruction))
+ (remove-if #'keywordp (car instruction)))
+ (values instruction
+ nil
+ nil))
(destructuring-bind (operator &rest operands)
instruction
- (apply (or (gethash operator *instruction-encoders*)
- (error "Unknown instruction operator ~S in ~S." operator instruction))
- operator
- (mapcar #'prefix-lookup legacy-prefixes)
- operands))))
+ (let ((code (apply (or (gethash operator *instruction-encoders*)
+ (error "Unknown instruction operator ~S in ~S." operator instruction))
+ operator
+ (mapcar #'prefix-lookup legacy-prefixes)
+ operands)))
+ (cond
+ ((null options)
+ code)
+ ((assoc :size options)
+ (assert (= (second (assoc :size options))
+ (length code)))
+ code))))))
(defmacro define-operator (operator lambda-list &body body)
@@ -202,7 +211,7 @@
(let ((defun-name (intern (format nil "~A-~A" 'instruction-encoder operator))))
`(progn
(defun ,defun-name (operator legacy-prefixes , at lambda-list)
- (declare (ignorable operator))
+ (declare (ignorable operator legacy-prefixes))
(let ((operator-mode nil)
(default-rex nil))
(declare (ignorable operator-mode default-rex))
@@ -281,16 +290,6 @@
,(when |64|
`(define-operator/64 ,|64| ,args , at body64)))))
-(defun resolve (x)
- (etypecase x
- (integer
- x)
- (symbol-reference
- (let ((s (symbol-reference-symbol x)))
- (loop (with-simple-restart (retry-symbol-resolve "Retry resolving ~S." s)
- (return (cdr (or (assoc s *symtab*)
- (error 'unresolved-symbol
- :symbol s))))))))))
(defun resolve-and-encode (x type &key size)
(encode-integer (cond
@@ -309,9 +308,9 @@
(etypecase operand
((cons (eql :pc+))
(reduce #'+ (cdr operand)
- :key #'resolve))
+ :key #'resolve-operand))
(symbol-reference
- (- (resolve operand)
+ (- (resolve-operand operand)
*pc*))))
(defun encode-integer (i type)
@@ -382,7 +381,7 @@
(assert (or (not reg-scale)
(and reg reg-scale)))
(let ((offset (reduce #'+ offsets
- :key #'resolve)))
+ :key #'resolve-operand)))
(cond
((and (not reg)
(eq mode :16-bit)
@@ -631,7 +630,7 @@
(defmacro imm (imm-operand opcode imm-type &rest extras)
`(when (immediate-p ,imm-operand)
- (let ((immediate (resolve ,imm-operand)))
+ (let ((immediate (resolve-operand ,imm-operand)))
(when (typep immediate ',imm-type)
(return-values-when
(encoded-values :opcode ,opcode
@@ -642,7 +641,7 @@
(defmacro imm-modrm (op-imm op-modrm opcode digit type)
`(when (immediate-p ,op-imm)
- (let ((immediate (resolve ,op-imm)))
+ (let ((immediate (resolve-operand ,op-imm)))
(when (typep immediate ',type)
(return-values-when
(merge-encodings (encoded-values :opcode ,opcode
@@ -764,7 +763,7 @@
(return-values-when
(encoded-values :opcode ,opcode
:displacement (encode-integer (reduce #'+ offsets
- :key #'resolve)
+ :key #'resolve-operand)
',type)))))))
(defmacro opcode (opcode &rest extras)
@@ -802,7 +801,7 @@
(defun encode-opcode-reg-imm (operator legacy-prefixes opcode op-reg op-imm type operator-mode default-rex)
(when (immediate-p op-imm)
- (let ((immediate (resolve op-imm)))
+ (let ((immediate (resolve-operand op-imm)))
(when (typep immediate type)
(let* ((reg-map (ecase operator-mode
(:8-bit '(:al :cl :dl :bl :ah :ch :dh :bh))
@@ -827,10 +826,20 @@
(encode-opcode-reg-imm operator legacy-prefixes ,opcode ,op-reg ,op-imm ',type operator-mode default-rex)))
-;;;;;;;;;;;;;;;;
+;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;; NOP
+
+(define-operator :% (op &rest data)
+ (case op
+ (:bytes
+ (let ((byte-size (pop data)))
+ (return-from operator
+ (loop for datum in data
+ append (loop for b from 0 below byte-size by 8
+ collect (ldb (byte 8 b)
+ datum))))))))
-(define-operator :nop ()
- (opcode #x90))
;;;;;;;;;;; ADC
@@ -928,6 +937,9 @@
(define-operator/32 :callr (dest)
(modrm dest #xff 2))
+(define-operator :call-segment (dest)
+ (modrm dest #xff 3))
+
;;;;;;;;;;; CLC, CLD, CLI, CLTS, CMC
(define-operator :clc () (opcode #xf8))
@@ -1254,6 +1266,9 @@
(indirect-operand-p dst))
(modrm dst #xff 4)))
+(define-operator* (:16 :jmpw-segment :32 :jmp-segment :64 :jmpr-segment) (addr)
+ (modrm addr #xff 5))
+
;;;;;;;;;;; LAHF, LAR
(define-operator :lahf ()
@@ -1267,6 +1282,9 @@
;;;;;;;;;;; LEA
(define-operator* (:16 :leaw :32 :leal :64 :lear) (addr dst)
+ (when (and (equal addr '(:esp :edx)) ; REMOVEME: ia-x86 compat. hack!!
+ (eq dst :esp))
+ (return-from operator '(#x8D #x64 #x14 #x00)))
(reg-modrm dst addr #x8d))
;;;;;;;;;;; LEAVE
@@ -1276,10 +1294,10 @@
;;;;;;;;;;; LGDT, LIDT
-(define-operator* (:16 :lgdtw :32 :lgdtl :64 :lgdtr) (addr)
+(define-operator* (:16 :lgdtw :32 :lgdt :64 :lgdtr) (addr)
(modrm addr #x0f01 2))
-(define-operator* (:16 :lidtw :32 :lidtl :64 :lidtr) (addr)
+(define-operator* (:16 :lidtw :32 :lidt :64 :lidtr) (addr)
(modrm addr #x0f01 3))
;;;;;;;;;;; LFENCE
@@ -1373,6 +1391,11 @@
(define-operator* (:16 :negw :32 :negl :64 :negr) (dst)
(modrm dst #xf7 3))
+;;;;;;;;;;;;;;;; NOP
+
+(define-operator :nop ()
+ (opcode #x90))
+
;;;;;;;;;;; NOT
(define-operator/8 :notb (dst)
@@ -1527,6 +1550,11 @@
(reg-modrm dst subtrahend #x1b)
(reg-modrm subtrahend dst #x19))
+;;;;;;;;;;; SGDT
+
+(define-operator/8 :sgdt (addr)
+ (modrm addr #x0f01 0))
+
;;;;;;;;;;; SHL
(define-operator/8 :shlb (count dst)
@@ -1547,7 +1575,7 @@
(when (eq :cl count)
(reg-modrm dst1 dst2 #x0fa5))
(when (immediate-p count)
- (let ((immediate (resolve count)))
+ (let ((immediate (resolve-operand count)))
(when (typep immediate '(uint #x8))
(reg-modrm dst1 dst2 #x0fa4
:immediate (encode-integer count '(uint 8)))))))
@@ -1572,7 +1600,7 @@
(when (eq :cl count)
(reg-modrm dst1 dst2 #x0fad))
(when (immediate-p count)
- (let ((immediate (resolve count)))
+ (let ((immediate (resolve-operand count)))
(when (typep immediate '(uint #x8))
(reg-modrm dst1 dst2 #x0fac
:immediate (encode-integer count '(uint 8)))))))
@@ -1620,6 +1648,10 @@
(imm-modrm mask dst #xf7 0 :int-16-32-64)
(reg-modrm mask dst #x85))
+;;;;;;;;;;; XCHG
+
+(define-operator :wrmsr ()
+ (opcode #x0f30))
;;;;;;;;;;; XCHG
More information about the Movitz-cvs
mailing list