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

Last change on this file since 13705 was 13705, checked in by gb, 10 years ago

Keep inching forward, trying to work out assembler/LAP stuff, mostly.

File size: 16.7 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#+notyet
34(defun define-arm-vinsn (backend vinsn-name results args temps body)
35  (let* ((opcode-vector (backend-lap-opcodes backend))
36         (opcode-lookup (backend-lookup-opcode backend))
37         (opcode-expander (backend-lookup-macro backend))
38         (backend-name (backend-name backend))
39         (arch-name (backend-target-arch-name backend))
40         (template-hash (backend-p2-template-hash-name backend))
41         (name-list ())
42         (attrs 0)
43         (nhybrids 0)
44         (local-labels ())
45         (referenced-labels ())
46         (source-indicator (form-symbol arch-name "-VINSN"))
47         (opcode-alist ()))
48    (flet ((valid-spec-name (x)
49             (or (and (consp x) 
50                      (consp (cdr x)) 
51                      (null (cddr x)) 
52                      (atom (car x))
53                      (or (assoc (cadr x) *vreg-specifier-constant-constraints* :test #'eq)
54                          (assoc (cadr x) *spec-class-storage-class-alist* :test #'eq)
55                          (eq (cadr x) :label)
56                          (and (consp (cadr x))
57                               (or 
58                                (assoc (caadr x) *vreg-specifier-constant-constraints* :test #'eq)
59                                (assoc (caadr x) *spec-class-storage-class-alist* :test #'eq))))
60                      (car x))
61                 (error "Invalid vreg spec: ~s" x)))
62           (add-spec-name (vname) 
63             (if (member vname name-list :test #'eq)
64               (error "Duplicate name ~s in vinsn ~s" vname vinsn-name)
65               (push vname name-list))))
66      (declare (dynamic-extent #'valid-spec-name #'add-spec-name))
67      (when (consp vinsn-name)
68        (setq attrs (encode-vinsn-attributes (cdr vinsn-name))
69              vinsn-name (car vinsn-name)))
70      (unless (and (symbolp vinsn-name) (eq *CCL-PACKAGE* (symbol-package vinsn-name)))
71        (setq vinsn-name (intern (string vinsn-name) *CCL-PACKAGE*)))
72      (dolist (n (append args temps))
73        (add-spec-name (valid-spec-name n)))
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                                 form
170                                 (let* ((name (string opname))
171                                        (opnum (funcall opcode-lookup name)))
172                                   (if (and (not opnum) opcode-expander)
173                                     (let* ((expander (funcall opcode-expander name)))
174                                       (if expander
175                                         (simplify-form (funcall expander form nil))
176                                         (error "Unknown ~A instruction in ~s" backend-name form)))
177                                     (let* ((opcode (if (< -1 opnum (length opcode-vector))
178                                                      (svref opcode-vector opnum)
179                                                      (error "~& Invalid ~A opcode: ~s" backend-name name)))
180                                            (opvals (mapcar #'simplify-operand opvals)))
181                                       (setf (assq opnum opcode-alist) name)
182                                       (let* ((operands (opcode-vinsn-operands opcode))
183                                              (nmin (opcode-min-vinsn-args opcode))
184                                              (nmax (opcode-max-vinsn-args opcode))
185                                              (nhave (length opvals)))
186                                         (declare (fixnum nmin nmax nhave))
187                                         (if (= nhave nmax)
188                                           `(,opnum ,@opvals)
189                                           (if (> nhave nmax)
190                                             (error "Too many operands in ~s (~a accepts at most ~d)"
191                                                    (cdr w) name nmax)
192                                             (if (= nhave nmin)
193                                               (let* ((newops ()))
194                                                 (dolist (op operands `(,opnum ,@(nreverse newops)))
195                                                   (let* ((flags (operand-flags op)))
196                                                     (unless (logbitp operand-fake flags)
197                                                       (push (if (logbitp operand-optional flags)
198                                                               0
199                                                               (pop opvals))
200                                                             newops)))))
201                                               (error "Too few operands in ~s : (~a requires at least ~d)"
202                                                      (cdr w) name nmin))))))))))))))
203                (let* ((template (make-vinsn-template
204                                  :name vinsn-name
205                                  :result-vreg-specs results
206                                  :argument-vreg-specs args
207                                  :temp-vreg-specs temps
208                                  :nhybrids nhybrids
209                                  :results&args (append results (nthcdr nhybrids args))
210                                  :nvp (- (+ (length results) (length args) (length temps))
211                                          nhybrids)
212                                  :body (prog1 (mapcar #'simplify-form body)
213                                          (dolist (ref referenced-labels)
214                                            (unless (memq ref local-labels)
215                                              (error 
216                                               "local label ~S was referenced but never defined in VINSN-TEMPLATE definition for ~s" ref vinsn-name))))
217                                  :local-labels local-labels :attributes attrs :opcode-alist
218                                  opcode-alist)))
219                  `(progn (set-vinsn-template ',vinsn-name ,template
220                           ,template-hash) (record-source-file ',vinsn-name ',source-indicator)
221                    ',vinsn-name))))))))))
222
223
224
225(defvar *arm-vinsn-templates* (make-hash-table :test #'eq))
226
227
228
229
230(defvar *known-arm-backends* ())
231
232
233#+(or linuxarm-target (not arm-target))
234(defvar *linuxarm-backend*
235  (make-backend :lookup-opcode #'arm::lookup-arm-instruction
236                :lookup-macro #'false
237                :lap-opcodes arm::*arm-instruction-table*
238                :define-vinsn 'define-arm-vinsn
239                :platform-syscall-mask (logior platform-os-linux platform-cpu-arm)
240                :p2-dispatch *arm2-specials*
241                :p2-vinsn-templates *arm-vinsn-templates*
242                :p2-template-hash-name '*arm-vinsn-templates*
243                :p2-compile 'arm2-compile
244                :target-specific-features
245                '(:arm :arm-target :eabi-target :linux-target :linuxarm-target  :32-bit-target :little-endian-target)
246                :target-fasl-pathname (make-pathname :type "lafsl")
247                :target-platform (logior platform-word-size-32
248                                         platform-cpu-arm
249                                         platform-os-linux)
250                :target-os :linuxarm
251                :name :linuxarm
252                :target-arch-name :arm
253                :target-foreign-type-data nil
254                :target-arch arm::*arm-target-arch*))
255
256
257#+darwinarm-target
258(defvar *darwinarm-backend*
259  (make-backend :lookup-opcode #'lookup-arm-opcode
260                :lookup-macro #'arm::arm-macro-function
261                :lap-opcodes arm::*arm-opcodes*
262                :define-vinsn 'define-arm-vinsn
263                :platform-syscall-mask (logior platform-os-darwin platform-cpu-arm)               
264                :p2-dispatch *arm2-specials*
265                :p2-vinsn-templates *arm-vinsn-templates*
266                :p2-template-hash-name '*arm-vinsn-templates*
267                :p2-compile 'arm2-compile
268                :target-specific-features
269                '(:powerpc :arm-target :darwin-target :darwinarm-target :arm-target :32-bit-target :big-endian-target)
270                :target-fasl-pathname (make-pathname :type "dfsl")
271                :target-platform (logior platform-word-size-32
272                                         platform-cpu-arm
273                                         platform-os-darwin)
274                :target-os :darwinarm
275                :name :darwinarm
276                :target-arch-name :arm
277                :target-foreign-type-data nil
278                :target-arch arm::*arm-target-arch*))
279
280#+(or linuxarm-target (not arm-target))
281(pushnew *linuxarm-backend* *known-arm-backends* :key #'backend-name)
282
283
284#+darwinarm-target
285(pushnew *darwinarm-backend* *known-arm-backends* :key #'backend-name)
286
287(defvar *arm-backend* (car *known-arm-backends*))
288
289(defun fixup-arm-backend ()
290  (dolist (b *known-arm-backends*)
291    (setf (backend-lap-opcodes b) arm::*arm-instruction-table*
292          (backend-p2-dispatch b) *arm2-specials*
293          (backend-p2-vinsn-templates b)  *arm-vinsn-templates*)
294    (or (backend-lap-macros b) (setf (backend-lap-macros b)
295                                     (make-hash-table :test #'equalp)))))
296
297
298
299(fixup-arm-backend)
300
301#+arm-target
302(setq *host-backend* *arm-backend* *target-backend* *arm-backend*)
303
304(defun setup-arm-ftd (backend)
305  (or (backend-target-foreign-type-data backend)
306      (let* ((name (backend-name backend))
307             (ftd
308              (case name
309                (:darwinarm
310                 (make-ftd :interface-db-directory "ccl:darwin-arm-headers;"
311                           :interface-package-name "ARM-DARWIN"
312                           :attributes '(:bits-per-word  32
313                                         :signed-char t
314                                         :struct-by-value t
315                                         :prepend-underscore nil)
316                           :ff-call-expand-function
317                           (intern "EXPAND-FF-CALL" "ARM-DARWIN")
318                           :ff-call-struct-return-by-implicit-arg-function
319                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
320                                   "ARM-DARWIN")
321                           :callback-bindings-function
322                           (intern "GENERATE-CALLBACK-BINDINGS" "ARM-DARWIN")
323                           :callback-return-value-function
324                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-DARWIN")))
325                (:linuxarm
326                 (make-ftd :interface-db-directory "ccl:arm-headers;"
327                           :interface-package-name "ARM-LINUX"
328                           :attributes '(:bits-per-word  32
329                                         :signed-char nil
330                                         :struct-by-value t
331                                         :float-results-in-x87 t)
332                           :ff-call-expand-function
333                           (intern "EXPAND-FF-CALL" "ARM-LINUX")
334                           :ff-call-struct-return-by-implicit-arg-function
335                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
336                                   "ARM-LINUX")
337                           :callback-bindings-function
338                           (intern "GENERATE-CALLBACK-BINDINGS" "ARM-LINUX")
339                           :callback-return-value-function
340                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-LINUX"))))))
341        (install-standard-foreign-types ftd)
342        (use-interface-dir :libc ftd)
343        (setf (backend-target-foreign-type-data backend) ftd))))
344
345(pushnew *arm-backend* *known-backends* :key #'backend-name)
346
347#+notyet
348(require "ARM-VINSNS")
349
350
351
352
353             
354
355
356 
Note: See TracBrowser for help on using the repository browser.