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

Improve disassemble-proglist etc.

parent 275595c2
......@@ -6,7 +6,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: asm-x86.lisp,v 1.27 2008/02/16 23:15:04 ffjeld Exp $
;;;; $Id: asm-x86.lisp,v 1.28 2008/02/18 20:57:14 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -445,7 +445,7 @@
(defun resolve-pc-relative (operand)
(etypecase operand
((cons (eql :pc+))
(pc-relative-operand
(reduce #'+ (cdr operand)
:key #'resolve-operand))
(symbol-reference
......@@ -772,9 +772,12 @@
(error "No operand ~S in ~S." key operands))))
(defmacro pop-code (code-place &optional context)
`(let ((x (pop ,code-place)))
`(progn
(unless ,code-place
(error "End of byte-stream in the middle of an instruction."))
(let ((x (pop ,code-place)))
(check-type x (unsigned-byte 8) ,(format nil "an octet (context: ~A)" context))
x))
x)))
(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."
......
......@@ -6,7 +6,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: asm.lisp,v 1.12 2008/02/09 09:50:46 ffjeld Exp $
;;;; $Id: asm.lisp,v 1.13 2008/02/16 19:14:06 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -25,6 +25,7 @@
#:retry-symbol-resolve
#:pc-relative-operand
#:assemble-proglist
#:disassemble-proglist
#:*pc*
#:*symtab*
#:*instruction-compute-extra-prefix-map*
......@@ -117,6 +118,10 @@
(defun pc-relative-operand-p (operand)
(typep operand 'pc-relative-operand))
(defun pc-relative-operand-offset (operand)
(check-type operand pc-relative-operand)
(second operand))
(define-condition unresolved-symbol ()
((symbol
:initarg :symbol
......@@ -229,14 +234,40 @@
:corrections (nconc new-corrections corrections)))
(t (values code *symtab*))))))))
(defun disassemble-proglist (code &key (cpu-package '#:asm-x86))
(let ((instruction-disassembler (find-symbol (string '#:disassemble-instruction)
cpu-package)))
(loop while code
collect (multiple-value-bind (instruction new-code)
(funcall instruction-disassembler
code)
(when (eq code new-code)
(loop-finish))
(setf code new-code)
instruction))))
(defun instruction-operands (instruction)
(if (listp (car instruction)) ; skip any instruction prefixes etc.
(cddr instruction)
(cdr instruction)))
(defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*))
(let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction)
cpu-package))
(proglist0 (loop while code
collect pc
collect (multiple-value-bind (instruction new-code)
(funcall instruction-disassembler
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)
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