Update of /project/movitz/cvsroot/ia-x86
In directory common-lisp.net:/tmp/cvs-serv12156
Modified Files:
codec.lisp
Log Message:
Added a protocol for adding "extra" prefixes (such as NOPs) to
instructions as they are inserted in a code-stream. This is needed for
Movitz to be able to align call instructions such that
return-addresses are distinguisable from immediate values, which is
required by stack discipline.
Date: Thu Sep 2 11:01:20 2004
Author: ffjeld
Index: ia-x86/codec.lisp
diff -u ia-x86/codec.lisp:1.5 ia-x86/codec.lisp:1.6
--- ia-x86/codec.lisp:1.5 Tue Feb 10 01:03:14 2004
+++ ia-x86/codec.lisp Thu Sep 2 11:01:19 2004
@@ -1,15 +1,15 @@
;;;;------------------------------------------------------------------
;;;;
-;;;; Copyright (C) 20012000, 2002, 2004,
+;;;; Copyright (C) 2000, 2001, 2002, 2004,
;;;; Department of Computer Science, University of Tromso, Norway
;;;;
;;;; Filename: codec.lisp
-;;;; Description:
+;;;; Description: Encoding and decoding of instructions to/from binary.
;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
;;;; Created at: Thu May 4 15:16:45 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: codec.lisp,v 1.5 2004/02/10 00:03:14 ffjeld Exp $
+;;;; $Id: codec.lisp,v 1.6 2004/09/02 09:01:19 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -428,9 +428,11 @@
-(defun template-instr-and-prefix-length (template instr)
+(defun template-instr-and-prefix-length (template instr env)
(+ (template-instr-numo template)
- (length (calculate-prefixes instr template))))
+ (length (calculate-prefixes instr template))
+ (length (compute-instruction-extra-prefixes instr template env))))
+
;;; ----------------------------------------------------------------
;;; Instruction decode
@@ -454,8 +456,8 @@
(defun make-decode-instruction (datum prefixes template)
(instruction-decode (make-instance (template-instr-classname template)
- 'datum datum
- 'prefixes (set-difference prefixes
+ :datum datum
+ :prefixes (set-difference prefixes
(template-req-prefixes template)))
template))
@@ -473,18 +475,22 @@
(set-difference (instruction-prefixes instr)
(template-not-prefixes template)))))
-(defun prefix-encode (prefix-list cdatum)
+(defun prefix-encode (cdatum prefix-list &optional extra-prefixes)
"Given an instruction encoded into <cdatum> by <template>,
append the necessary prefix-bytes to cdatum."
(let ((new-byte (realpart cdatum))
(byte-pos (imagpart cdatum)))
(loop for prefix in prefix-list
- do (progn
- (setf (ldb (byte 8 (* 8 byte-pos))
- new-byte)
+ do (setf (ldb (byte 8 (* 8 byte-pos))
+ new-byte)
(decode-set +prefix-opcode-map+
prefix))
- (incf byte-pos)))
+ (incf byte-pos))
+ (loop for prefix in extra-prefixes
+ do (setf (ldb (byte 8 (* 8 byte-pos))
+ new-byte)
+ prefix)
+ (incf byte-pos))
(complex new-byte byte-pos)))
(defun make-instr-symbolic-from-template (template)
@@ -539,8 +545,10 @@
:encoding-list (mapcar #'operand-class-encoding
(template-instr-operand-classes template))
:template template))
-
-(defun instruction-encode-from-teo (instr teo)
+
+(defvar *instruction-compute-extra-prefix-map* nil)
+
+(defun instruction-encode-from-teo (instr teo env)
(check-type instr instruction)
(let ((template (teo-template teo))
(resolved-operand-list (teo-resolved-operand-list teo))
@@ -550,9 +558,17 @@
and operand-encoding in operand-encoding-list
and operand-type in (template-instr-operand-types template)
do (operand-encode operand operand-encoding operand-type is))
- (prefix-encode (calculate-prefixes instr template)
- (encode-instr-symbolic template is)))))
-
+ (prefix-encode (encode-instr-symbolic template is)
+ (calculate-prefixes instr template)
+ (compute-instruction-extra-prefixes instr template env)))))
+
+(defun compute-instruction-extra-prefixes (instr template env)
+ (funcall (or (instruction-finalizer instr)
+ (cdr (assoc (class-name (class-of instr)) *instruction-compute-extra-prefix-map*
+ :test #'string=))
+ (constantly nil))
+ instr env (+ (template-instr-numo template)
+ (length (calculate-prefixes instr template)))))
(defun template-match-by-cpu-mode (template cpu-mode)
(or (eq :any-mode (template-cpu-mode template))
@@ -580,13 +596,16 @@
(setf chosen-teo teo))
finally (return chosen-teo)))
-(defun optimize-teo-smallest (teo-list instr)
+(defun optimize-teo-smallest (teo-list instr env)
"Prefer the smallest (as in fewest octets) encodings."
+ (declare (ignore env))
(pairwise-teopt teo-list
instr
#'(lambda (teo1 teo2 instr)
- (< (template-instr-and-prefix-length (teo-template teo1) instr)
- (template-instr-and-prefix-length (teo-template teo2) instr)))))
+ (< (+ (template-instr-numo (teo-template teo1))
+ (length (calculate-prefixes instr (teo-template teo1))))
+ (+ (template-instr-numo (teo-template teo2))
+ (length (calculate-prefixes instr (teo-template teo2))))))))
(defun template-is-16-bit-p (template)
(or (eq :16-bit (template-addressing-mode template))
@@ -594,8 +613,9 @@
(member '16-bit-operand (template-req-prefixes template))
(member '16-bit-address (template-req-prefixes template))))
-(defun optimize-teo-smallest-no16 (teo-list instr)
+(defun optimize-teo-smallest-no16 (teo-list instr env)
"Prefer the smallest 32-bit encoding."
+ (declare (ignore env))
(pairwise-teopt teo-list
instr
#'(lambda (teo1 teo2 instr)
@@ -603,40 +623,38 @@
(t2 (teo-template teo2)))
(or (and (not (template-is-16-bit-p t1))
(template-is-16-bit-p t2))
- #+ignore (and (null (intersection '(16-bit-operand 16-bit-address)
- (template-req-prefixes t1)))
- (intersection '(16-bit-operand 16-bit-address)
- (template-req-prefixes t2)))
- (< (template-instr-and-prefix-length t1 instr)
- (template-instr-and-prefix-length t2 instr)))))))
+ (< (+ (template-instr-numo t1)
+ (length (calculate-prefixes instr t1)))
+ (+ (template-instr-numo t2)
+ (length (calculate-prefixes instr t2)))))))))
-(defun optimize-teo-original-size (teo-list instr)
+(defun optimize-teo-original-size (teo-list instr env)
"Find an encoding that matches the size of the instruction's
original size (its instruction-original-datum)."
(let ((original-size (imagpart (instruction-original-datum instr))))
(find-if #'(lambda (teo)
(= original-size
- (template-instr-and-prefix-length (teo-template teo) instr)))
+ (template-instr-and-prefix-length (teo-template teo) instr env)))
teo-list)))
-(defun optimize-teo-user-size (teo-list instr)
+(defun optimize-teo-user-size (teo-list instr env)
"Find an encoding that matches the user-specified size."
(find-if #'(lambda (teo)
(= (instruction-user-size instr)
- (template-instr-and-prefix-length (teo-template teo) instr)))
+ (template-instr-and-prefix-length (teo-template teo) instr env)))
teo-list))
-(defun instruction-encode (instr &optional env (optimize-teo-fn #'optimize-teo-smallest))
+(defun instruction-encode (instr env &optional (optimize-teo-fn #'optimize-teo-smallest))
(let ((teo-list (instruction-encode-to-teo instr env)))
(if (null teo-list)
(error "Unable to encode ~A." instr)
(let ((teo (if (instruction-user-size instr)
- (optimize-teo-user-size teo-list instr)
- (funcall optimize-teo-fn teo-list instr))))
+ (optimize-teo-user-size teo-list instr env)
+ (funcall optimize-teo-fn teo-list instr env))))
(if (not (teo-p teo))
(error "Optimization with ~S of instruction ~S failed for teo-list ~S"
optimize-teo-fn instr teo-list)
- (instruction-encode-from-teo instr teo))))))
+ (instruction-encode-from-teo instr teo env))))))
;;;
