[movitz-cvs] CVS movitz

[ffjeld]

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv31315

Modified Files:
	asm.lisp 
Log Message:
Improve disassemble-proglist etc.


--- /project/movitz/cvsroot/movitz/asm.lisp	2008/02/16 19:14:06	1.13
+++ /project/movitz/cvsroot/movitz/asm.lisp	2008/02/18 22:30:45	1.14
@@ -6,7 +6,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at 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 $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -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)))