source: branches/working-0711/ccl/compiler/X86/x86-backend.lisp @ 11810

Last change on this file since 11810 was 11810, checked in by gz, 10 years ago

Fix bad format (or warn etc.) calls found by the format string scanner

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.5 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        (: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" head 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" head 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")
Note: See TracBrowser for help on using the repository browser.