1 ;;;; a bunch of handy macros for the ARM
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;; Instruction-like macros.
16 (defmacro move
(dst src
&optional
(predicate :al
))
17 "Move SRC into DST unless they are location=."
18 (once-only ((n-dst dst
)
20 `(unless (location= ,n-dst
,n-src
)
21 (inst mov
,predicate
,n-dst
,n-src
))))
25 (let ((real-tn-fn (symbolicate 'complex- type
'-reg-real-tn
))
26 (imag-tn-fn (symbolicate 'complex- type
'-reg-imag-tn
)))
28 (defmacro ,(symbolicate 'move- type
)
29 (dst src
&optional
(predicate :al
))
30 (once-only ((n-dst dst
)
32 `(unless (location= ,n-dst
,n-src
)
33 (inst ,',inst
,predicate
,n-dst
,n-src
))))
34 (defmacro ,(symbolicate 'move-complex- type
)
35 (dst src
&optional
(predicate :al
))
36 (once-only ((n-dst dst
)
38 `(unless (location= ,n-dst
,n-src
)
39 ;; Note that the complex (single and double) float
40 ;; registers are aligned to paired underlying
41 ;; (single and double) registers, so there is no
42 ;; need to worry about overlap.
43 (let ((src-real (,',real-tn-fn
,n-src
))
44 (dst-real (,',real-tn-fn
,n-dst
)))
45 (inst ,',inst
,predicate dst-real src-real
))
46 (let ((src-imag (,',imag-tn-fn
,n-src
))
47 (dst-imag (,',imag-tn-fn
,n-dst
)))
48 (inst ,', inst
,predicate dst-imag src-imag
)))))))))
54 `(defmacro ,op
(object base
55 &optional
(offset 0) (lowtag 0) (predicate :al
))
56 `(inst ,',inst
,predicate
,object
57 (@ ,base
(- (ash ,offset
,,shift
) ,lowtag
))))))
58 (def loadw ldr word-shift
)
59 (def storew str word-shift
))
61 (defmacro load-symbol
(reg symbol
)
62 (once-only ((reg reg
) (symbol symbol
))
64 (composite-immediate-instruction add
,reg null-tn
(static-symbol-offset ,symbol
)))))
66 (defmacro load-symbol-value
(reg symbol
&optional
(predicate :al
))
67 `(inst ldr
,predicate
,reg
69 (+ (static-symbol-offset ',symbol
)
70 (ash symbol-value-slot word-shift
)
71 (- other-pointer-lowtag
)))))
73 (defmacro store-symbol-value
(reg symbol
&optional
(predicate :al
))
74 `(inst str
,predicate
,reg
76 (+ (static-symbol-offset ',symbol
)
77 (ash symbol-value-slot word-shift
)
78 (- other-pointer-lowtag
)))))
80 (defmacro load-type
(target source
&optional
(offset 0) (predicate :al
))
81 "Loads the type bits of a pointer into target independent of
82 byte-ordering issues."
83 (once-only ((n-target target
)
86 (let ((target-offset (ecase *backend-byte-order
*
87 (:little-endian n-offset
)
88 (:big-endian
`(+ ,n-offset
(1- n-word-bytes
))))))
89 `(inst ldrb
,predicate
,n-target
(@ ,n-source
,target-offset
)))))
91 ;;; Macros to handle the fact that our stack pointer isn't actually in
92 ;;; a register (or won't be, by the time we're done).
94 (defmacro load-csp
(target &optional
(predicate :al
))
95 `(load-symbol-value ,target
*control-stack-pointer
* ,predicate
))
97 (defmacro store-csp
(source &optional
(predicate :al
))
98 `(store-symbol-value ,source
*control-stack-pointer
* ,predicate
))
100 ;;; Macros to handle the fact that we cannot use the machine native call and
101 ;;; return instructions.
103 (defmacro lisp-jump
(function)
104 "Jump to the lisp function FUNCTION."
105 `(inst add pc-tn
,function
106 (- (ash simple-fun-code-offset word-shift
)
107 fun-pointer-lowtag
)))
109 (defmacro lisp-return
(return-pc return-style
)
110 "Return to RETURN-PC."
112 ;; Indicate a single-valued return by clearing all of the status
113 ;; flags, or a multiple-valued return by setting all of the status
116 (:single-value
'(inst msr
(cpsr :f
) 0))
117 (:multiple-values
'(inst msr
(cpsr :f
) #xf0000000
))
119 #+(or) ;; Doesn't work, can't have a negative immediate value.
120 (inst add pc-tn
,return-pc
(- 4 other-pointer-lowtag
))
121 (inst sub pc-tn
,return-pc
(- other-pointer-lowtag
4))))
123 (defmacro emit-return-pc
(label)
124 "Emit a return-pc header word. LABEL is the label to use for this return-pc."
126 (emit-alignment n-lowtag-bits
)
128 (inst lra-header-word
)))
133 ;;; Move a stack TN to a register and vice-versa.
134 (defmacro load-stack-tn
(reg stack
&optional
(predicate :al
))
137 (let ((offset (tn-offset stack
)))
140 (loadw reg cfp-tn offset
0 ,predicate
))))))
141 (defmacro store-stack-tn
(stack reg
&optional
(predicate :al
))
142 `(let ((stack ,stack
)
144 (let ((offset (tn-offset stack
)))
147 (storew reg cfp-tn offset
0 ,predicate
))))))
149 (defmacro maybe-load-stack-tn
(reg reg-or-stack
)
150 "Move the TN Reg-Or-Stack into Reg if it isn't already there."
151 (once-only ((n-reg reg
)
152 (n-stack reg-or-stack
))
154 ((any-reg descriptor-reg
)
156 ((any-reg descriptor-reg
)
157 (move ,n-reg
,n-stack
))
159 (loadw ,n-reg cfp-tn
(tn-offset ,n-stack
))))))))
161 ;;;; Storage allocation:
164 ;;; This is the main mechanism for allocating memory in the lisp heap.
166 ;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
167 ;;; applied. The amount of space to be allocated is SIZE bytes (which
168 ;;; must be a multiple of the lisp object size).
170 ;;; Each platform seems to have its own slightly different way to do
171 ;;; heap allocation, taking various different options as parameters.
172 ;;; For ARM, we take the bare minimum parameters, RESULT-TN, SIZE, and
173 ;;; LOWTAG, and we require a single temporary register called FLAG-TN
174 ;;; to emphasize the parallelism with PSEUDO-ATOMIC (which must
175 ;;; surround a call to ALLOCATION anyway), and to indicate that the
176 ;;; P-A FLAG-TN is also acceptable here.
178 (defmacro allocation
(result-tn size lowtag
&key flag-tn
)
179 ;; Normal allocation to the heap.
180 (let ((alloc-size (gensym)))
181 `(let ((,alloc-size
,size
))
182 (load-symbol-value ,flag-tn
*allocation-pointer
*)
183 (inst add
,result-tn
,flag-tn
,lowtag
)
184 (inst add
,flag-tn
,flag-tn
,alloc-size
)
185 (store-symbol-value ,flag-tn
*allocation-pointer
*))))
187 (defmacro with-fixed-allocation
((result-tn flag-tn type-code size
188 &key
(lowtag other-pointer-lowtag
))
190 "Do stuff to allocate an other-pointer object of fixed Size with a single
191 word header having the specified Type-Code. The result is placed in
192 Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
193 by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably
194 initializes the object."
195 (once-only ((result-tn result-tn
) (flag-tn flag-tn
)
196 (type-code type-code
) (size size
) (lowtag lowtag
))
197 `(pseudo-atomic (,flag-tn
)
198 (allocation ,result-tn
(pad-data-block ,size
) ,lowtag
201 (inst mov
,flag-tn
(ash (1- ,size
) n-widetag-bits
))
202 (inst orr
,flag-tn
,flag-tn
,type-code
)
203 (storew ,flag-tn
,result-tn
0 ,lowtag
))
207 (defun emit-error-break (vop kind code values
)
210 (note-this-location vop
:internal-error
))
211 ;; Use the magic officially-undefined instruction that Linux
212 ;; treats as generating SIGTRAP.
214 ;; The rest of this is "just" the encoded error details.
216 (with-adjustable-vector (vector)
217 (write-var-integer code vector
)
219 (write-var-integer (make-sc-offset (sc-number (tn-sc tn
))
220 (or (tn-offset tn
) 0))
222 (inst byte
(length vector
))
223 (dotimes (i (length vector
))
224 (inst byte
(aref vector i
)))
225 (emit-alignment word-shift
))))
227 (defun error-call (vop error-code
&rest values
)
229 "Cause an error. ERROR-CODE is the error to cause."
230 (emit-error-break vop error-trap
(error-number-or-lose error-code
) values
))
232 (defun generate-error-code (vop error-code
&rest values
)
234 "Generate-Error-Code Error-code Value*
235 Emit code for an error with the specified Error-Code and context Values."
236 (assemble (*elsewhere
*)
237 (let ((start-lab (gen-label)))
238 (emit-label start-lab
)
239 (emit-error-break vop error-trap
(error-number-or-lose error-code
) values
)
244 ;;; handy macro for making sequences look atomic
246 ;;; FLAG-TN must be wired to R7. If a deferred interrupt happens
247 ;;; while we have *PSEUDO-ATOMIC* set to non-nil, then
248 ;;; *PSEUDO-ATOMIC-INTERRUPTED* will be changed from NIL to the fixnum
249 ;;; #x000f0001 (so, #x003c0004), which is the syscall number for
250 ;;; BREAK_POINT. This value is less than #x0800000b (NIL). The
251 ;;; runtime "knows" that an SWI with a condition code of :LT instead
252 ;;; of the normal :AL is a pseudo-atomic interrupted trap.
253 (defmacro pseudo-atomic
((flag-tn) &body forms
)
255 (aver (and (sc-is ,flag-tn non-descriptor-reg
)
256 (= (tn-offset ,flag-tn
) 7)))
257 (without-scheduling ()
258 (store-symbol-value pc-tn
*pseudo-atomic-atomic
*))
261 (without-scheduling ()
262 (store-symbol-value null-tn
*pseudo-atomic-atomic
*)
263 (load-symbol-value ,flag-tn
*pseudo-atomic-interrupted
*)
264 (inst cmp
,flag-tn null-tn
)
265 (inst mov
:lt
,flag-tn
(lsr ,flag-tn n-fixnum-tag-bits
))
268 ;;;; memory accessor vop generators
270 (defmacro define-full-reffer
(name type offset lowtag scs el-type
274 `((:translate
,translate
)))
276 (:args
(object :scs
(descriptor-reg))
277 (index :scs
(any-reg)))
278 (:arg-types
,type tagged-num
)
279 (:temporary
(:scs
(interior-reg)) lip
)
280 (:results
(value :scs
,scs
))
281 (:result-types
,el-type
)
283 (inst add lip object index
)
284 (loadw value lip
,offset
,lowtag
))))
286 (defmacro define-full-setter
(name type offset lowtag scs el-type
290 `((:translate
,translate
)))
292 (:args
(object :scs
(descriptor-reg))
293 (index :scs
(any-reg))
294 (value :scs
,scs
:target result
))
295 (:arg-types
,type tagged-num
,el-type
)
296 (:temporary
(:scs
(interior-reg)) lip
)
297 (:results
(result :scs
,scs
))
298 (:result-types
,el-type
)
300 (inst add lip object index
)
301 (storew value lip
,offset
,lowtag
)
302 (move result value
))))
304 (defmacro define-partial-reffer
(name type size signed offset lowtag scs
305 el-type
&optional translate
)
308 `((:translate
,translate
)))
310 (:args
(object :scs
(descriptor-reg))
311 (index :scs
(unsigned-reg)))
312 (:arg-types
,type positive-fixnum
)
313 (:results
(value :scs
,scs
))
314 (:result-types
,el-type
)
315 (:temporary
(:scs
(interior-reg)) lip
)
318 '(inst add lip object index
)
319 '(inst add lip object
(lsl index
1)))
321 (:byte
(if signed
'ldrsb
'ldrb
))
322 (:short
(if signed
'ldrsh
'ldrh
)))
323 value
(@ lip
(- (* ,offset n-word-bytes
) ,lowtag
))))))
325 (defmacro define-partial-setter
(name type size offset lowtag scs el-type
329 `((:translate
,translate
)))
331 (:args
(object :scs
(descriptor-reg))
332 (index :scs
(unsigned-reg))
333 (value :scs
,scs
:target result
))
334 (:arg-types
,type positive-fixnum
,el-type
)
335 (:temporary
(:scs
(interior-reg)) lip
)
336 (:results
(result :scs
,scs
))
337 (:result-types
,el-type
)
340 '(inst add lip object index
)
341 '(inst add lip object
(lsl index
1)))
342 (inst ,(ecase size
(:byte
'strb
) (:short
'strh
))
343 value
(@ lip
(- (* ,offset n-word-bytes
) ,lowtag
)))
344 (move result value
))))
346 (def!macro with-pinned-objects
((&rest objects
) &body body
)
347 "Arrange with the garbage collector that the pages occupied by
348 OBJECTS will not be moved in memory for the duration of BODY.
349 Useful for e.g. foreign calls where another thread may trigger
350 garbage collection. This is currently implemented by disabling GC"
351 (declare (ignore objects
)) ;should we eval these for side-effect?