1 ;;;; a bunch of handy macros for the PPC
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
)
17 "Move SRC into DST unless they are location=."
18 (once-only ((n-dst dst
)
20 `(unless (location= ,n-dst
,n-src
)
21 (inst mr
,n-dst
,n-src
))))
25 `(defmacro ,op
(object base
&optional
(offset 0) (lowtag 0))
26 `(inst ,',inst
,object
,base
(- (ash ,offset
,,shift
) ,lowtag
)))))
27 (def loadw lwz word-shift
)
28 (def storew stw word-shift
))
30 (defmacro load-symbol
(reg symbol
)
31 `(inst addi
,reg null-tn
(static-symbol-offset ,symbol
)))
35 (let ((loader (intern (concatenate 'simple-string
38 (storer (intern (concatenate 'simple-string
41 (offset (intern (concatenate 'simple-string
45 (find-package "SB!VM"))))
47 (defmacro ,loader
(reg symbol
)
48 `(inst lwz
,reg null-tn
49 (+ (static-symbol-offset ',symbol
)
50 (ash ,',offset word-shift
)
51 (- other-pointer-lowtag
))))
52 (defmacro ,storer
(reg symbol
)
53 `(inst stw
,reg null-tn
54 (+ (static-symbol-offset ',symbol
)
55 (ash ,',offset word-shift
)
56 (- other-pointer-lowtag
))))))))
60 ;; FIXME: These are only good for static-symbols, so why not
61 ;; statically-allocate the static-symbol TLS slot indices at
62 ;; cross-compile time so we can just use a fixed offset within the
63 ;; TLS block instead of mucking about with the extra memory access
64 ;; (and temp register, for stores)?
66 (defmacro load-tl-symbol-value
(reg symbol
)
68 (inst lwz
,reg null-tn
69 (+ (static-symbol-offset ',symbol
)
70 (ash symbol-tls-index-slot word-shift
)
71 (- other-pointer-lowtag
)))
72 (inst lwzx
,reg thread-base-tn
,reg
)))
74 (defmacro load-tl-symbol-value
(reg symbol
)
75 `(load-symbol-value ,reg
,symbol
))
78 (defmacro store-tl-symbol-value
(reg symbol temp
)
80 (inst lwz
,temp null-tn
81 (+ (static-symbol-offset ',symbol
)
82 (ash symbol-tls-index-slot word-shift
)
83 (- other-pointer-lowtag
)))
84 (inst stwx
,reg thread-base-tn
,temp
)))
86 (defmacro store-tl-symbol-value
(reg symbol temp
)
87 (declare (ignore temp
))
88 `(store-symbol-value ,reg
,symbol
)))
90 (defmacro load-type
(target source
&optional
(offset 0))
91 "Loads the type bits of a pointer into target independent of
92 byte-ordering issues."
93 (once-only ((n-target target
)
96 (ecase *backend-byte-order
*
98 `(inst lbz
,n-target
,n-source
,n-offset
))
100 `(inst lbz
,n-target
,n-source
(+ ,n-offset
(1- n-word-bytes
)))))))
102 ;;; Macros to handle the fact that we cannot use the machine native call and
103 ;;; return instructions.
105 (defmacro lisp-jump
(function lip
)
106 "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
108 ;; something is deeply bogus. look at this
109 ;; (loadw ,lip ,function function-code-offset function-pointer-type)
110 (inst addi
,lip
,function
(- (* n-word-bytes simple-fun-code-offset
) fun-pointer-lowtag
))
114 (defmacro lisp-return
(return-pc lip
&key
(offset 0))
115 "Return to RETURN-PC."
117 (inst addi
,lip
,return-pc
(- (* (1+ ,offset
) n-word-bytes
) other-pointer-lowtag
))
121 (defmacro emit-return-pc
(label)
122 "Emit a return-pc header word. LABEL is the label to use for this return-pc."
124 (emit-alignment n-lowtag-bits
)
126 (inst lra-header-word
)))
132 ;;; Move a stack TN to a register and vice-versa.
133 (defmacro load-stack-tn
(reg stack
)
136 (let ((offset (tn-offset stack
)))
139 (loadw reg cfp-tn offset
))))))
140 (defmacro store-stack-tn
(stack reg
)
141 `(let ((stack ,stack
)
143 (let ((offset (tn-offset stack
)))
146 (storew reg cfp-tn offset
))))))
148 (defmacro maybe-load-stack-tn
(reg reg-or-stack
)
149 "Move the TN Reg-Or-Stack into Reg if it isn't already there."
150 (once-only ((n-reg reg
)
151 (n-stack reg-or-stack
))
153 ((any-reg descriptor-reg
)
155 ((any-reg descriptor-reg
)
156 (move ,n-reg
,n-stack
))
158 (loadw ,n-reg cfp-tn
(tn-offset ,n-stack
))))))))
161 ;;;; Storage allocation:
163 ;;; This is the main mechanism for allocating memory in the lisp heap.
165 ;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
166 ;;; applied. The amount of space to be allocated is SIZE bytes (which
167 ;;; must be a multiple of the lisp object size).
169 ;;; On other platforms (Non-PPC), if STACK-P is given, then allocation
170 ;;; occurs on the control stack (for dynamic-extent). In this case,
171 ;;; you MUST also specify NODE, so that the appropriate compiler
172 ;;; policy can be used, and TEMP-TN, which is needed for work-space.
173 ;;; TEMP-TN MUST be a non-descriptor reg. FIXME: This is not yet
174 ;;; implemented on PPC. We should implement this and replace the
175 ;;; inline stack-based allocation that presently occurs in the
176 ;;; VOPs. The stack-p argument is ignored on PPC.
178 ;;; If generational GC is enabled, you MUST supply a value for TEMP-TN
179 ;;; because a temp register is needed to do inline allocation.
180 ;;; TEMP-TN, in this case, can be any register, since it holds a
181 ;;; double-word aligned address (essentially a fixnum).
182 (defmacro allocation
(result-tn size lowtag
&key stack-p node temp-tn flag-tn
)
183 ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is
184 ;; set. If the lowtag also has a 1 bit in the same position, we're all
185 ;; set. Otherwise, we need to zap out the lowtag from alloc-tn, and
186 ;; then or in the lowtag.
187 ;; Normal allocation to the heap.
188 (declare (ignore stack-p node
)
190 (ignore temp-tn flag-tn
))
192 (let ((alloc-size (gensym)))
193 `(let ((,alloc-size
,size
))
194 (if (logbitp (1- n-lowtag-bits
) ,lowtag
)
196 (inst ori
,result-tn alloc-tn
,lowtag
))
198 (inst clrrwi
,result-tn alloc-tn n-lowtag-bits
)
199 (inst ori
,result-tn
,result-tn
,lowtag
)))
200 (if (numberp ,alloc-size
)
201 (inst addi alloc-tn alloc-tn
,alloc-size
)
202 (inst add alloc-tn alloc-tn
,alloc-size
))))
205 ;; Make temp-tn be the size
206 (cond ((numberp ,size
)
207 (inst lr
,temp-tn
,size
))
209 (move ,temp-tn
,size
)))
212 (inst lr
,flag-tn
(make-fixup "boxed_region" :foreign
))
214 (inst lwz
,result-tn
,flag-tn
0)
216 (inst lwz
,result-tn thread-base-tn
(* thread-alloc-region-slot
219 ;; we can optimize this to only use one fixup here, once we get
221 ;; (inst lr ,flag-tn (make-fixup "boxed_region" :foreign 4))
222 ;; (inst lwz ,flag-tn ,flag-tn 0)
224 (inst lwz
,flag-tn
,flag-tn
4)
226 (inst lwz
,flag-tn thread-base-tn
(* (1+ thread-alloc-region-slot
)
229 (without-scheduling ()
230 ;; CAUTION: The C code depends on the exact order of
231 ;; instructions here. In particular, immediately before the
232 ;; TW instruction must be an ADD or ADDI instruction, so it
233 ;; can figure out the size of the desired allocation and
234 ;; storing the new base pointer back to the allocation region
235 ;; must take two instructions (one on threaded targets).
237 ;; Now make result-tn point at the end of the object, to
238 ;; figure out if we overflowed the current region.
239 (inst add
,result-tn
,result-tn
,temp-tn
)
240 ;; result-tn points to the new end of the region. Did we go past
241 ;; the actual end of the region? If so, we need a full alloc.
242 ;; The C code depends on this exact form of instruction. If
243 ;; either changes, you have to change the other appropriately!
244 (inst tw
:lge
,result-tn
,flag-tn
)
246 ;; The C code depends on this instruction sequence taking up
247 ;; #!-sb-thread three #!+sb-thread one machine instruction.
248 ;; The lr of a fixup counts as two instructions.
250 (inst lr
,flag-tn
(make-fixup "boxed_region" :foreign
))
252 (inst stw
,result-tn
,flag-tn
0)
254 (inst stw
,result-tn thread-base-tn
(* thread-alloc-region-slot
257 ;; Should the allocation trap above have fired, the runtime
258 ;; arranges for execution to resume here, just after where we
259 ;; would have updated the free pointer in the alloc region.
261 ;; At this point, result-tn points at the end of the object.
262 ;; Adjust to point to the beginning.
263 (inst sub
,result-tn
,result-tn
,temp-tn
)
264 ;; Set the lowtag appropriately
265 (inst ori
,result-tn
,result-tn
,lowtag
)))
267 (defmacro with-fixed-allocation
((result-tn flag-tn temp-tn type-code size
268 &key
(lowtag other-pointer-lowtag
)
271 "Do stuff to allocate an other-pointer object of fixed Size with a single
272 word header having the specified Type-Code. The result is placed in
273 Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
274 by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably
275 initializes the object."
276 (once-only ((result-tn result-tn
) (temp-tn temp-tn
) (flag-tn flag-tn
)
277 (type-code type-code
) (size size
) (lowtag lowtag
))
278 `(pseudo-atomic (,flag-tn
)
279 (if ,stack-allocate-p
282 (inst ori
,result-tn csp-tn
,lowtag
)
283 (inst addi csp-tn csp-tn
(pad-data-block ,size
)))
284 (allocation ,result-tn
(pad-data-block ,size
) ,lowtag
288 (inst lr
,temp-tn
(logior (ash (1- ,size
) n-widetag-bits
) ,type-code
))
289 (storew ,temp-tn
,result-tn
0 ,lowtag
))
292 (defun align-csp (temp)
293 ;; is used for stack allocation of dynamic-extent objects
294 (let ((aligned (gen-label)))
295 (inst andi. temp csp-tn lowtag-mask
)
297 (inst addi csp-tn csp-tn n-word-bytes
)
298 (storew zero-tn csp-tn -
1)
299 (emit-label aligned
)))
303 (defun emit-error-break (vop kind code values
)
306 (note-this-location vop
:internal-error
))
309 (encode-internal-error-args values
)
310 (emit-alignment word-shift
)))
312 (defun error-call (vop error-code
&rest values
)
313 "Cause an error. ERROR-CODE is the error to cause."
314 (emit-error-break vop error-trap
(error-number-or-lose error-code
) values
))
316 (defun generate-error-code (vop error-code
&rest values
)
317 "Generate-Error-Code Error-code Value*
318 Emit code for an error with the specified Error-Code and context Values."
319 (assemble (*elsewhere
*)
320 (let ((start-lab (gen-label)))
321 (emit-label start-lab
)
322 (emit-error-break vop error-trap
(error-number-or-lose error-code
) values
)
327 ;;; handy macro for making sequences look atomic
329 ;;; FLAG-TN must be wired to NL3. If a deferred interrupt happens
330 ;;; while we have the low bits of ALLOC-TN set, we add a "large"
331 ;;; constant to FLAG-TN. On exit, we add FLAG-TN to ALLOC-TN which (a)
332 ;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then
333 ;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
334 ;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
335 (defmacro pseudo-atomic
((flag-tn) &body forms
)
336 #!+sb-safepoint-strictly
337 `(progn ,flag-tn
,@forms
(emit-safepoint))
338 #!-sb-safepoint-strictly
340 (without-scheduling ()
341 ;; Extra debugging stuff:
344 (inst andi.
,flag-tn alloc-tn lowtag-mask
)
345 (inst twi
:ne
,flag-tn
0))
346 (inst ori alloc-tn alloc-tn pseudo-atomic-flag
))
349 (without-scheduling ()
350 (inst subi alloc-tn alloc-tn pseudo-atomic-flag
)
351 ;; Now test to see if the pseudo-atomic interrupted bit is set.
352 (inst andi.
,flag-tn alloc-tn pseudo-atomic-interrupted-flag
)
353 (inst twi
:ne
,flag-tn
0))
356 (inst andi.
,flag-tn alloc-tn lowtag-mask
)
357 (inst twi
:ne
,flag-tn
0))
362 (defun emit-safepoint ()
363 (inst lwz zero-tn null-tn
(- (+ 4096 4 other-pointer-lowtag
))))
365 (sb!xc
:defmacro with-pinned-objects
((&rest objects
) &body body
)
366 "Arrange with the garbage collector that the pages occupied by
367 OBJECTS will not be moved in memory for the duration of BODY.
368 Useful for e.g. foreign calls where another thread may trigger
369 garbage collection. This is currently implemented by disabling GC"
371 (declare (ignore objects
)) ; should we eval these for side-effect?
376 `(let ((*pinned-objects
* (list* ,@objects
*pinned-objects
*)))
377 (declare (truly-dynamic-extent *pinned-objects
*))