Support building without PSEUDO-ATOMIC on POSIX safepoints
[sbcl.git] / src / compiler / sparc / macros.lisp
1 ;;;; various useful macros for generating Sparc code
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;; Instruction-like macros.
15
16 (defmacro move (dst src)
17   "Move SRC into DST unless they are location=."
18   (once-only ((n-dst dst)
19               (n-src src))
20     `(unless (location= ,n-dst ,n-src)
21        (inst move ,n-dst ,n-src))))
22
23 (macrolet
24     ((def (op inst shift)
25        `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
26           `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
27   (def loadw ld word-shift)
28   (def storew st word-shift))
29
30 (defmacro load-symbol (reg symbol)
31   `(inst add ,reg null-tn (static-symbol-offset ,symbol)))
32
33 (macrolet
34     ((frob (slot)
35        (let ((loader (intern (concatenate 'simple-string
36                                           "LOAD-SYMBOL-"
37                                           (string slot))))
38              (storer (intern (concatenate 'simple-string
39                                           "STORE-SYMBOL-"
40                                           (string slot))))
41              (offset (intern (concatenate 'simple-string
42                                           "SYMBOL-"
43                                           (string slot)
44                                           "-SLOT")
45                              (find-package "SB!VM"))))
46          `(progn
47             (defmacro ,loader (reg symbol)
48               `(inst ld ,reg null-tn
49                      (+ (static-symbol-offset ',symbol)
50                         (ash ,',offset word-shift)
51                         (- other-pointer-lowtag))))
52             (defmacro ,storer (reg symbol)
53               `(inst st ,reg null-tn
54                      (+ (static-symbol-offset ',symbol)
55                         (ash ,',offset word-shift)
56                         (- other-pointer-lowtag))))))))
57   (frob value)
58   (frob function))
59
60 (defmacro load-type (target source &optional (offset 0))
61   #!+sb-doc
62   "Loads the type bits of a pointer into target independent of
63   byte-ordering issues."
64   (once-only ((n-target target)
65               (n-source source)
66               (n-offset offset))
67     ;; FIXME: although I don't understand entirely, I'm going to do
68     ;; what whn does in x86/macros.lisp -- Christophe
69     (ecase *backend-byte-order*
70       (:little-endian
71        `(inst ldub ,n-target ,n-source ,n-offset))
72       (:big-endian
73        `(inst ldub ,n-target ,n-source (+ ,n-offset (1- n-word-bytes)))))))
74
75 ;;; Macros to handle the fact that we cannot use the machine native call and
76 ;;; return instructions.
77
78 (defmacro lisp-jump (fun)
79   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
80   `(progn
81      (inst j ,fun
82            (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
83      (move code-tn ,fun)))
84
85 (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
86   "Return to RETURN-PC."
87   `(progn
88      (inst j ,return-pc
89            (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
90      ,(if frob-code
91           `(move code-tn ,return-pc)
92           '(inst nop))))
93
94 (defmacro emit-return-pc (label)
95   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
96   `(progn
97      (emit-alignment n-lowtag-bits)
98      (emit-label ,label)
99      (inst lra-header-word)))
100
101
102 \f
103 ;;;; stack TN's
104
105 ;;; Move a stack TN to a register and vice-versa.
106 (defmacro load-stack-tn (reg stack)
107   `(let ((reg ,reg)
108          (stack ,stack))
109      (let ((offset (tn-offset stack)))
110        (sc-case stack
111          ((control-stack)
112           (loadw reg cfp-tn offset))))))
113
114 (defmacro store-stack-tn (stack reg)
115   `(let ((stack ,stack)
116          (reg ,reg))
117      (let ((offset (tn-offset stack)))
118        (sc-case stack
119          ((control-stack)
120           (storew reg cfp-tn offset))))))
121
122 (defmacro maybe-load-stack-tn (reg reg-or-stack)
123   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
124   (once-only ((n-reg reg)
125               (n-stack reg-or-stack))
126     `(sc-case ,n-reg
127        ((any-reg descriptor-reg)
128         (sc-case ,n-stack
129           ((any-reg descriptor-reg)
130            (move ,n-reg ,n-stack))
131           ((control-stack)
132            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
133
134 \f
135 \f
136 ;;;; Storage allocation:
137
138 ;;;; Allocation macro
139 ;;;;
140 ;;;; This macro does the appropriate stuff to allocate space.
141 ;;;;
142 ;;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
143 ;;;; applied.  The amount of space to be allocated is SIZE bytes (which
144 ;;;; must be a multiple of the lisp object size).
145 (defmacro allocation (result-tn size lowtag &key stack-p temp-tn)
146   #!+gencgc
147   ;; A temp register is needed to do inline allocation.  TEMP-TN, in
148   ;; this case, can be any register, since it holds a double-word
149   ;; aligned address (essentially a fixnum).
150   (assert temp-tn)
151   ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is
152   ;; set.
153   `(cond
154      (,stack-p
155       ;; Stack allocation
156       ;;
157       ;; The control stack grows up, so round up CSP to a
158       ;; multiple of 8 (lispobj size).  Use that as the
159       ;; allocation pointer.  Then add SIZE bytes to the
160       ;; allocation and set CSP to that, so we have the desired
161       ;; space.
162
163       ;; Make sure the temp-tn is a non-descriptor register!
164       (assert (and ,temp-tn (sc-is ,temp-tn non-descriptor-reg)))
165
166       ;; temp-tn is csp-tn rounded up to a multiple of 8 (lispobj size)
167       (align-csp ,temp-tn)
168       ;; For the benefit of future historians, this is how CMUCL does the
169       ;; align-csp (I think their version is branch free only because
170       ;; they simply don't worry about zeroing the pad word):
171       #+nil (inst add ,temp-tn csp-tn sb!vm:lowtag-mask)
172       #+nil (inst andn ,temp-tn sb!vm:lowtag-mask)
173
174       ;; Set the result to temp-tn, with appropriate lowtag
175       (inst or ,result-tn csp-tn ,lowtag)
176
177       ;; Allocate the desired space on the stack.
178       ;;
179       ;; FIXME: Can't allocate on stack if SIZE is too large.
180       ;; Need to rearrange this code.
181       (inst add csp-tn ,size))
182
183      #!-gencgc
184      ;; Normal allocation to the heap -- cheneygc version.
185      ;;
186      ;; On cheneygc, the alloc-tn currently has the pseudo-atomic bit.
187      ;; If the lowtag also has a 1 bit in the same position, we're all set.
188      ;;
189      ;; See comment in PSEUDO-ATOMIC-FLAG.
190      ((logbitp (1- n-lowtag-bits) ,lowtag)
191       (inst or ,result-tn alloc-tn ,lowtag)
192       (inst add alloc-tn ,size))
193      ;;
194      ;; Otherwise, we need to zap out the lowtag from alloc-tn, and then
195      ;; or in the lowtag.
196      #!-gencgc
197      (t
198       (inst andn ,result-tn alloc-tn lowtag-mask)
199       (inst or ,result-tn ,lowtag)
200       (inst add alloc-tn ,size))
201
202      ;; Normal allocation to the heap -- gencgc version.
203      ;;
204      ;; No need to worry about lowtag bits matching up here, since
205      ;; alloc-tn is just a "pseudo-atomic-bit-tn" now and we don't read
206      ;; it.
207      #!+gencgc
208      (t
209       (inst li ,temp-tn (make-fixup "boxed_region" :foreign))
210       (loadw ,result-tn ,temp-tn 0)     ;boxed_region.free_pointer
211       (loadw ,temp-tn ,temp-tn 1)       ;boxed_region.end_addr
212
213       (without-scheduling ()
214         (let ((done (gen-label))
215               (full-alloc (gen-label)))
216           ;; See if we can do an inline allocation.  The updated
217           ;; free pointer should not point past the end of the
218           ;; current region.  If it does, a full alloc needs to be
219           ;; done.
220           (inst add ,result-tn ,size)
221
222           ;; result-tn points to the new end of region.  Did we go
223           ;; past the actual end of the region?  If so, we need a
224           ;; full alloc.
225           (inst cmp ,result-tn ,temp-tn)
226           (if (member :sparc-v9 *backend-subfeatures*)
227               (inst b :gtu full-alloc :pn)
228               (inst b :gtu full-alloc))
229           (inst nop)
230           ;; Inline allocation worked, so update the free pointer
231           ;; and go.  Should really do a swap instruction here to
232           ;; swap memory with a register.
233
234           ;; Kludge: We ought to have two distinct FLAG-TN and TEMP-TN
235           ;; here, to avoid the SUB and the TEMP-TN reload which is
236           ;; causing it.  PPC gets it right.
237           (inst li ,temp-tn (make-fixup "boxed_region" :foreign))
238           (storew ,result-tn ,temp-tn 0)
239
240           (inst b done)
241           (inst sub ,result-tn ,size)
242
243           (emit-label full-alloc)
244           ;; Full alloc via trap to the C allocator.  Tell the
245           ;; allocator what the result-tn and size are, using the
246           ;; OR instruction.  Then trap to the allocator.
247           (inst or zero-tn ,result-tn ,size)
248           ;; DFL: Not certain why we use two kinds of traps: T for p/a
249           ;; and UNIMP for all other traps.  But the C code in the runtime
250           ;; for the UNIMP case is a lot nicer, so I'm hooking into that.
251           ;; (inst t :t allocation-trap)
252           (inst unimp allocation-trap)
253
254           (emit-label done)
255           ;; Set lowtag appropriately
256           (inst or ,result-tn ,lowtag))))))
257
258 (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
259                                  &body body)
260   "Do stuff to allocate an other-pointer object of fixed Size with a single
261   word header having the specified Type-Code.  The result is placed in
262   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
263   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
264   initializes the object."
265   (unless body
266     (bug "empty &body in WITH-FIXED-ALLOCATION"))
267   (once-only ((result-tn result-tn) (temp-tn temp-tn)
268               (type-code type-code) (size size))
269     `(pseudo-atomic ()
270        (allocation ,result-tn (pad-data-block ,size) other-pointer-lowtag
271                    :temp-tn ,temp-tn)
272        (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
273        (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
274        ,@body)))
275
276 (defun align-csp (temp)
277   (let ((aligned (gen-label)))
278     ;; FIXME: why use a TEMP?  Why not just ZERO-TN?
279     (inst andcc temp csp-tn lowtag-mask)
280     (if (member :sparc-v9 *backend-subfeatures*)
281         (inst b :eq aligned :pt)
282         (inst b :eq aligned))
283     (storew zero-tn csp-tn 0) ; sneaky use of delay slot
284     (inst add csp-tn csp-tn n-word-bytes)
285     (emit-label aligned)))
286 \f
287 ;;;; Error Code
288 (eval-when (:compile-toplevel :load-toplevel :execute)
289   (defun emit-error-break (vop kind code values)
290     (let ((vector (gensym)))
291       `((let ((vop ,vop))
292           (when vop
293             (note-this-location vop :internal-error)))
294         (inst unimp ,kind)
295         (with-adjustable-vector (,vector)
296           (write-var-integer (error-number-or-lose ',code) ,vector)
297           ,@(mapcar #'(lambda (tn)
298                         `(let ((tn ,tn))
299                            (write-var-integer (make-sc-offset (sc-number
300                                                                (tn-sc tn))
301                                                               (tn-offset tn))
302                                               ,vector)))
303                     values)
304           (inst byte (length ,vector))
305           (dotimes (i (length ,vector))
306             (inst byte (aref ,vector i))))
307         (emit-alignment word-shift)))))
308
309 (defmacro error-call (vop error-code &rest values)
310   "Cause an error.  ERROR-CODE is the error to cause."
311   (cons 'progn
312         (emit-error-break vop error-trap error-code values)))
313
314
315 (defmacro cerror-call (vop label error-code &rest values)
316   "Cause a continuable error.  If the error is continued, execution resumes at
317   LABEL."
318   `(progn
319      (inst b ,label)
320      ,@(emit-error-break vop cerror-trap error-code values)))
321
322 (defmacro generate-error-code (vop error-code &rest values)
323   "Generate-Error-Code Error-code Value*
324   Emit code for an error with the specified Error-Code and context Values."
325   `(assemble (*elsewhere*)
326      (let ((start-lab (gen-label)))
327        (emit-label start-lab)
328        (error-call ,vop ,error-code ,@values)
329        start-lab)))
330
331 (defmacro generate-cerror-code (vop error-code &rest values)
332   "Generate-CError-Code Error-code Value*
333   Emit code for a continuable error with the specified Error-Code and
334   context Values.  If the error is continued, execution resumes after
335   the GENERATE-CERROR-CODE form."
336   (with-unique-names (continue error)
337     `(let ((,continue (gen-label)))
338        (emit-label ,continue)
339        (assemble (*elsewhere*)
340          (let ((,error (gen-label)))
341            (emit-label ,error)
342            (cerror-call ,vop ,continue ,error-code ,@values)
343            ,error)))))
344 \f
345 ;;; a handy macro for making sequences look atomic
346 (defmacro pseudo-atomic ((&optional) &rest forms)
347   (let ()
348     `(progn
349        ;; Set the pseudo-atomic flag.
350        (without-scheduling ()
351          (inst or alloc-tn 4))
352        ,@forms
353        ;; Reset the pseudo-atomic flag.
354        (without-scheduling ()
355         ;; Remove the pseudo-atomic flag.
356         (inst andn alloc-tn 4)
357         ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1).
358         (inst andcc zero-tn alloc-tn 3)
359         ;; The C code needs to process this correctly and fixup alloc-tn.
360         (inst t :ne pseudo-atomic-trap)))))
361
362
363 (def!macro with-pinned-objects ((&rest objects) &body body)
364   "Arrange with the garbage collector that the pages occupied by
365 OBJECTS will not be moved in memory for the duration of BODY.
366 Useful for e.g. foreign calls where another thread may trigger
367 garbage collection.  This is currently implemented by disabling GC"
368   #!-gencgc
369   (declare (ignore objects))            ;should we eval these for side-effect?
370   #!-gencgc
371   `(without-gcing
372     ,@body)
373   #!+gencgc
374   `(let ((*pinned-objects* (list* ,@objects *pinned-objects*)))
375      ,@body))