source: trunk/source/compiler/ARM/arm-backend.lisp @ 14222

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

Don't "naturally" align a record field if the field type's natural
alignment is greater than the word size (unless the ftd has a
:natural-alignment attribute.)

The ARM always aligns fields on natural boundaries; PPC32 and X8632
don't. (In other words, this has been wrong for years.)

If we ever support (SIMD) vector types, this'll have to be revisited.

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