Commit 4a3d2a3a authored by Frode Vatvedt Fjeld's avatar Frode Vatvedt Fjeld

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.
parent 5dfd694a
;;;;------------------------------------------------------------------
;;;;
;;;; 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.4 2004/02/08 22:38:35 ffjeld Exp $
;;;; $Id: codec.lisp,v 1.5 2004/02/10 00:03:14 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -428,9 +428,11 @@ templates, return the subset of the templates that are still eligible matches."
(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 @@ templates, return the subset of the templates that are still eligible matches."
(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 @@ templates, return the subset of the templates that are still eligible matches."
(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))
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)
......@@ -540,7 +546,9 @@ a teo for encoding later."
(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 @@ a teo for encoding later."
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 @@ a teo for encoding later."
(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 @@ a teo for encoding later."
(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 @@ a teo for encoding later."
(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)))))))
(defun optimize-teo-original-size (teo-list 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 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))))))
;;;
......
......@@ -9,7 +9,7 @@
;;;; Created at: Fri Dec 17 18:01:26 1999
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: ia-x86.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $
;;;; $Id: ia-x86.lisp,v 1.3 2004/02/10 00:03:23 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -23,18 +23,22 @@
((operands
:type list
:initform '()
:initarg operands
:initarg :operands
:accessor instruction-operands)
(prefixes
:type list
:initarg prefixes
:initarg :prefixes
:initform '()
:accessor instruction-prefixes)
(user-size
:initarg user-size
:initarg :user-size
:reader instruction-user-size)
(user-finalizer
:initarg :user-finalizer
:initform nil
:reader instruction-finalizer)
(original-datum
:initarg datum
:initarg :datum
:accessor instruction-original-datum)))
(defmethod print-object ((obj instruction) stream)
......
......@@ -9,7 +9,7 @@
;;;; Created at: Wed Feb 16 14:02:57 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: operands.lisp,v 1.3 2004/02/09 23:46:23 ffjeld Exp $
;;;; $Id: operands.lisp,v 1.4 2004/02/10 00:03:42 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -137,7 +137,7 @@ operands at encoding-time."))
(defun abstract-operand-to-offset (operand template instr env)
(sign-extend (mod (- (operand-resolve-to-number operand env)
(assemble-env-current-pc env)
(template-instr-and-prefix-length template instr))
(template-instr-and-prefix-length template instr env))
#x100000000)
4))
......
;;;;------------------------------------------------------------------
;;;;
;;;; Copyright (C) 20012000, 2002-2004,
;;;; Copyright (C) 2000-2004,
;;;; Department of Computer Science, University of Tromso, Norway
;;;;
;;;; Filename: packages.lisp
......@@ -9,7 +9,7 @@
;;;; Created at: Wed Feb 16 14:02:57 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: packages.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $
;;;; $Id: packages.lisp,v 1.3 2004/02/10 00:03:47 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -20,6 +20,7 @@
(:export
#:init-instruction-tables
#:*cpu-mode*
#:*instruction-compute-extra-prefix-map*
#:decode-sub-stream
#:decode-read-octet
#:decode
......
......@@ -9,7 +9,7 @@
;;;; Created at: Mon May 15 13:43:55 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: proglist.lisp,v 1.3 2004/02/10 00:04:04 ffjeld Exp $
;;;; $Id: proglist.lisp,v 1.4 2004/08/10 10:12:52 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -100,19 +100,21 @@
(make-assemble-env :symtab (assemble-env-symtab env)
:current-pc referring-pc)
optimize-teo)))
#+ignore
(when (< (imagpart cdatum) assumed-length)
(warn "Assumption ~D bigger than actual ~D" assumed-length (imagpart cdatum))
(setf cdatum
(instruction-encode instruction
(make-assemble-env :symtab (assemble-env-symtab env)
:current-pc referring-pc)
#'(lambda (teo-list instr)
(find-if #'(lambda (teo)
#'(lambda (teo-list instr env)
(or (find-if #'(lambda (teo)
(= assumed-length
(template-instr-and-prefix-length
(teo-template teo)
instr)))
teo-list)))))
instr env)))
teo-list)
(error "Unable to find encoding matching size ~D for ~S"
assumed-length instr))))))
(unless (= (imagpart cdatum) assumed-length)
(error 'assumption-failed
'forward-reference fwd-to-resolve
......@@ -144,7 +146,7 @@
(cdr placeholder-cons) (cdr cdatums)))))
(defun guess-next-instruction-length (expr missing-labels program-rest)
(defun guess-next-instruction-length (expr missing-labels program-rest env)
(declare (special *proglist-minimum-expr-size*))
;; (let ((minimum-size (max previous-length (gethash expr *proglist-minimum-expr-size*))))
(or (instruction-user-size expr)
......@@ -169,7 +171,7 @@
(t (loop with guesses = nil
for template in (templates-lookup-by-class-name (type-of expr))
when (template-match-by-operand-classes template (instruction-operands expr))
do (let ((l (template-instr-and-prefix-length template expr)))
do (let ((l (template-instr-and-prefix-length template expr env)))
(unless (member l guesses)
(setf guesses
(merge 'list guesses (list l) #'<))))
......@@ -190,9 +192,8 @@
(loop for fwd in forward-references
when (try-resolve-forward-reference fwd env optimize-teo)
collect fwd into resolved-forwards
finally (unless (null resolved-forwards)
(setf forward-references
(set-difference forward-references resolved-forwards)))))
finally (setf forward-references
(set-difference forward-references resolved-forwards))))
(ALIGNMENT
(loop for cbyte in (create-alignment expr (assemble-env-current-pc env))
do (push cbyte encoded-proglist-reverse)
......@@ -252,7 +253,8 @@
(loop for assumed-instr-length =
(guess-next-instruction-length expr
(unresolved-labels-labels ul-condition)
(rest expr-rest))
(rest expr-rest)
env)
do
#+ignore (warn "Trying for ~A at ~D with ~A octets.."
expr (assemble-env-current-pc env) assumed-instr-length)
......@@ -277,7 +279,7 @@
(assumption-failed (af-condition)
(unless (eq fwd (assumption-failed-forward-reference af-condition))
(error af-condition)) ; decline
#+ignore (warn "~A" af-condition)
;; (warn "~A" af-condition)
;; pop this length off the list of instr-length guesses
(assert (gethash expr *proglist-minimum-expr-size*) (expr)
"Unable to encode ~A. Is the label too far away?" expr)
......
......@@ -9,7 +9,7 @@
;;;; Created at: Mon Jul 31 13:54:27 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: read.lisp,v 1.5 2004/06/21 07:33:50 ffjeld Exp $
;;;; $Id: read.lisp,v 1.6 2004/08/10 10:12:57 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -44,6 +44,8 @@
;;; absexpr ::= <label> | <number> | append-prg
;;; append-prg ::= program
;;;
;;; prefix ::= <segment-override> | (:size <size>)
;;;
;;;
;;; Instructions are recognized by symbol-name, so there should be no
;;; need to worry about packages etc.
......@@ -206,25 +208,34 @@ returns the symbol/label that is referenced."
(t (error "Can't read operand ~S" spec))))
(defun read-prefixes (prefix-spec)
(loop for p in prefix-spec
with user-size = nil
(loop with user-size = nil with user-finalizer = nil
for p in prefix-spec
if (symbolp p)
collect (let ((ps (find-symbol (symbol-name p) '#:ia-x86)))
(if (decode-set +prefix-opcode-map+ ps :errorp nil)
ps
(error "No such prefix: ~A" p)))
into prefixes
else if (integerp p)
do (setf user-size p)
finally (return (values prefixes user-size))))
else do
(check-type p list)
(ecase (car p)
(:size
(let ((size (second p)))
(check-type size integer)
(setf user-size size)))
(:finalize ; XXX
(let ((finalizer (second p)))
(check-type finalizer symbol "a function name")
(setf user-finalizer finalizer))))
finally (return (values prefixes user-size user-finalizer))))
(defvar *find-instruction-cache* (make-hash-table :test #'eq))
(defun read-instruction (sexpr)
"Parse a list into an assembly instruction."
(let (prefix-list user-size instr-name operand-list)
(let (prefix-list user-size user-finalizer instr-name operand-list)
(if (listp (first sexpr))
(setf (values prefix-list user-size) (read-prefixes (first sexpr))
(setf (values prefix-list user-size user-finalizer) (read-prefixes (first sexpr))
instr-name (second sexpr)
operand-list (nthcdr 2 sexpr))
(setf prefix-list nil
......@@ -244,9 +255,10 @@ returns the symbol/label that is referenced."
(unless instr-symbol-status
(error "No instruction named ~A." (string instr-name)))
instr-symbol)))
'prefixes prefix-list
'user-size user-size
'operands (mapcar #'read-operand operand-list))))))
:prefixes prefix-list
:user-size user-size
:user-finalizer user-finalizer
:operands (mapcar #'read-operand operand-list))))))
(defun inline-data-p (expr)
......@@ -303,4 +315,4 @@ a proglist: A list of INSTRUCTION objects."
(defmacro asm (&rest spec)
`(instruction-encode (read-instruction ',spec)))
`(instruction-encode (read-instruction ',spec) nil))
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