Commit 790cc3f6 authored by Frode Vatvedt Fjeld's avatar Frode Vatvedt Fjeld

Various bits and pieces, movitz now compiles (but won't boot).

parent 2949b5ee
......@@ -6,7 +6,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: asm-x86.lisp,v 1.15 2008/02/04 11:48:27 ffjeld Exp $
;;;; $Id: asm-x86.lisp,v 1.16 2008/02/04 12:11:00 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 ,@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 ,@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
......
......@@ -6,7 +6,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: asm.lisp,v 1.8 2008/02/04 08:33:39 ffjeld Exp $
;;;; $Id: asm.lisp,v 1.9 2008/02/04 12:00:36 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -20,6 +20,7 @@
#:indirect-operand-p
#:indirect-operand
#:register-operand
#:resolve-operand
#:unresolved-symbol
#:retry-symbol-resolve
#:pc-relative-operand
......@@ -36,20 +37,32 @@
(defvar *symtab* nil "Current symbol table.")
(defvar *instruction-compute-extra-prefix-map* nil)
(defvar *position-independent-p* t)
(defvar *sub-program-instructions* '(:jmp :ret)
(defvar *sub-program-instructions* '(:jmp :ret :iretd)
"Instruction operators after which to insert sub-programs.")
(defvar *anonymous-sub-program-identities* nil)
(defun quotep (x)
"Is x a symbol (in any package) named 'quote'?"
;; This is required because of Movitz package-fiddling.
(and (symbolp x)
(string= x 'quote)))
(deftype simple-symbol-reference ()
'(cons (eql quote) (cons symbol null)))
'(cons (satisfies quotep) (cons symbol null)))
(deftype sub-program-operand ()
'(cons (eql quote)
'(cons (satisfies quotep)
(cons
(cons (eql :sub-program))
null)))
(deftype funcall-operand ()
'(cons (satisfies quotep)
(cons
(cons (eql :funcall))
null)))
(deftype symbol-reference ()
'(or simple-symbol-reference sub-program-operand))
......@@ -64,7 +77,6 @@
(car (push (cons operand (gensym "sub-program-"))
*anonymous-sub-program-identities*)))))))
(defun sub-program-program (operand)
(cddadr operand))
......@@ -75,8 +87,14 @@
(sub-program-operand
(sub-program-label expr))))
(defun funcall-operand-operator (operand)
(cadadr operand))
(defun funcall-operand-operands (operand)
(cddadr operand))
(deftype immediate-operand ()
'(or integer symbol-reference))
'(or integer symbol-reference funcall-operand))
(defun immediate-p (expr)
(typep expr 'immediate-operand))
......@@ -88,7 +106,7 @@
(typep operand 'register-operand))
(deftype indirect-operand ()
'(and cons (not (cons (eql quote)))))
'(and cons (not (cons (satisfies quotep)))))
(defun indirect-operand-p (operand)
(typep operand 'indirect-operand))
......@@ -107,6 +125,21 @@
(format s "Unresolved symbol ~S." (unresolved-symbol c)))))
(defun resolve-operand (operand)
(etypecase operand
(integer
operand)
(symbol-reference
(let ((s (symbol-reference-symbol operand)))
(loop (with-simple-restart (retry-symbol-resolve "Retry resolving ~S." s)
(return (cdr (or (assoc s *symtab*)
(error 'unresolved-symbol
:symbol s))))))))
(funcall-operand
(apply (funcall-operand-operator operand)
(mapcar #'resolve-operand
(funcall-operand-operands operand))))))
;;;;;;;;;;;;
......@@ -121,7 +154,7 @@
(sub-programs nil))
(flet ((process-instruction (instruction)
(etypecase instruction
(symbol
((or symbol integer)
(let ((previous-definition (assoc instruction *symtab*)))
(cond
((null previous-definition)
......@@ -139,24 +172,24 @@
((member previous-definition corrections)
(cond
((> *pc* (cdr previous-definition))
;; (warn "correcting ~S from ~D to ~D" instruction (cdr previous-definition) *pc*)
;; (warn "correcting ~S from ~D to ~D" instruction (cdr previous-definition) *pc*)
(setf (cdr previous-definition) *pc*)
(push previous-definition new-corrections))
((< *pc* (cdr previous-definition))
;; (warn "Definition for ~S shrunk from ~S to ~S (corrections: ~{~D~}."
;; instruction
;; (cdr previous-definition)
;; *pc*
;; corrections)
;; (warn "prg: ~{~%~A~}" proglist)
;; (warn "Definition for ~S shrunk from ~S to ~S."
;; instruction
;; (cdr previous-definition)
;; *pc*)
;; (break "Definition for ~S shrunk from ~S to ~S."
;; instruction
;; (cdr previous-definition)
;; *pc*)
;; (warn "Definition for ~S shrunk from ~S to ~S (corrections: ~{~D~}."
;; instruction
;; (cdr previous-definition)
;; *pc*
;; corrections)
;; (warn "prg: ~{~%~A~}" proglist)
;; (warn "Definition for ~S shrunk from ~S to ~S."
;; instruction
;; (cdr previous-definition)
;; *pc*)
;; (break "Definition for ~S shrunk from ~S to ~S."
;; instruction
;; (cdr previous-definition)
;; *pc*)
(setf (cdr previous-definition) *pc*)
(push previous-definition new-corrections))))
(t (error "Label ~S doubly defined. Old value: ~S, new value: ~S"
......@@ -168,7 +201,7 @@
(let ((code (handler-bind
((unresolved-symbol (lambda (c)
(let ((a (cons (unresolved-symbol c) *pc*)))
;; (warn "assuming ~S for ~S" (unresolved-symbol c) *pc*)
;; (warn "assuming ~S for ~S" (unresolved-symbol c) *pc*)
(push a assumptions)
(push a *symtab*)
(invoke-restart 'retry-symbol-resolve)))))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment