Commit cb5853ec authored by Frode Vatvedt Fjeld's avatar Frode Vatvedt Fjeld

Finishing touches on the disassembler.

parent db9c25ef
......@@ -6,7 +6,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: asm-x86.lisp,v 1.28 2008/02/18 20:57:14 ffjeld Exp $
;;;; $Id: asm-x86.lisp,v 1.29 2008/02/18 22:30:47 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -278,7 +278,7 @@
(make-array 256 :initial-element nil))
(deftype disassembly-decoder ()
'(list-of* keyword (or keyword null) symbol))
'(list-of* boolean keyword (or keyword null) symbol))
(defun (setf opcode-disassembler) (decoder opcode operator-mode)
(check-type decoder disassembly-decoder)
......@@ -312,22 +312,22 @@
(defmacro define-disassembler ((operator opcode &optional cpu-mode (digit nil digit-p)) lambda-list &body body)
(defmacro define-disassembler ((operator opcode &optional cpu-mode digit backup-p) lambda-list &body body)
(cond
(digit-p
(digit
`(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 ,@body))))
do (define-disassembler (,operator ext-opcode ,cpu-mode nil t) ,lambda-list ,@body))))
((symbolp lambda-list)
`(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,operator ,cpu-mode ',lambda-list ,@body)))
`(setf (opcode-disassembler ,opcode ,cpu-mode) (list ,backup-p ,operator ,cpu-mode ',lambda-list ,@body)))
(t (let ((defun-name (intern (format nil "~A-~A-~X~@[-~A~]" 'disassembler operator opcode cpu-mode))))
`(progn
(defun ,defun-name ,lambda-list ,@body)
(setf (opcode-disassembler ,opcode ',cpu-mode) (list ,operator ',cpu-mode ',defun-name))
(setf (opcode-disassembler ,opcode ',cpu-mode) (list ,backup-p ,operator ',cpu-mode ',defun-name))
',defun-name)))))
(defun disassemble-simple-prefix (code operator opcode operand-size address-size rex)
......@@ -799,15 +799,18 @@
(defun disassemble-instruction (code &optional override-operand-size override-address-size rex)
(labels ((lookup-decoder (table opcode)
(let* ((datum (pop-code code))
(let* ((backup-code code)
(datum (pop-code code))
(opcode (logior (ash opcode 8)
datum))
(decoder (svref table datum)))
(typecase decoder
((simple-vector 256)
(vector
(lookup-decoder decoder opcode))
(disassembly-decoder
(values decoder
(when (car decoder)
(setf code backup-code))
(values (cdr decoder)
opcode))
(t (error "No disassembler registered for opcode #x~X." opcode))))))
(multiple-value-bind (decoder opcode)
......@@ -1384,14 +1387,13 @@
;;;;;;;;;;; CALL
(define-operator* (:16 :callw :32 :calll :64 :callr :dispatch :call) (dest)
(case *cpu-mode*
(:16-bit
(pc-rel #xe8 dest (sint 16)))
(:32-bit
(pc-rel #xe8 dest (sint 32))))
(when (eq operator-mode *cpu-mode*)
(modrm dest #xff 2)))
(define-operator/16 :callw (dest)
(pc-rel #xe8 dest (sint 16))
(modrm dest #xff 2))
(define-operator/32 :call (dest)
(pc-rel #xe8 dest (sint 32))
(modrm dest #xff 2))
(define-operator/none :call-segment (dest)
(modrm dest #xff 3))
......@@ -1879,11 +1881,6 @@
(define-operator* (:16 :negw :32 :negl :64 :negr) (dst)
(modrm dst #xf7 3))
;;;;;;;;;;;;;;;; NOP
(define-operator/none :nop ()
(opcode #x90))
;;;;;;;;;;; NOT
(define-operator/8 :notb (dst)
......@@ -2162,3 +2159,9 @@
(imm-modrm src dst #x81 6 :int-16-32-64)
(reg-modrm dst src #x33)
(reg-modrm src dst #x31))
;;;;;;;;;;;;;;;; NOP
(define-operator/none :nop ()
(opcode #x90))
......@@ -6,7 +6,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: asm.lisp,v 1.13 2008/02/16 19:14:06 ffjeld Exp $
;;;; $Id: asm.lisp,v 1.14 2008/02/18 22:30:45 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -234,13 +234,22 @@
:corrections (nconc new-corrections corrections)))
(t (values code *symtab*))))))))
(defun instruction-operator (instruction)
(if (listp (car instruction)) ; skip any instruction prefixes etc.
(cadr instruction)
(car instruction)))
(defun instruction-operands (instruction)
(if (listp (car instruction)) ; skip any instruction prefixes etc.
(cddr instruction)
(cdr instruction)))
(defun instruction-modifiers (instruction)
(if (listp (car instruction))
(car instruction)
nil))
(defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*))
(defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*) collect-data collect-labels)
(let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction)
cpu-package))
(proglist0 (loop while code
......@@ -250,24 +259,33 @@
code)
(when (eq code new-code)
(loop-finish))
(loop until (eq code new-code)
do (incf pc)
(setf code (cdr code)))
(let ((operands (instruction-operands instruction)))
(if (notany #'pc-relative-operand-p operands)
instruction
(nconc (loop until (eq instruction operands)
collect (pop instruction))
(loop for operand in operands
collect (if (not (pc-relative-operand-p operand))
operand
(let* ((location (+ pc (pc-relative-operand-offset operand)))
(entry (or (rassoc location symtab)
(car (push (cons (gensym) location)
symtab)))))
`(quote ,(car entry))))))))))))
(values (loop for (pc instruction) on proglist0 by #'cddr
when (car (rassoc pc symtab))
collect it
collect instruction)
(let* ((data (loop until (eq code new-code)
do (incf pc)
collect (pop code)))
(operands (instruction-operands instruction)))
;; (format *debug-io* "~D: ~X ~S~%" pc data instruction)
(cons data
(if (notany #'pc-relative-operand-p operands)
instruction
(nconc (loop until (eq instruction operands)
collect (pop instruction))
(loop for operand in operands
collect (if (not (pc-relative-operand-p operand))
operand
(let* ((location (+ pc (pc-relative-operand-offset operand)))
(entry (or (rassoc location symtab)
(car (push (cons (gensym) location)
symtab)))))
`(quote ,(car entry)))))))))))))
(values (loop for (pc data-instruction) on proglist0 by #'cddr
for (data . instruction) = data-instruction
for label = (when collect-labels
(rassoc pc symtab))
when label
collect (if (not collect-data)
(car label)
(cons nil (car label)))
collect (if (not collect-data)
instruction
data-instruction))
symtab)))
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