1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2005, Clozure Associates |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | |
---|
17 | (in-package "CCL") |
---|
18 | |
---|
19 | (next-nx-defops) |
---|
20 | (defvar *x862-specials* nil) |
---|
21 | (let* ((newsize (%i+ (next-nx-num-ops) 10)) |
---|
22 | (old *x862-specials*) |
---|
23 | (oldsize (length old))) |
---|
24 | (declare (fixnum newsize oldsize)) |
---|
25 | (unless (>= oldsize newsize) |
---|
26 | (let* ((v (make-array newsize :initial-element nil))) |
---|
27 | (dotimes (i oldsize (setq *x862-specials* v)) |
---|
28 | (setf (svref v i) (svref old i)))))) |
---|
29 | |
---|
30 | (defun x86-encode-vinsn-operand-type (thing backend) |
---|
31 | (when thing |
---|
32 | (if (atom thing) |
---|
33 | (x86::encode-operand-type :label) |
---|
34 | (ecase (car thing) |
---|
35 | (:% (ecase (arch::target-lisp-node-size (backend-target-arch backend)) |
---|
36 | (8 (x86::encode-operand-type :reg64)) |
---|
37 | (4 (x86::encode-operand-type :reg32)))) |
---|
38 | (:%acc (ecase (arch::target-lisp-node-size (backend-target-arch backend)) |
---|
39 | (8 (x86::encode-operand-type :reg64 :acc)) |
---|
40 | (4 (x86::encode-operand-type :reg32 :acc)))) |
---|
41 | (:%q (x86::encode-operand-type :reg64)) |
---|
42 | (:%accq (x86::encode-operand-type :reg64 :acc)) |
---|
43 | (:%l (x86::encode-operand-type :reg32)) |
---|
44 | (:%accl (x86::encode-operand-type :reg32 :acc)) |
---|
45 | (:%w (x86::encode-operand-type :reg16)) |
---|
46 | (:%accw (x86::encode-operand-type :reg16 :acc)) |
---|
47 | (:%b (x86::encode-operand-type :reg8)) |
---|
48 | (:%accb (x86::encode-operand-type :reg8 :acc)) |
---|
49 | (:%xmm (x86::encode-operand-type :regxmm)) |
---|
50 | (:%mmx (x86::encode-operand-type :regmmx)) |
---|
51 | (:@ (x86::encode-operand-type :anymem)) |
---|
52 | (:rcontext (x86::encode-operand-type :anymem)) |
---|
53 | (:$1 (x86::encode-operand-type :imm1) ) |
---|
54 | (:$b (x86::encode-operand-type :imm8s )) |
---|
55 | (:$ub (x86::encode-operand-type :imm8)) |
---|
56 | (:$w (x86::encode-operand-type :imm16)) |
---|
57 | (:$l (x86::encode-operand-type :imm32s)) |
---|
58 | (:$ul (x86::encode-operand-type :imm32)) |
---|
59 | (:$q (x86::encode-operand-type :imm64)) |
---|
60 | (:%shift (x86::encode-operand-type :shiftcount :reg8)) |
---|
61 | (:$self (x86::encode-operand-type :self)))))) |
---|
62 | |
---|
63 | (defun lookup-x86-opcode (form backend) |
---|
64 | (when (consp form) |
---|
65 | (let* ((name (string (car form))) |
---|
66 | (templates (gethash name x86::*x86-opcode-template-lists*))) |
---|
67 | (when templates |
---|
68 | (flet ((optype (thing) |
---|
69 | (x86-encode-vinsn-operand-type thing backend))) |
---|
70 | (let* ((operands (cdr form)) |
---|
71 | (type0 (optype (pop operands))) |
---|
72 | (type1 (optype (pop operands))) |
---|
73 | (type2 (optype (car operands)))) |
---|
74 | (dolist (template templates) |
---|
75 | (when (x86::match-template-types template type0 type1 type2 backend) |
---|
76 | (collect ((types)) |
---|
77 | (if type0 (types type0)) |
---|
78 | (if type1 (types type1)) |
---|
79 | (if type2 (types type2)) |
---|
80 | (return (values (x86::x86-opcode-template-ordinal template) |
---|
81 | (types)))))))))))) |
---|
82 | |
---|
83 | (defun fixup-opcode-ordinals (vinsn-template opcode-templates &optional (backend *target-backend*)) |
---|
84 | (let* ((changed ())) |
---|
85 | (dolist (vinsn-opcode (vinsn-template-opcode-alist vinsn-template)) |
---|
86 | (destructuring-bind (old-ordinal name &optional type0 type1 type2) vinsn-opcode |
---|
87 | (let* ((opcode-templates (gethash name opcode-templates))) |
---|
88 | (unless opcode-templates |
---|
89 | (error "Unknown X86 instruction - ~a. Odd, because it was once a known instruction." name)) |
---|
90 | (let* ((new-ordinal (dolist (template opcode-templates) |
---|
91 | (when (x86::match-template-types template type0 type1 type2 backend) |
---|
92 | (return (x86::x86-opcode-template-ordinal template)))))) |
---|
93 | (unless new-ordinal |
---|
94 | (error "No match for opcode ~s in ~s" vinsn-opcode vinsn-template)) |
---|
95 | (unless (eql old-ordinal new-ordinal) |
---|
96 | (setf (car vinsn-opcode) new-ordinal) |
---|
97 | (push (cons old-ordinal new-ordinal) changed)))))) |
---|
98 | (when changed |
---|
99 | ;;(format t "~& opcode ordinals changed in ~s: ~s" vinsn-template changed) |
---|
100 | (flet ((update-instruction (i) |
---|
101 | (when (consp i) |
---|
102 | ;; An :ANCHORED-UUO directive contains a real |
---|
103 | ;; (vinsn-encoded) instruction (typically a UUO) in |
---|
104 | ;; its cadr. Other directives won't contain embedded |
---|
105 | ;; instructions and whatever's in their CARs won't |
---|
106 | ;; match in the assoc below. |
---|
107 | (when (eq (car i) :anchored-uuo) |
---|
108 | (setq i (cadr i))) |
---|
109 | (let* ((pair (assoc (car i) changed :test #'eq))) |
---|
110 | (when pair |
---|
111 | (setf (car i) (cdr pair))))))) |
---|
112 | (labels ((fixup-form (form) |
---|
113 | (unless (atom form) |
---|
114 | (if (atom (car form)) |
---|
115 | (update-instruction form) |
---|
116 | (dolist (f (cdr form)) |
---|
117 | (fixup-form f)))))) |
---|
118 | (dolist (form (vinsn-template-body vinsn-template)) |
---|
119 | (fixup-form form))))))) |
---|
120 | |
---|
121 | (defparameter *report-missing-vinsns* nil) |
---|
122 | |
---|
123 | (defun fixup-x86-vinsn-templates (template-hash opcode-templates &optional (backend *target-backend*)) |
---|
124 | (maphash #'(lambda (name vinsn-template) |
---|
125 | (if (not (cdr vinsn-template)) |
---|
126 | (when *report-missing-vinsns* |
---|
127 | (warn "Reference to undefined vinsn ~s" name)) |
---|
128 | (fixup-opcode-ordinals (cdr vinsn-template) opcode-templates backend))) |
---|
129 | template-hash)) |
---|
130 | |
---|
131 | |
---|
132 | |
---|
133 | ;;; This defines a template. All expressions in the body must be |
---|
134 | ;;; evaluable at macroexpansion time. |
---|
135 | (defun define-x86-vinsn (backend vinsn-name results args temps body) |
---|
136 | (let* ((opcode-lookup (backend-lookup-opcode backend)) |
---|
137 | (backend-name (backend-name backend)) |
---|
138 | (arch-name (backend-target-arch-name backend)) |
---|
139 | (template-hash (backend-p2-template-hash-name backend)) |
---|
140 | (name-list ()) |
---|
141 | (attrs 0) |
---|
142 | (nhybrids 0) |
---|
143 | (local-labels ()) |
---|
144 | (referenced-labels ()) |
---|
145 | (source-indicator (form-symbol arch-name "-VINSN")) |
---|
146 | (opcode-alist ())) |
---|
147 | (flet ((valid-spec-name (x) |
---|
148 | (or (and (consp x) |
---|
149 | (consp (cdr x)) |
---|
150 | (null (cddr x)) |
---|
151 | (atom (car x)) |
---|
152 | (or (assoc (cadr x) *vreg-specifier-constant-constraints* :test #'eq) |
---|
153 | (assoc (cadr x) *spec-class-storage-class-alist* :test #'eq) |
---|
154 | (eq (cadr x) :label) |
---|
155 | (and (consp (cadr x)) (eq (caadr x) :label) (consp (cdadr x)) (null (cddadr x))) |
---|
156 | (and (consp (cadr x)) |
---|
157 | (or |
---|
158 | (assoc (caadr x) *vreg-specifier-constant-constraints* :test #'eq) |
---|
159 | (assoc (caadr x) *spec-class-storage-class-alist* :test #'eq)))) |
---|
160 | (car x)) |
---|
161 | (error "Invalid vreg spec: ~s" x))) |
---|
162 | (add-spec-name (vname) |
---|
163 | (if (member vname name-list :test #'eq) |
---|
164 | (error "Duplicate name ~s in vinsn ~s" vname vinsn-name) |
---|
165 | (push vname name-list)))) |
---|
166 | (declare (dynamic-extent #'valid-spec-name #'add-spec-name)) |
---|
167 | (when (consp vinsn-name) |
---|
168 | (setq attrs (encode-vinsn-attributes (cdr vinsn-name)) |
---|
169 | vinsn-name (car vinsn-name))) |
---|
170 | (unless (and (symbolp vinsn-name) (eq *CCL-PACKAGE* (symbol-package vinsn-name))) |
---|
171 | (setq vinsn-name (intern (string vinsn-name) *CCL-PACKAGE*))) |
---|
172 | (dolist (n (append args temps)) |
---|
173 | (add-spec-name (valid-spec-name n))) |
---|
174 | (dolist (form body) |
---|
175 | (if (atom form) |
---|
176 | (add-spec-name form))) |
---|
177 | (setq name-list (nreverse name-list)) |
---|
178 | ;; We now know that "args" is an alist; we don't know if |
---|
179 | ;; "results" is. First, make sure that there are no duplicate |
---|
180 | ;; result names (and validate "results".) |
---|
181 | (do* ((res results tail) |
---|
182 | (tail (cdr res) (cdr tail))) |
---|
183 | ((null res)) |
---|
184 | (let* ((name (valid-spec-name (car res)))) |
---|
185 | (if (assoc name tail :test #'eq) |
---|
186 | (error "Duplicate result name ~s in ~s." name results)))) |
---|
187 | (let* ((non-hybrid-results ()) |
---|
188 | (match-args args)) |
---|
189 | (dolist (res results) |
---|
190 | (let* ((res-name (car res))) |
---|
191 | (if (not (assoc res-name args :test #'eq)) |
---|
192 | (if (not (= nhybrids 0)) |
---|
193 | (error "result ~s should also name an argument. " res-name) |
---|
194 | (push res-name non-hybrid-results)) |
---|
195 | (if (eq res-name (caar match-args)) |
---|
196 | (setf nhybrids (1+ nhybrids) |
---|
197 | match-args (cdr match-args)) |
---|
198 | (error "~S - hybrid results should appear in same order as arguments." res-name))))) |
---|
199 | (dolist (name non-hybrid-results) |
---|
200 | (add-spec-name name))) |
---|
201 | (let* ((k -1)) |
---|
202 | (declare (fixnum k)) |
---|
203 | (let* ((name-alist (mapcar #'(lambda (n) (cons n (list (incf k)))) name-list))) |
---|
204 | (flet ((find-name (n) |
---|
205 | (let* ((pair (assoc n name-alist :test #'eq))) |
---|
206 | (declare (list pair)) |
---|
207 | (if pair |
---|
208 | (cdr pair) |
---|
209 | (or (subprim-name->offset n backend) |
---|
210 | (error "Unknown name ~s" n)))))) |
---|
211 | (labels ((simplify-simple-operand (op) |
---|
212 | (if (atom op) |
---|
213 | (if (typep op 'fixnum) |
---|
214 | op |
---|
215 | (if (eq op :rcontext) |
---|
216 | op |
---|
217 | (if (constantp op) |
---|
218 | (progn |
---|
219 | (if (keywordp op) |
---|
220 | (pushnew op referenced-labels)) |
---|
221 | (eval op)) |
---|
222 | (find-name op)))) |
---|
223 | (if (eq (car op) :^) |
---|
224 | (list :^ (simplify-simple-operand (cadr op))) |
---|
225 | (if (eq (car op) :apply) |
---|
226 | `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op))) |
---|
227 | (if (member (car op) |
---|
228 | '(:tra :align :byte :word :long :quad :talign)) |
---|
229 | `(,(car op) ,(simplify-operand (cadr op))) |
---|
230 | (simplify-operand (eval op))))))) ; Handler-case this? |
---|
231 | (simplify-memory-operand (op) |
---|
232 | ;; This happens to be the only place that |
---|
233 | ;; we allow segment registers. |
---|
234 | (let* ((seg nil) |
---|
235 | (disp nil) |
---|
236 | (base nil) |
---|
237 | (index nil) |
---|
238 | (scale nil)) |
---|
239 | (do* ((form op (cdr form))) |
---|
240 | ((null form) (list seg disp base index scale)) |
---|
241 | (let* ((head (car form))) |
---|
242 | (if (consp head) |
---|
243 | (case (car head) |
---|
244 | (:%seg |
---|
245 | (if (eq form op) |
---|
246 | (setq seg (simplify-operand (cadr head))) |
---|
247 | (error "Bad :%seg in ~s" op))) |
---|
248 | ((:%q :% :%l) |
---|
249 | (let* ((r (simplify-operand head))) |
---|
250 | (if base |
---|
251 | (if index |
---|
252 | (error "Extra register ~s in ~s" |
---|
253 | head op) |
---|
254 | (setq index r)) |
---|
255 | (setq base r)))) |
---|
256 | (t |
---|
257 | (if (and (null (cdr form)) |
---|
258 | (or disp base index)) |
---|
259 | (progn |
---|
260 | (setq scale (simplify-simple-operand head)) |
---|
261 | (if (and base (not index)) |
---|
262 | (setq index base base nil))) |
---|
263 | (if (not (or disp base index)) |
---|
264 | (setq disp (simplify-simple-operand head)) |
---|
265 | (error "~s not expected in ~s" op))))) |
---|
266 | (if (and (null (cdr form)) |
---|
267 | (or disp base index)) |
---|
268 | (progn |
---|
269 | (setq scale (simplify-simple-operand head)) |
---|
270 | (if (and base (not index)) |
---|
271 | (setq index base base nil))) |
---|
272 | (if (not (or disp base index)) |
---|
273 | (setq disp (simplify-simple-operand head)) |
---|
274 | (error "~s not expected in ~s" op)))))))) |
---|
275 | (simplify-operand (op) |
---|
276 | (cond ((atom op) |
---|
277 | (simplify-simple-operand op)) |
---|
278 | ((eq (car op) :@) |
---|
279 | (cons :@ |
---|
280 | (simplify-memory-operand (cdr op)))) |
---|
281 | ((eq (car op) :rcontext) |
---|
282 | (list :rcontext |
---|
283 | (simplify-simple-operand (cadr op)))) |
---|
284 | ((member (car op) |
---|
285 | '(:% :%q :%l :%w :%b |
---|
286 | :%acc :%accq :%accl :%accw :%accb |
---|
287 | :$ :$1 :$b :$ub :$w :$l |
---|
288 | :$ul :$q :%mmx :%xmm :%shift :$self)) |
---|
289 | (simplify-simple-operand (cadr op))) |
---|
290 | (t |
---|
291 | (simplify-simple-operand op))))) |
---|
292 | (labels ((simplify-constraint (guard) |
---|
293 | ;; A constraint is one of |
---|
294 | |
---|
295 | ;; (:eq|:lt|:gt vreg-name constant) ; "value" |
---|
296 | ;; of vreg relop constant |
---|
297 | |
---|
298 | ;; (:pred <function-name> <operand>* ; |
---|
299 | ;; <function-name> unquoted, each <operand> |
---|
300 | ;; is a vreg-name or constant expression. |
---|
301 | |
---|
302 | ;; (:type vreg-name typeval) ; vreg is of |
---|
303 | ;; "type" typeval |
---|
304 | ;; |
---|
305 | ;;(:not <constraint>) ; constraint is false |
---|
306 | ;; (:and <constraint> ...) ; conjuntion |
---|
307 | ;; (:or <constraint> ...) ; disjunction |
---|
308 | ;; There's no "else"; we'll see how ugly it |
---|
309 | ;; is without one. |
---|
310 | (destructuring-bind (guardname &rest others) guard |
---|
311 | (ecase guardname |
---|
312 | (:not |
---|
313 | (destructuring-bind (negation) others |
---|
314 | `(:not ,(simplify-constraint negation)))) |
---|
315 | (:pred |
---|
316 | (destructuring-bind (predicate &rest operands) others |
---|
317 | `(:pred ,predicate ,@(mapcar #'simplify-operand operands)))) |
---|
318 | ((:eq :lt :gt :type) |
---|
319 | (destructuring-bind (vreg constant) others |
---|
320 | (unless (constantp constant) |
---|
321 | (error "~S : not constant in constraint ~s ." constant guard)) |
---|
322 | `(,guardname ,(find-name vreg) ,(eval constant)))) |
---|
323 | ((:or :and) |
---|
324 | (unless others (error "Missing constraint list in ~s ." guard)) |
---|
325 | `(,guardname ,(mapcar #'simplify-constraint others)))))) |
---|
326 | (simplify-form (form) |
---|
327 | (if (atom form) |
---|
328 | (progn |
---|
329 | (if (keywordp form) (push form local-labels) ) |
---|
330 | form) |
---|
331 | (destructuring-bind (&whole w opname &rest opvals) form |
---|
332 | (if (consp opname) ; A constraint, we presume ... |
---|
333 | (cons (simplify-constraint opname) |
---|
334 | (mapcar #'simplify-form opvals)) |
---|
335 | (if (keywordp opname) |
---|
336 | (progn |
---|
337 | (list opname |
---|
338 | (if (eq opname :anchored-uuo) |
---|
339 | (simplify-form (car opvals)) |
---|
340 | (simplify-operand (car opvals))))) |
---|
341 | (let* ((name (string opname))) |
---|
342 | (multiple-value-bind (opnum types) |
---|
343 | (funcall opcode-lookup form backend) |
---|
344 | (if (not opnum) |
---|
345 | (error "Unknown ~A instruction in ~s" backend-name form) |
---|
346 | (let* ((opvals (mapcar #'simplify-operand opvals))) |
---|
347 | (setf (assq opnum opcode-alist) (cons name types)) |
---|
348 | `(,opnum ,@opvals))))))))))) |
---|
349 | (let* ((template (make-vinsn-template :name vinsn-name |
---|
350 | :result-vreg-specs results |
---|
351 | :argument-vreg-specs args |
---|
352 | :temp-vreg-specs temps |
---|
353 | :nhybrids nhybrids |
---|
354 | :results&args (append results (nthcdr nhybrids args)) |
---|
355 | :nvp (- (+ (length results) (length args) (length temps)) |
---|
356 | nhybrids) |
---|
357 | :body (prog1 (mapcar #'simplify-form body) |
---|
358 | (dolist (ref referenced-labels) |
---|
359 | (unless (memq ref local-labels) |
---|
360 | (error |
---|
361 | "local-label ~S was referenced but ~ |
---|
362 | never defined in VINSN-TEMPLATE definition for ~s" |
---|
363 | ref vinsn-name)))) |
---|
364 | :local-labels local-labels |
---|
365 | :attributes attrs |
---|
366 | :opcode-alist opcode-alist))) |
---|
367 | |
---|
368 | `(progn |
---|
369 | (set-vinsn-template ',vinsn-name ,template ,template-hash) |
---|
370 | (record-source-file ',vinsn-name ',source-indicator) |
---|
371 | ',vinsn-name)))))))))) |
---|
372 | |
---|
373 | |
---|
374 | |
---|
375 | #+x8632-target |
---|
376 | (require "X8632-BACKEND") |
---|
377 | #+x8664-target |
---|
378 | (require "X8664-BACKEND") |
---|
379 | |
---|
380 | (defparameter *x86-backend* |
---|
381 | #+x8632-target *x8632-backend* |
---|
382 | #+x8664-target *x8664-backend* |
---|
383 | #-x86-target nil) |
---|
384 | |
---|
385 | |
---|
386 | (defun fixup-x86-backend (&rest args) |
---|
387 | #+x8632-target (apply #'fixup-x8632-backend args) |
---|
388 | #+x8664-target (apply #'fixup-x8664-backend args) |
---|
389 | #-x86-target (declare (ignore args)) |
---|
390 | ) |
---|
391 | |
---|
392 | (provide "X86-BACKEND") |
---|