1 ;;;; various useful macros for generating Sparc code
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 move ,n-dst ,n-src))))
24 ((frob (op inst shift)
25 `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
26 `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
27 (frob loadw ld word-shift)
28 (frob storew st word-shift))
30 (defmacro load-symbol (reg symbol)
31 `(inst add ,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 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))))))))
60 (defmacro load-type (target source &optional (offset 0))
62 "Loads the type bits of a pointer into target independent of
63 byte-ordering issues."
64 (once-only ((n-target target)
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*
71 `(inst ldub ,n-target ,n-source ,n-offset))
73 `(inst ldub ,n-target ,n-source (+ ,n-offset 3))))))
75 ;;; Macros to handle the fact that we cannot use the machine native call and
76 ;;; return instructions.
78 (defmacro lisp-jump (fun)
79 "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
82 (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
85 (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
86 "Return to RETURN-PC."
89 (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
91 `(move code-tn ,return-pc)
94 (defmacro emit-return-pc (label)
95 "Emit a return-pc header word. LABEL is the label to use for this return-pc."
99 (inst lra-header-word)))
105 ;;; Move a stack TN to a register and vice-versa.
106 (defmacro load-stack-tn (reg stack)
109 (let ((offset (tn-offset stack)))
112 (loadw reg cfp-tn offset))))))
114 (defmacro store-stack-tn (stack reg)
115 `(let ((stack ,stack)
117 (let ((offset (tn-offset stack)))
120 (storew reg cfp-tn offset))))))
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))
127 ((any-reg descriptor-reg)
129 ((any-reg descriptor-reg)
130 (move ,n-reg ,n-stack))
132 (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
135 ;;;; Storage allocation:
136 (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
138 "Do stuff to allocate an other-pointer object of fixed Size with a single
139 word header having the specified Type-Code. The result is placed in
140 Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
141 by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably
142 initializes the object."
143 (once-only ((result-tn result-tn) (temp-tn temp-tn)
144 (type-code type-code) (size size))
145 `(pseudo-atomic (:extra (pad-data-block ,size))
146 (inst or ,result-tn alloc-tn other-pointer-lowtag)
147 (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
148 (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
153 (eval-when (:compile-toplevel :load-toplevel :execute)
154 (defun emit-error-break (vop kind code values)
155 (let ((vector (gensym)))
158 (note-this-location vop :internal-error)))
160 (with-adjustable-vector (,vector)
161 (write-var-integer (error-number-or-lose ',code) ,vector)
162 ,@(mapcar #'(lambda (tn)
164 (write-var-integer (make-sc-offset (sc-number
169 (inst byte (length ,vector))
170 (dotimes (i (length ,vector))
171 (inst byte (aref ,vector i))))
172 (align word-shift)))))
174 (defmacro error-call (vop error-code &rest values)
175 "Cause an error. ERROR-CODE is the error to cause."
177 (emit-error-break vop error-trap error-code values)))
180 (defmacro cerror-call (vop label error-code &rest values)
181 "Cause a continuable error. If the error is continued, execution resumes at
185 ,@(emit-error-break vop cerror-trap error-code values)))
187 (defmacro generate-error-code (vop error-code &rest values)
188 "Generate-Error-Code Error-code Value*
189 Emit code for an error with the specified Error-Code and context Values."
190 `(assemble (*elsewhere*)
191 (let ((start-lab (gen-label)))
192 (emit-label start-lab)
193 (error-call ,vop ,error-code ,@values)
196 (defmacro generate-cerror-code (vop error-code &rest values)
197 "Generate-CError-Code Error-code Value*
198 Emit code for a continuable error with the specified Error-Code and
199 context Values. If the error is continued, execution resumes after
200 the GENERATE-CERROR-CODE form."
201 (let ((continue (gensym "CONTINUE-LABEL-"))
202 (error (gensym "ERROR-LABEL-")))
203 `(let ((,continue (gen-label)))
204 (emit-label ,continue)
205 (assemble (*elsewhere*)
206 (let ((,error (gen-label)))
208 (cerror-call ,vop ,continue ,error-code ,@values)
213 ;;; a handy macro for making sequences look atomic
214 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
215 (let ((n-extra (gensym)))
216 `(let ((,n-extra ,extra))
217 ;; Set the pseudo-atomic flag.
218 (without-scheduling ()
219 (inst add alloc-tn 4))
221 ;; Reset the pseudo-atomic flag.
222 (without-scheduling ()
223 #+nil (inst taddcctv alloc-tn (- ,n-extra 4))
224 ;; Remove the pseudo-atomic flag.
225 (inst add alloc-tn (- ,n-extra 4))
226 ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1).
227 (inst andcc zero-tn alloc-tn 3)
228 ;; The C code needs to process this correctly and fixup alloc-tn.
229 (inst t :ne pseudo-atomic-trap)))))