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@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))))))
;;;