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

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

Keep moving forward. Can -almost- compile simple functions.

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