/[movitz]/ia-x86/proglist.lisp
ViewVC logotype

Contents of /ia-x86/proglist.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Tue Oct 12 09:37:24 2004 UTC (9 years, 6 months ago) by ffjeld
Branch: MAIN
CVS Tags: HEAD
Changes since 1.5: +1 -2 lines
Removed warning about "assumption bigger than.."
1 ;;;;------------------------------------------------------------------
2 ;;;;
3 ;;;; Copyright (C) 20012000, 2002, 2004,
4 ;;;; Department of Computer Science, University of Tromso, Norway
5 ;;;;
6 ;;;; Filename: proglist.lisp
7 ;;;; Description:
8 ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
9 ;;;; Created at: Mon May 15 13:43:55 2000
10 ;;;; Distribution: See the accompanying file COPYING.
11 ;;;;
12 ;;;; $Id: proglist.lisp,v 1.6 2004/10/12 09:37:24 ffjeld Exp $
13 ;;;;
14 ;;;;------------------------------------------------------------------
15
16 (in-package #:ia-x86)
17
18 (defvar *label-counter* 0)
19 (defun make-label ()
20 (intern (format nil "~A-~D"
21 'label
22 (incf *label-counter*))))
23
24 (defun labelize-proglist (proglist &optional (start-address 0))
25 "Destructively modifies the instruction-objects in proglist."
26 (let ((end-address (+ start-address
27 (loop for i in proglist
28 summing (imagpart (instruction-original-datum i)))))
29 (label-hash (make-hash-table :test #'eql :size 19)))
30 (loop for i in proglist
31 with pc = start-address
32 do (incf pc (imagpart (instruction-original-datum i)))
33 do (loop for operands on (instruction-operands i)
34 when (typep (car operands) 'operand-rel-pointer)
35 do (let ((address (+ pc (slot-value (car operands) 'offset))))
36 (if (<= start-address address end-address)
37 (let ((label (or (gethash address label-hash)
38 (setf (gethash address label-hash)
39 (make-label)))))
40 (setf (car operands)
41 (make-instance 'operand-label 'label label)))
42 (setf (car operands)
43 (make-instance 'operand-number 'number address))))))
44 (loop for i in proglist
45 with pc = start-address
46 when (gethash pc label-hash)
47 collect (gethash pc label-hash)
48 collect i
49 do (incf pc (imagpart (instruction-original-datum i))))))
50
51 (defclass forward-reference ()
52 ((labels :initarg labels :reader forward-reference-labels)
53 (referring-pc :initarg referring-pc)
54 (placeholder-cons :initarg placeholder-cons)
55 (assumed-length :initarg assumed-length
56 :accessor forward-reference-assumed-length)))
57
58 (defclass forward-reference-instruction (forward-reference)
59 ((instruction :initarg instruction)))
60
61 (defclass forward-reference-inline-data (forward-reference)
62 ((inline-data :initarg inline-data)))
63
64 (defmethod print-object ((obj forward-reference) stream)
65 (format stream "<unresolved: ~A>" (forward-reference-labels obj)))
66
67 (define-condition assumption-failed ()
68 ((forward-reference :initarg forward-reference
69 :reader assumption-failed-forward-reference)
70 (actual-symtab :initarg actual-symtab
71 :reader assumption-failed-actual-symtab)
72 (actual-length :initarg actual-length
73 :reader assumption-failed-actual-length))
74 (:report
75 (lambda (condition stream)
76 (with-slots (forward-reference actual-symtab assumed-length actual-length)
77 condition
78 (with-slots (referring-pc assumed-length)
79 forward-reference
80 (format stream
81 "Assumption failed when ~A implied length ~A while ~A was assumed."
82 actual-symtab actual-length assumed-length))))))
83
84 (defun try-resolve-forward-reference (fwd-to-resolve env optimize-teo)
85 (if (notevery #'(lambda (label)
86 (symtab-try-lookup-label (assemble-env-symtab env) label))
87 (forward-reference-labels fwd-to-resolve))
88 nil ; this label doesn't (completely) resolve this fwd.
89 (prog1 t (resolve-forward-reference fwd-to-resolve env optimize-teo))))
90
91 (defmethod resolve-forward-reference ((fwd-to-resolve forward-reference-instruction) env optimize-teo)
92 (with-slots (labels instruction referring-pc
93 placeholder-cons assumed-length)
94 fwd-to-resolve
95 ;;; (warn "Resolving at ~D from ~D: ~S" referring-pc (assemble-env-current-pc env)
96 ;;; (mapcar #'(lambda (l)
97 ;;; (cons l (format nil "~D" (symtab-lookup-label (assemble-env-symtab env) l))))
98 ;;; labels))
99 (let ((cdatum (instruction-encode instruction
100 (make-assemble-env :symtab (assemble-env-symtab env)
101 :current-pc referring-pc)
102 optimize-teo)))
103 (when (< (imagpart cdatum) assumed-length)
104 (setf cdatum
105 (instruction-encode instruction
106 (make-assemble-env :symtab (assemble-env-symtab env)
107 :current-pc referring-pc)
108 #'(lambda (teo-list instr env)
109 (or (find-if #'(lambda (teo)
110 (= assumed-length
111 (template-instr-and-prefix-length
112 (teo-template teo)
113 instr env)))
114 teo-list)
115 (error "Unable to find encoding matching size ~D for ~S"
116 assumed-length instr))))))
117 (unless (= (imagpart cdatum) assumed-length)
118 (error 'assumption-failed
119 'forward-reference fwd-to-resolve
120 'actual-symtab (mapcar #'(lambda (label)
121 (cons label
122 (symtab-lookup-label (assemble-env-symtab env)
123 label)))
124 labels)
125 'actual-length (imagpart cdatum)))
126 (setf (car placeholder-cons) cdatum))))
127
128 (defmethod resolve-forward-reference ((fwd-to-resolve forward-reference-inline-data) env optimize-teo)
129 (declare (ignore optimize-teo))
130 (with-slots (labels inline-data referring-pc placeholder-cons assumed-length)
131 fwd-to-resolve
132 (let* ((cdatums (reverse (inline-data-encode inline-data env)))
133 (total-length (loop for cd in cdatums summing (imagpart cd))))
134 (unless (= total-length assumed-length)
135 (error 'assumption-failed
136 'forward-reference fwd-to-resolve
137 'actual-symtab (mapcar #'(lambda (label)
138 (cons label
139 (symtab-lookup-label (assemble-env-symtab env) label)))
140 labels)
141 'actual-length total-length))
142 ;; splice in the cdatums list
143 (setf (car placeholder-cons) (car cdatums)
144 (cdr (last cdatums)) (cdr placeholder-cons)
145 (cdr placeholder-cons) (cdr cdatums)))))
146
147
148 (defun guess-next-instruction-length (expr missing-labels program-rest env)
149 (declare (special *proglist-minimum-expr-size*))
150 ;; (let ((minimum-size (max previous-length (gethash expr *proglist-minimum-expr-size*))))
151 (or (instruction-user-size expr)
152 (car (or (gethash expr *proglist-minimum-expr-size*)
153 (setf (gethash expr *proglist-minimum-expr-size*)
154 (typecase expr
155 ((or ia-x86-instr::jmp #+ignore ia-x86-instr::jcc)
156 ;; educated guess for jumps..
157 (assert (= 1 (length missing-labels)))
158 (let ((instruction-offset (position (first missing-labels) program-rest)))
159 (assert instruction-offset ()
160 "Can't find label ~S for instruction ~S." (first missing-labels) expr)
161 (etypecase expr
162 (ia-x86-instr::jmp
163 (if (>= instruction-offset 60)
164 '(5 2 4)
165 '(2 5 4)))
166 #+ignore (ia-x86-instr::jcc
167 (if (>= instruction-offset 50)
168 (if (eq *cpu-mode* :32-bit) '(6 2 4 5) '(4 2 6 5))
169 (if (eq *cpu-mode* :32-bit) '(2 6 4) '(2 4 6)))))))
170 (t (loop with guesses = nil
171 for template in (templates-lookup-by-class-name (type-of expr))
172 when (template-match-by-operand-classes template (instruction-operands expr))
173 do (let ((l (template-instr-and-prefix-length template expr env)))
174 (unless (member l guesses)
175 (setf guesses
176 (merge 'list guesses (list l) #'<))))
177 finally (return guesses)))))))))
178
179 (defun proglist-encode-internal (prog-list env forward-references encoded-proglist-reverse
180 optimize-teo)
181
182 (declare (special *proglist-minimum-expr-size*))
183 (loop for expr-rest on prog-list
184 do (let ((expr (first expr-rest)))
185 (etypecase expr
186 ((or SYMBOL integer)
187 (setf (assemble-env-symtab env)
188 (symtab-def-label (assemble-env-symtab env)
189 expr
190 (assemble-env-current-pc env)))
191 (loop for fwd in forward-references
192 when (try-resolve-forward-reference fwd env optimize-teo)
193 collect fwd into resolved-forwards
194 finally (setf forward-references
195 (set-difference forward-references resolved-forwards))))
196 (ALIGNMENT
197 (loop for cbyte in (create-alignment expr (assemble-env-current-pc env))
198 do (push cbyte encoded-proglist-reverse)
199 do (incf (assemble-env-current-pc env)
200 (imagpart cbyte))))
201 (INLINE-DATA
202 ;; this follows pretty much the same structure as the INSTRUCTION case.
203 (handler-case
204 (loop for cbyte in (inline-data-encode expr env)
205 do (push cbyte encoded-proglist-reverse)
206 do (incf (assemble-env-current-pc env)
207 (imagpart cbyte)))
208 (unresolved-labels (ul-condition)
209 (push 'unresolved-inline-data-forward-reference encoded-proglist-reverse)
210 (let* ((assumed-length (inline-data-guess-sizeof expr env))
211 (fwd (make-instance 'forward-reference-inline-data
212 'labels (unresolved-labels-labels ul-condition)
213 'inline-data expr
214 'referring-pc (assemble-env-current-pc env)
215 'assumed-length assumed-length
216 'placeholder-cons encoded-proglist-reverse)))
217 (loop
218 (handler-case
219 (return-from proglist-encode-internal
220 (proglist-encode-internal (rest expr-rest)
221 (make-assemble-env
222 :symtab (symtab-add-frame (assemble-env-symtab env))
223 :current-pc (+ (assemble-env-current-pc env)
224 (forward-reference-assumed-length fwd)))
225 (cons fwd forward-references)
226 encoded-proglist-reverse
227 optimize-teo))
228 (assumption-failed (af-condition)
229 (unless (eq fwd (assumption-failed-forward-reference af-condition))
230 (error af-condition)) ; decline
231 ;; (warn af-condition)
232 (setf (forward-reference-assumed-length fwd)
233 (assumption-failed-actual-length af-condition))
234 ;; The assumption failed, we'll retry with the length found at the
235 ;; time the label was actually resolved.
236 (values))))))))
237 (INSTRUCTION
238 (handler-case
239 (let ((datum (instruction-encode expr env optimize-teo)))
240 (push datum encoded-proglist-reverse)
241 (incf (assemble-env-current-pc env)
242 (imagpart datum)))
243 (unresolved-labels (ul-condition)
244 ;; we stumbled upon a label-reference that wasn't immediately
245 ;; resolvable. We assume it's a forward reference.
246 ;; First, reserve a cons-cell for this instruction to be encoded later
247 (push 'unresolved-forward-reference encoded-proglist-reverse)
248 ;; Now loop over the possible octet-lengths for this instruction.
249 ;; For each iteration, assume that octet-length, and if no exception is
250 ;; raised, the assumption holds and we break out of the loop with
251 ;; the RETURN-FROM form.
252 (loop for assumed-instr-length =
253 (guess-next-instruction-length expr
254 (unresolved-labels-labels ul-condition)
255 (rest expr-rest)
256 env)
257 do
258 #+ignore (warn "Trying for ~A at ~D with ~A octets.."
259 expr (assemble-env-current-pc env) assumed-instr-length)
260 (let ((fwd (make-instance 'forward-reference-instruction
261 'labels (unresolved-labels-labels ul-condition)
262 'instruction expr
263 'referring-pc (assemble-env-current-pc env)
264 'assumed-length assumed-instr-length
265 'placeholder-cons encoded-proglist-reverse)))
266 (handler-case
267 ;; if assumption holds, break out of the loop
268 (return-from proglist-encode-internal
269 (proglist-encode-internal ; attempt to continue by recursion
270 (rest expr-rest)
271 (make-assemble-env
272 :symtab (symtab-add-frame (assemble-env-symtab env))
273 :current-pc (+ (assemble-env-current-pc env)
274 assumed-instr-length))
275 (cons fwd forward-references)
276 encoded-proglist-reverse
277 optimize-teo))
278 (assumption-failed (af-condition)
279 (unless (eq fwd (assumption-failed-forward-reference af-condition))
280 (error af-condition)) ; decline
281 ;; (warn "~A" af-condition)
282 ;; pop this length off the list of instr-length guesses
283 (assert (gethash expr *proglist-minimum-expr-size*) (expr)
284 "Unable to encode ~A. Is the label too far away?" expr)
285 (pop (gethash expr *proglist-minimum-expr-size*))
286 ;; the assumption failed.
287 ;; now continue the dolist loop
288 (values)))))
289 (error "Unable to encode ~A. Is the label too far away? ~
290 [Should _really_ never get here!!]"
291 expr)))))))
292 ;; When we get here, the whole proglist is encoded.
293 (unless (null forward-references)
294 (error "There were unresolved forward references: ~A"
295 (mapcar #'forward-reference-labels
296 forward-references)))
297 ;; success, return.
298 (values (nreverse encoded-proglist-reverse)
299 (assemble-env-symtab env)))
300
301
302 (defun cbyte-to-octet-list (cbyte)
303 (loop
304 with value = (realpart cbyte)
305 for i from (1- (imagpart cbyte)) downto 0
306 collect (ldb (byte 8 (* 8 i)) value)))
307
308 (defun proglist-encode (result-type cpu-mode start-addr prog-list
309 &key (optimize-teo #'optimize-teo-smallest-no16)
310 (symtab-lookup nil))
311 (let ((*cpu-mode* cpu-mode)
312 (*symtab-lookup* symtab-lookup)
313 (*proglist-minimum-expr-size* (make-hash-table :test #'eq)))
314 (declare (special *symtab-lookup* *proglist-minimum-expr-size*))
315 (multiple-value-bind (encoded-proglist symtab)
316 (proglist-encode-internal prog-list
317 (make-assemble-env :current-pc start-addr
318 :symtab (make-symtab))
319 nil nil optimize-teo)
320 (ecase result-type
321 ((:cbytes)
322 (values encoded-proglist symtab))
323 ((:octet-list)
324 (values (mapcan #'cbyte-to-octet-list encoded-proglist)
325 symtab))
326 ((:octet-vector)
327 (let* ((ep-size (loop for cbyte in encoded-proglist
328 summing (imagpart cbyte)))
329 (ep-vector (make-array ep-size
330 :element-type '(unsigned-byte 8)
331 :fill-pointer t)))
332 (loop
333 for cbyte in encoded-proglist
334 with i = 0
335 do (loop for bp from (1- (imagpart cbyte)) downto 0
336 do (setf (aref ep-vector i)
337 (ldb (byte 8 (* 8 bp)) (realpart cbyte)))
338 do (incf i))
339 finally (return (values ep-vector symtab)))))))))
340
341
342 (defun print-encoded-proglist (epl &optional (base-addr 0))
343 (loop for cbyte in epl
344 and counter from 0 by 1
345 with pc = base-addr
346 do (format t "~8,'0X: ~22<~{ ~2,'0X~}~;~> ~4D ~A~%"
347 pc
348 (cbyte-to-octet-list cbyte)
349 counter
350 (apply #'decode-octet-list (cbyte-to-octet-list cbyte)))
351 do (incf pc (imagpart cbyte))))
352
353 (defun octet-list-to-bioctets (octet-list)
354 (loop for oc on octet-list by #'cddr
355 collect (let ((msb (first oc))
356 (lsb (or (second oc) 0)))
357 (dpb lsb (byte 8 8) msb))))

  ViewVC Help
Powered by ViewVC 1.1.5