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

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

Ensure that the entryoint of newly-created functions goes to
.SPfix-nfn-entrypoint.

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