source: branches/arm/compiler/ARM/arm-backend.lisp @ 13759

Last change on this file since 13759 was 13759, checked in by gb, 9 years ago

Don't treat (some) local-labels as local names during definition;
we won't do that during expansion.
Handle pseudo-ops during vinsn definition.

File size: 14.3 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20(next-nx-defops)
21(defvar *arm2-specials* nil)
22(let* ((newsize (%i+ (next-nx-num-ops) 10))
23       (old *arm2-specials*)
24       (oldsize (length old)))
25  (declare (fixnum newsize oldsize))
26  (unless (>= oldsize newsize)
27    (let* ((v (make-array newsize :initial-element nil)))
28      (dotimes (i oldsize (setq *arm2-specials* v))
29        (setf (svref v i) (svref old i))))))
30
31;;; This defines a template.  All expressions in the body must be
32;;; evaluable at macroexpansion time.
33(defun %define-arm-vinsn (backend vinsn-name results args temps body)
34  (let* ((arch-name (backend-target-arch-name backend))
35         (template-hash (backend-p2-template-hash-name backend))
36         (name-list ())
37         (attrs 0)
38         (nhybrids 0)
39         (local-labels ())
40         (referenced-labels ())
41         (source-indicator (form-symbol arch-name "-VINSN"))
42         (opcode-alist ()))
43    (flet ((valid-spec-name (x)
44             (or (and (consp x) 
45                      (consp (cdr x)) 
46                      (null (cddr x)) 
47                      (atom (car x))
48                      (or (assoc (cadr x) *vreg-specifier-constant-constraints* :test #'eq)
49                          (assoc (cadr x) *spec-class-storage-class-alist* :test #'eq)
50                          (eq (cadr x) :label)
51                          (and (consp (cadr x))
52                               (or 
53                                (assoc (caadr x) *vreg-specifier-constant-constraints* :test #'eq)
54                                (assoc (caadr x) *spec-class-storage-class-alist* :test #'eq))))
55                      (car x))
56                 (error "Invalid vreg spec: ~s" x)))
57           (add-spec-name (vname) 
58             (if (member vname name-list :test #'eq)
59               (error "Duplicate name ~s in vinsn ~s" vname vinsn-name)
60               (push vname name-list))))
61      (declare (dynamic-extent #'valid-spec-name #'add-spec-name))
62      (when (consp vinsn-name)
63        (setq attrs (encode-vinsn-attributes (cdr vinsn-name))
64              vinsn-name (car vinsn-name)))
65      (unless (and (symbolp vinsn-name) (eq *CCL-PACKAGE* (symbol-package vinsn-name)))
66        (setq vinsn-name (intern (string vinsn-name) *CCL-PACKAGE*)))
67      (dolist (n (append args temps))
68        (add-spec-name (valid-spec-name n)))
69      #+no
70      (dolist (form body)
71        (if (atom form)
72          (add-spec-name form)))
73      (setq name-list (nreverse name-list))
74      ;; We now know that "args" is an alist; we don't know if
75      ;; "results" is.  First, make sure that there are no duplicate
76      ;; result names (and validate "results".)
77      (do* ((res results tail)
78            (tail (cdr res) (cdr tail)))
79           ((null res))
80        (let* ((name (valid-spec-name (car res))))
81          (if (assoc name tail :test #'eq)
82            (error "Duplicate result name ~s in ~s." name results))))
83      (let* ((non-hybrid-results ()) 
84             (match-args args))
85        (dolist (res results)
86          (let* ((res-name (car res)))
87            (if (not (assoc res-name args :test #'eq))
88              (if (not (= nhybrids 0))
89                (error "result ~s should also name an argument. " res-name)
90                (push res-name non-hybrid-results))
91              (if (eq res-name (caar match-args))
92                (setf nhybrids (1+ nhybrids)
93                      match-args (cdr match-args))
94                (error "~S - hybrid results should appear in same order as arguments." res-name)))))
95        (dolist (name non-hybrid-results)
96          (add-spec-name name)))
97      (let* ((k -1))
98        (declare (fixnum k))
99        (let* ((name-alist (mapcar #'(lambda (n) (cons n (list (incf k)))) name-list)))
100          (flet ((find-name (n)
101                   (let* ((pair (assoc n name-alist :test #'eq)))
102                     (declare (list pair))
103                     (if pair
104                       (cdr pair)
105                       (or (subprim-name->offset n backend)
106                           (error "Unknown name ~s" n))))))
107            (labels ((simplify-operand (op)
108                       (if (atom op)
109                         (if (typep op 'fixnum)
110                           op
111                           (if (constantp op)
112                             (progn
113                               (if (keywordp op)
114                                 (pushnew op referenced-labels))
115                               (eval op))
116                             (find-name op)))
117                         (if (eq (car op) :apply)
118                           `(,(cadr op) ,@(mapcar #'simplify-operand (cddr op)))
119                           (simplify-operand (eval op)))))) ; Handler-case this?         
120              (labels ((simplify-constraint (guard)
121                         ;; A constraint is one of
122
123                         ;; (:eq|:lt|:gt vreg-name constant)
124
125                         ;; value" of vreg relop constant
126
127                         ;; (:pred <function-name> <operand>* ;
128                         ;; <function-name> unquoted, each <operand>
129                         ;; is a vreg-name or constant expression.
130
131                         ;; (:type vreg-name typeval) ; vreg is of
132                         ;; "type" typeval
133                         ;;
134                         ;;(:not <constraint>) ; constraint is false
135                         ;; (:and <constraint> ...)        ;  conjuntion
136                         ;; (:or <constraint> ...)         ;  disjunction
137                         ;; There's no "else"; we'll see how ugly it
138                         ;; is without one.
139                         (destructuring-bind (guardname &rest others) guard
140                           (ecase guardname
141                             (:not 
142                              (destructuring-bind (negation) others
143                                `(:not ,(simplify-constraint negation))))
144                             (:pred
145                              (destructuring-bind (predicate &rest operands) others
146                                `(:pred ,predicate ,@(mapcar #'simplify-operand operands))))
147                             ((:eq :lt :gt :type)
148                              (destructuring-bind (vreg constant) others
149                                (unless (constantp constant)
150                                  (error "~S : not constant in constraint ~s ." constant guard))
151                                `(,guardname ,(find-name vreg) ,(eval constant))))
152                             ((:or :and)
153                              (unless others (error "Missing constraint list in ~s ." guard))
154                              `(,guardname ,(mapcar #'simplify-constraint others))))))
155                       (simplify-form (form)
156                         (if (atom form)
157                           (progn 
158                             (if (keywordp form) (push form local-labels) )
159                             form)
160                           (destructuring-bind (&whole w opname &rest opvals) form
161                             (if (consp opname) ; A constraint, we presume ...
162                               (cons (simplify-constraint opname)
163                                     (mapcar #'simplify-form opvals))
164                               (if (keywordp opname)
165                                 (ecase opname
166                                   ((:code :data)  form)
167                                   (:word (destructuring-bind (val) opvals
168                                            (list opname
169                                                  (let* ((p (position val name-list)))
170                                                    (if p (list p) (eval val)))))))
171                                 (arm::vinsn-simplify-instruction form name-list)))))))
172                (let* ((template (make-vinsn-template
173                                  :name vinsn-name
174                                  :result-vreg-specs results
175                                  :argument-vreg-specs args
176                                  :temp-vreg-specs temps
177                                  :nhybrids nhybrids
178                                  :results&args (append results (nthcdr nhybrids args))
179                                  :nvp (- (+ (length results) (length args) (length temps))
180                                          nhybrids)
181                                  :body (prog1 (mapcar #'simplify-form body)
182                                          (dolist (ref referenced-labels)
183                                            (unless (memq ref local-labels)
184                                              (error 
185                                               "local label ~S was referenced but never defined in VINSN-TEMPLATE definition for ~s" ref vinsn-name))))
186                                  :local-labels local-labels :attributes attrs :opcode-alist
187                                  opcode-alist)))
188                  `(progn (set-vinsn-template ',vinsn-name ,template
189                           ,template-hash) (record-source-file ',vinsn-name ',source-indicator)
190                    ',vinsn-name))))))))))
191
192
193
194(defvar *arm-vinsn-templates* (make-hash-table :test #'eq))
195
196
197
198
199(defvar *known-arm-backends* ())
200
201
202#+(or linuxarm-target (not arm-target))
203(defvar *linuxarm-backend*
204  (make-backend :lookup-opcode #'arm::lookup-arm-instruction
205                :lookup-macro #'false
206                :lap-opcodes arm::*arm-instruction-table*
207                :define-vinsn '%define-arm-vinsn
208                :platform-syscall-mask (logior platform-os-linux platform-cpu-arm)
209                :p2-dispatch *arm2-specials*
210                :p2-vinsn-templates *arm-vinsn-templates*
211                :p2-template-hash-name '*arm-vinsn-templates*
212                :p2-compile 'arm2-compile
213                :target-specific-features
214                '(:arm :arm-target :eabi-target :linux-target :linuxarm-target  :32-bit-target :little-endian-target)
215                :target-fasl-pathname (make-pathname :type "lafsl")
216                :target-platform (logior platform-word-size-32
217                                         platform-cpu-arm
218                                         platform-os-linux)
219                :target-os :linuxarm
220                :name :linuxarm
221                :target-arch-name :arm
222                :target-foreign-type-data nil
223                :target-arch arm::*arm-target-arch*))
224
225
226#+darwinarm-target
227(defvar *darwinarm-backend*
228  (make-backend :lookup-opcode #'lookup-arm-opcode
229                :lookup-macro #'arm::arm-macro-function
230                :lap-opcodes arm::*arm-opcodes*
231                :define-vinsn 'define-arm-vinsn
232                :platform-syscall-mask (logior platform-os-darwin platform-cpu-arm)               
233                :p2-dispatch *arm2-specials*
234                :p2-vinsn-templates *arm-vinsn-templates*
235                :p2-template-hash-name '*arm-vinsn-templates*
236                :p2-compile 'arm2-compile
237                :target-specific-features
238                '(:powerpc :arm-target :darwin-target :darwinarm-target :arm-target :32-bit-target :big-endian-target)
239                :target-fasl-pathname (make-pathname :type "dfsl")
240                :target-platform (logior platform-word-size-32
241                                         platform-cpu-arm
242                                         platform-os-darwin)
243                :target-os :darwinarm
244                :name :darwinarm
245                :target-arch-name :arm
246                :target-foreign-type-data nil
247                :target-arch arm::*arm-target-arch*))
248
249#+(or linuxarm-target (not arm-target))
250(pushnew *linuxarm-backend* *known-arm-backends* :key #'backend-name)
251
252
253#+darwinarm-target
254(pushnew *darwinarm-backend* *known-arm-backends* :key #'backend-name)
255
256(defvar *arm-backend* (car *known-arm-backends*))
257
258(defun fixup-arm-backend ()
259  (dolist (b *known-arm-backends*)
260    (setf (backend-lap-opcodes b) arm::*arm-instruction-table*
261          (backend-p2-dispatch b) *arm2-specials*
262          (backend-p2-vinsn-templates b)  *arm-vinsn-templates*)
263    (or (backend-lap-macros b) (setf (backend-lap-macros b)
264                                     (make-hash-table :test #'equalp)))))
265
266
267
268(fixup-arm-backend)
269
270#+arm-target
271(setq *host-backend* *arm-backend* *target-backend* *arm-backend*)
272
273(defun setup-arm-ftd (backend)
274  (or (backend-target-foreign-type-data backend)
275      (let* ((name (backend-name backend))
276             (ftd
277              (case name
278                (:darwinarm
279                 (make-ftd :interface-db-directory "ccl:darwin-arm-headers;"
280                           :interface-package-name "ARM-DARWIN"
281                           :attributes '(:bits-per-word  32
282                                         :signed-char t
283                                         :struct-by-value t
284                                         :prepend-underscore nil)
285                           :ff-call-expand-function
286                           (intern "EXPAND-FF-CALL" "ARM-DARWIN")
287                           :ff-call-struct-return-by-implicit-arg-function
288                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
289                                   "ARM-DARWIN")
290                           :callback-bindings-function
291                           (intern "GENERATE-CALLBACK-BINDINGS" "ARM-DARWIN")
292                           :callback-return-value-function
293                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-DARWIN")))
294                (:linuxarm
295                 (make-ftd :interface-db-directory "ccl:arm-headers;"
296                           :interface-package-name "ARM-LINUX"
297                           :attributes '(:bits-per-word  32
298                                         :signed-char nil
299                                         :struct-by-value t
300                                         :float-results-in-x87 t)
301                           :ff-call-expand-function
302                           (intern "EXPAND-FF-CALL" "ARM-LINUX")
303                           :ff-call-struct-return-by-implicit-arg-function
304                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
305                                   "ARM-LINUX")
306                           :callback-bindings-function
307                           (intern "GENERATE-CALLBACK-BINDINGS" "ARM-LINUX")
308                           :callback-return-value-function
309                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-LINUX"))))))
310        (install-standard-foreign-types ftd)
311        (use-interface-dir :libc ftd)
312        (setf (backend-target-foreign-type-data backend) ftd))))
313
314(pushnew *arm-backend* *known-backends* :key #'backend-name)
315
316#+notyet
317(require "ARM-VINSNS")
318
319
320
321
322             
323
324
325 
Note: See TracBrowser for help on using the repository browser.