source: trunk/source/compiler/X86/x86-backend.lisp @ 10200

Last change on this file since 10200 was 10200, checked in by rme, 12 years ago

Encode :$self type in vinsns. Also add various :%acc operand types
for use in vinsns.

There is sometimes a shorter encoding for instructions which use the
accumulator (EAX/RAX) as an operand, so provide a way to get at these
instructions.

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