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

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

Yet another scheme for subprim calls. Go ahead and laugh.
Details:

  • ba/bla are new pseudo instructions, identical to b/bl except that their operands are subprim names (or addresses).
  • for each subprim name/address referenced in a ba/bla instruction, the assembler generates an:

(ldr pc (:= data-word-containing-subprim-address))

instruction and makes the ba/bla branch to that instruction.

  • this is the only use of the "constant pool" and there are no longer user-visible directives for referencing pc-relative data. (We can load 32-bit integer constants via movw/movt instructions and initialize FPRs to constants via GPRs.)
  • by default, the disassembler hides this and shows ba/bla instructions.

Compared to the scheme of a few days ago, it's about the same speed
(b/bl to LDR vs mov reg/bx reg). If a subprim's called once per function
it's a little bigger; if there's more than one call site, it can be smaller.
(And we don't have to find a temp register.) If we can map the subprims
to addresses within 32MB of the pure area, then purify can turn the PC-relative
branches/bls to the LDR instructions into direct branches/bls to the code.

Compared to the original scheme (branch/bl to mov pc, #n) we don't flush
the pipeline on every call and don't have any constraints on subprimitive
addresses (they don't have to be expressible as ARM constants.)

File size: 7.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      (let* ((arm::*lap-labels* ())
67             (arm::*called-subprim-jmp-labels* ())
68             (name-cell (list name))
69             (arm::*arm-constants* ())
70             (*arm-lap-lfun-bits* bits)
71             (arm::*arm-register-names* arm::*standard-arm-register-names*))
72        (dolist (form body)
73          (arm-lap-form form primary))
74        (rplacd name-cell (length arm::*arm-constants*))
75        (push name-cell arm::*arm-constants*)
76        (arm-lap-generate-code primary
77                               (arm::arm-finalize primary)
78                               *arm-lap-lfun-bits*))))
79
80
81
82#+big-endian-host
83(defun set-arm-code-vector-word (code-vector i insn)
84  (setf (uvref code-vector i)
85        (logior (ash (arm::lap-instruction-opcode-high insn) 16)
86                         (arm::lap-instruction-opcode-low insn))))
87
88#+little-endian-host
89(defun set-arm-code-vector-word (code-vector i insn)
90  (declare (type (simple-array (unsigned-byte 16) (*)) code-vector)
91           (fixnum i)
92           (optimize (speed 3) (safety 0)))
93  (let* ((j (+ i i)))
94    (declare (fixnum j))
95    (setf (aref code-vector j) (arm::lap-instruction-opcode-low insn)
96          (aref code-vector (the fixnum (1+ j)))
97          (arm::lap-instruction-opcode-high insn))))
98   
99 
100
101
102
103(defun arm-lap-generate-code (seg code-vector-size bits)
104  (declare (fixnum code-vector-size))
105  (let* ((target-backend *target-backend*)
106         (cross-compiling (target-arch-case
107                           (:arm (not (eq *host-backend* target-backend)))
108                           (t t)))
109         (constants-size (+ 3 (length arm::*arm-constants*)))
110         (constants-vector (%alloc-misc
111                            constants-size
112                            (if cross-compiling
113                              target::subtag-xfunction
114                              target::subtag-function)))
115         (i 0))
116    (declare (fixnum i constants-size))
117    (let* ((code-vector (%alloc-misc
118                         code-vector-size
119                         (if cross-compiling
120                           target::subtag-xcode-vector
121                           arm::subtag-code-vector))))
122      (do-dll-nodes (insn seg)
123        (unless (eql (arm::instruction-element-size insn) 0)
124          (set-arm-code-vector-word code-vector i insn)
125          (incf i)))
126      (dolist (immpair arm::*arm-constants*)
127        (let* ((imm (car immpair))
128               (k (cdr immpair)))
129          (declare (fixnum k))
130          (setf (uvref constants-vector (+ 2 k)) imm)))
131      (setf (uvref constants-vector (1- constants-size)) bits ; lfun-bits
132            (uvref constants-vector 1) code-vector
133            (uvref constants-vector 0) (ash (arm::arm-subprimitive-address '.SPfix-nfn-entrypoint) (- arm::fixnumshift)))
134      #+arm-target (%make-code-executable code-vector)
135      constants-vector)))
136
137(defun arm-lap-pseudo-op (directive arg)
138  (ecase directive
139    (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list arg)))))
140       
141
142       
143(defun arm-lap-form (form seg)
144  (if (and form (symbolp form))
145    (arm::emit-lap-label seg form)
146    (if (or (atom form) (not (symbolp (car form))))
147      (error "~& unknown ARM-LAP form: ~S ." form)
148      (multiple-value-bind (expansion expanded)
149                           (arm-lap-macroexpand-1 form)
150        (if expanded
151          (arm-lap-form expansion seg)
152          (let* ((name (car form)))
153            (if (keywordp name)
154              (arm-lap-pseudo-op name (cadr form))
155              (case name
156                ((progn) (dolist (f (cdr form)) (arm-lap-form f seg)))
157                ((let) (arm-lap-equate-form (cadr form) (cddr form) seg))
158                (t
159                 (arm::assemble-instruction seg form))))))))))
160
161;;; (let ((name val) ...) &body body)
162;;; each "val" gets a chance to be treated as a ARM register name
163;;; before being evaluated.
164(defun arm-lap-equate-form (eqlist body seg)
165  (collect ((symbols)
166            (values))
167    (let* ((arm::*arm-register-names* arm::*arm-register-names*))
168      (dolist (pair eqlist)
169        (destructuring-bind (symbol value) pair
170          (unless (and symbol
171                       (symbolp symbol)
172                       (not (constant-symbol-p symbol))
173                       (not (arm::get-arm-register symbol)))
174            (error "~s is not a bindable symbol name . " symbol))
175          (let* ((regval (and value
176                              (or (typep value 'symbol)
177                                  (typep value 'string))
178                              (arm::get-arm-register value))))
179            (if regval
180              (arm::define-arm-register symbol regval)
181              (progn
182                (symbols symbol)
183                (values (eval value)))))))
184
185    (progv (symbols) (values)
186      (dolist (form body)
187        (arm-lap-form form seg))))))
188
189
190
191
192
193
194
195
196(defmacro defarmlapfunction (&environment env name arglist &body body
197                             &aux doc)
198  (if (not (endp body))
199      (and (stringp (car body))
200           (cdr body)
201           (setq doc (car body))
202           (setq body (cdr body))))
203  `(progn
204     (eval-when (:compile-toplevel)
205       (note-function-info ',name t ,env))
206     #-arm-target
207     (progn
208       (eval-when (:load-toplevel)
209         (%defun (nfunction ,name (lambda (&lap 0) (arm-lap-function ,name ,arglist ,@body))) ,doc))
210       (eval-when (:execute)
211         (%define-arm-lap-function ',name '((let ,arglist ,@body)))))
212     #+arm-target       ; just shorthand for defun
213     (%defun (nfunction ,name (lambda (&lap 0) (arm-lap-function ,name ,arglist ,@body))) ,doc)))
214 
215
216
217(provide "ARM-LAP")
Note: See TracBrowser for help on using the repository browser.