source: branches/arm/compiler/ARM/arm-lap.lisp @ 14042

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

Split ARM instructions into two 16-bit halves, to try to reduce
incidental consing in the assembler.

File size: 9.3 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL 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
18(in-package "CCL")
19
20(eval-when (:compile-toplevel :load-toplevel :execute)
21  (require "ARM-ARCH")
22  (require "DLL-NODE")
23  (require "ARM-ASM")
24  (require "SUBPRIMS"))
25
26
27(defun arm-lap-macro-function (name)
28  (declare (special *arm-backend*))
29  (gethash (string name) (backend-lap-macros *arm-backend*)))
30
31(defun (setf arm-lap-macro-function) (def name)
32  (declare (special *arm-backend*))
33  (let* ((s (string name)))
34    (when (gethash s arm::*arm-instruction-ordinals*)
35      (error "~s already defines an arm instruction . " name))
36    (setf (gethash s (backend-lap-macros *arm-backend*)) def)))
37
38(defmacro defarmlapmacro (name arglist &body body)
39  `(progn
40     (setf (arm-lap-macro-function ',name)
41           (nfunction (arm-lap-macro ,name) ,(parse-macro name arglist body)))
42     (record-source-file ',name 'arm-lap)
43     ',name))
44
45(defvar *arm-lap-lfun-bits* 0)
46
47
48
49
50
51
52(defun arm-lap-macroexpand-1 (form)
53  (unless (and (consp form) (atom (car form)))
54    (values form nil))
55  (let* ((expander (arm-lap-macro-function (car form))))
56    (if expander
57      (values (funcall expander form nil) t)
58      (values form nil))))
59
60
61
62
63
64(defun %define-arm-lap-function (name body &optional (bits 0))
65  (with-dll-node-freelist (primary arm::*lap-instruction-freelist*)
66    (with-dll-node-freelist (constant-pool arm::*lap-instruction-freelist*)
67      (let* ((arm::*lap-labels* ())
68             (arm::*last-constant-pool-origin* ())
69             (name-cell (list name))
70             (arm::*arm-constants* ())
71             (*arm-lap-lfun-bits* bits)
72             (arm::*arm-register-names* arm::*standard-arm-register-names*)
73             (arm::*called-subprim-jmp-labels* ())
74             (current primary)
75             (sections (vector primary constant-pool)))
76        (declare (dynamic-extent sections))
77        (dolist (form body)
78          (setq current (arm-lap-form form current sections)))
79        (rplacd name-cell (length arm::*arm-constants*))
80        (push name-cell arm::*arm-constants*)
81        (arm-lap-generate-code primary
82                               (arm::arm-finalize primary  constant-pool)
83                               *arm-lap-lfun-bits*)))))
84
85
86
87#+big-endian-host
88(defun set-arm-code-vector-word (code-vector i insn)
89  (setf (uvref code-vector i)
90        (logior (ash (arm::lap-instruction-opcode-high insn) 16)
91                         (arm::lap-instruction-opcode-low insn))))
92
93#+little-endian-host
94(defun set-arm-code-vector-word (code-vector i insn)
95  (declare (type (simple-array (unsigned-byte 16) (*)) code-vector)
96           (fixnum i)
97           (optimize (speed 3) (safety 0)))
98  (let* ((j (+ i i)))
99    (declare (fixnum j))
100    (setf (aref code-vector j) (arm::lap-instruction-opcode-low insn)
101          (aref code-vector (the fixnum (1+ j)))
102          (arm::lap-instruction-opcode-high insn))))
103   
104 
105
106
107
108(defun arm-lap-generate-code (seg code-vector-size bits)
109  (declare (fixnum code-vector-size))
110  (let* ((target-backend *target-backend*)
111         (cross-compiling (target-arch-case
112                           (:arm (not (eq *host-backend* target-backend)))
113                           (t t)))
114         (constants-size (+ 3 (length arm::*arm-constants*)))
115         (constants-vector (%alloc-misc
116                            constants-size
117                            (if cross-compiling
118                              target::subtag-xfunction
119                              target::subtag-function)))
120         (i 0))
121    (declare (fixnum i constants-size))
122    (let* ((code-vector (%alloc-misc
123                         code-vector-size
124                         (if cross-compiling
125                           target::subtag-xcode-vector
126                           arm::subtag-code-vector))))
127      (do-dll-nodes (insn seg)
128        (unless (eql (arm::instruction-element-size insn) 0)
129          (set-arm-code-vector-word code-vector i insn)
130          (incf i)))
131      (dolist (immpair arm::*arm-constants*)
132        (let* ((imm (car immpair))
133               (k (cdr immpair)))
134          (declare (fixnum k))
135          (setf (uvref constants-vector (+ 2 k)) imm)))
136      (setf (uvref constants-vector (1- constants-size)) bits ; lfun-bits
137            (uvref constants-vector 1) code-vector
138            (uvref constants-vector 0) (ash (arm::arm-subprimitive-address '.SPfix-nfn-entrypoint) (- arm::fixnumshift)))
139      #+arm-target (%make-code-executable code-vector)
140      constants-vector)))
141
142(defun arm-lap-pseudo-op (directive arg current sections)
143  (flet ((check-usage (directive)
144           (unless (eq current (svref sections 1))
145             (error "~s directive should only be used inside :data section" directive))))
146    (ecase directive
147      (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list arg)))
148      (:data
149       (setq current (svref sections 1)))
150      (:code
151       (setq current (svref sections 0)))
152      (:section
153       (setq current (svref sections
154                            (ecase arg
155                              (:code 0)
156                              (:data 1)))))
157      (:word
158       (check-usage :word)
159       (arm::emit-lap-instruction-element
160        (let* ((insn (arm::make-lap-instruction nil)))
161          (arm::set-field-value insn (byte 32 0)  (logand #xffffffff (eval arg)))
162          insn)
163        current))
164     
165      (:single
166       (check-usage :single)
167       (arm::emit-lap-instruction-element
168        (let* ((insn (arm::make-lap-instruction nil)))
169          (arm::set-field-value insn (byte 32 0) (single-float-bits (float (eval arg) 0.0f0)))
170          insn)
171        current))
172      (:double
173       (check-usage :double)
174       (multiple-value-bind (high low) (double-float-bits (float (eval arg) 0.0d0))
175         (let* ((insnlow (arm::make-lap-instruction nil))
176                (insnhigh (arm::make-lap-instruction nil)))
177           (arm::set-field-value insnlow (byte 32 0) low)
178           (arm::set-field-value insnhigh (byte 32 0) high)
179           (arm::emit-lap-instruction-element insnlow current)
180           (arm::emit-lap-instruction-element insnhigh current)))))
181    current))
182       
183
184       
185(defun arm-lap-form (form current sections)
186  (if (and form (symbolp form))
187    (arm::emit-lap-label current form)
188    (if (or (atom form) (not (symbolp (car form))))
189      (error "~& unknown ARM-LAP form: ~S ." form)
190      (multiple-value-bind (expansion expanded)
191                           (arm-lap-macroexpand-1 form)
192        (if expanded
193          (setq current (arm-lap-form expansion current sections))
194          (let* ((name (car form)))
195            (if (keywordp name)
196              (setq current (arm-lap-pseudo-op name (cadr form) current sections))
197              (case name
198                ((progn) (dolist (f (cdr form)) (setq current (arm-lap-form f current sections))))
199                ((let) (setq current (arm-lap-equate-form (cadr form) (cddr form) current sections)))
200                (t
201                 (arm::assemble-instruction current form)))))))))
202  current)
203
204;;; (let ((name val) ...) &body body)
205;;; each "val" gets a chance to be treated as a ARM register name
206;;; before being evaluated.
207(defun arm-lap-equate-form (eqlist body current sections)
208  (collect ((symbols)
209            (values))
210    (let* ((arm::*arm-register-names* arm::*arm-register-names*))
211      (dolist (pair eqlist)
212        (destructuring-bind (symbol value) pair
213          (unless (and symbol
214                       (symbolp symbol)
215                       (not (constant-symbol-p symbol))
216                       (not (arm::get-arm-register symbol)))
217            (error "~s is not a bindable symbol name . " symbol))
218          (let* ((regval (and value
219                              (or (typep value 'symbol)
220                                  (typep value 'string))
221                              (arm::get-arm-register value))))
222            (if regval
223              (arm::define-arm-register symbol regval)
224              (progn
225                (symbols symbol)
226                (values (eval value)))))))
227
228    (progv (symbols) (values)
229      (dolist (form body current)
230        (setq current (arm-lap-form form current sections)))))))
231
232
233
234
235
236
237
238
239(defmacro defarmlapfunction (&environment env name arglist &body body
240                             &aux doc)
241  (if (not (endp body))
242      (and (stringp (car body))
243           (cdr body)
244           (setq doc (car body))
245           (setq body (cdr body))))
246  `(progn
247     (eval-when (:compile-toplevel)
248       (note-function-info ',name t ,env))
249     #-arm-target
250     (progn
251       (eval-when (:load-toplevel)
252         (%defun (nfunction ,name (lambda (&lap 0) (arm-lap-function ,name ,arglist ,@body))) ,doc))
253       (eval-when (:execute)
254         (%define-arm-lap-function ',name '((let ,arglist ,@body)))))
255     #+arm-target       ; just shorthand for defun
256     (%defun (nfunction ,name (lambda (&lap 0) (arm-lap-function ,name ,arglist ,@body))) ,doc)))
257 
258
259
260(provide "ARM-LAP")
Note: See TracBrowser for help on using the repository browser.