4 ;;; Instruction-like macros.
6 (defmacro move (src dst)
7 "Move SRC into DST unless they are location=."
8 (once-only ((src src) (dst dst))
9 `(unless (location= ,src ,dst)
10 (inst move ,src ,dst))))
12 (defmacro loadw (result base &optional (offset 0) (lowtag 0))
13 (once-only ((result result) (base base))
14 `(inst ldw (- (ash ,offset word-shift) ,lowtag) ,base ,result)))
16 (defmacro storew (value base &optional (offset 0) (lowtag 0))
17 (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
18 `(inst stw ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
20 (defmacro load-symbol (reg symbol)
21 (once-only ((reg reg) (symbol symbol))
22 `(inst addi (static-symbol-offset ,symbol) null-tn ,reg)))
24 (defmacro load-symbol-value (reg symbol)
26 (+ (static-symbol-offset ',symbol)
27 (ash symbol-value-slot word-shift)
28 (- other-pointer-lowtag))
32 (defmacro store-symbol-value (reg symbol)
33 `(inst stw ,reg (+ (static-symbol-offset ',symbol)
34 (ash symbol-value-slot word-shift)
35 (- other-pointer-lowtag))
38 (defmacro load-type (target source &optional (offset 0))
39 "Loads the type bits of a pointer into target independent of
40 byte-ordering issues."
41 (ecase *backend-byte-order*
43 `(inst ldb ,offset ,source ,target))
45 `(inst ldb (+ ,offset 3) ,source ,target))))
47 ;;; Macros to handle the fact that we cannot use the machine native call and
48 ;;; return instructions.
50 (defmacro lisp-jump (function)
51 "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
54 (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
58 (move ,function code-tn)))
60 (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
61 "Return to RETURN-PC."
63 (inst addi (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
65 (inst bv lip-tn ,@(unless frob-code '(:nullify t)))
67 `((move ,return-pc code-tn)))))
69 (defmacro emit-return-pc (label)
70 "Emit a return-pc header word. LABEL is the label to use for this
75 (inst lra-header-word)))
80 ;;; Load-Stack-TN, Store-Stack-TN -- Interface
82 ;;; Move a stack TN to a register and vice-versa.
84 (defmacro load-stack-tn (reg stack)
87 (let ((offset (tn-offset stack)))
90 (loadw reg cfp-tn offset))))))
92 (defmacro store-stack-tn (stack reg)
95 (let ((offset (tn-offset stack)))
98 (storew reg cfp-tn offset))))))
101 ;;; MAYBE-LOAD-STACK-TN -- Interface
103 (defmacro maybe-load-stack-tn (reg reg-or-stack)
104 "Move the TN Reg-Or-Stack into Reg if it isn't already there."
105 (once-only ((n-reg reg)
106 (n-stack reg-or-stack))
108 ((any-reg descriptor-reg)
110 ((any-reg descriptor-reg)
111 (move ,n-stack ,n-reg))
113 (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
116 ;;;; Storage allocation:
118 (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
120 "Do stuff to allocate an other-pointer object of fixed Size with a single
121 word header having the specified Type-Code. The result is placed in
122 Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
123 by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably
124 initializes the object."
125 (once-only ((result-tn result-tn) (temp-tn temp-tn)
126 (type-code type-code) (size size))
127 `(pseudo-atomic (:extra (pad-data-block ,size))
128 (inst move alloc-tn ,result-tn)
129 (inst dep other-pointer-lowtag 31 3 ,result-tn)
130 (inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)
131 (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
137 (defvar *adjustable-vectors* nil)
139 (defmacro with-adjustable-vector ((var) &rest body)
140 `(let ((,var (or (pop *adjustable-vectors*)
142 :element-type '(unsigned-byte 8)
145 (declare (type (vector (unsigned-byte 8) 16) ,var))
146 (setf (fill-pointer ,var) 0)
150 (push ,var *adjustable-vectors*))))
152 (eval-when (compile load eval)
153 (defun emit-error-break (vop kind code values)
154 (let ((vector (gensym)))
157 (note-this-location vop :internal-error)))
159 (with-adjustable-vector (,vector)
160 (write-var-integer (error-number-or-lose ',code) ,vector)
161 ,@(mapcar #'(lambda (tn)
163 (write-var-integer (make-sc-offset (sc-number
168 (inst byte (length ,vector))
169 (dotimes (i (length ,vector))
170 (inst byte (aref ,vector i))))
171 (align word-shift)))))
173 (defmacro error-call (vop error-code &rest values)
174 "Cause an error. ERROR-CODE is the error to cause."
176 (emit-error-break vop error-trap error-code values)))
179 (defmacro cerror-call (vop label error-code &rest values)
180 "Cause a continuable error. If the error is continued, execution resumes at
184 ,@(emit-error-break vop cerror-trap error-code values)))
186 (defmacro generate-error-code (vop error-code &rest values)
187 "Generate-Error-Code Error-code Value*
188 Emit code for an error with the specified Error-Code and context Values."
189 `(assemble (*elsewhere*)
190 (let ((start-lab (gen-label)))
191 (emit-label start-lab)
192 (error-call ,vop ,error-code ,@values)
195 (defmacro generate-cerror-code (vop error-code &rest values)
196 "Generate-CError-Code Error-code Value*
197 Emit code for a continuable error with the specified Error-Code and
198 context Values. If the error is continued, execution resumes after
199 the GENERATE-CERROR-CODE form."
200 (let ((continue (gensym "CONTINUE-LABEL-"))
201 (error (gensym "ERROR-LABEL-")))
202 `(let ((,continue (gen-label)))
203 (emit-label ,continue)
204 (assemble (*elsewhere*)
205 (let ((,error (gen-label)))
207 (cerror-call ,vop ,continue ,error-code ,@values)
212 ;;; PSEUDO-ATOMIC -- 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 (inst addi 4 alloc-tn alloc-tn)
219 (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))
223 ;;;; Indexed references:
225 (deftype load/store-index (scale lowtag min-offset
226 &optional (max-offset min-offset))
227 `(integer ,(- (truncate (+ (ash 1 14)
228 (* min-offset n-word-bytes)
231 ,(truncate (- (+ (1- (ash 1 14)) lowtag)
232 (* max-offset n-word-bytes))
235 (defmacro define-full-reffer (name type offset lowtag scs el-type
240 `((:translate ,translate)))
242 (:args (object :scs (descriptor-reg) :to (:eval 0))
243 (index :scs (any-reg) :target temp))
244 (:arg-types ,type tagged-num)
245 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
246 (:results (value :scs ,scs))
247 (:result-types ,el-type)
249 (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
250 (inst ldwx temp object value)))
251 (define-vop (,(symbolicate name "-C"))
253 `((:translate ,translate)))
255 (:args (object :scs (descriptor-reg)))
258 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
260 (:results (value :scs ,scs))
261 (:result-types ,el-type)
263 (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag)
266 (defmacro define-full-setter (name type offset lowtag scs el-type
271 `((:translate ,translate)))
273 (:args (object :scs (descriptor-reg))
274 (index :scs (any-reg))
275 (value :scs ,scs :target result))
276 (:arg-types ,type tagged-num ,el-type)
277 (:temporary (:scs (interior-reg)) lip)
278 (:results (result :scs ,scs))
279 (:result-types ,el-type)
281 (inst add object index lip)
282 (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
283 (move value result)))
284 (define-vop (,(symbolicate name "-C"))
286 `((:translate ,translate)))
288 (:args (object :scs (descriptor-reg))
292 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
295 (:results (result :scs ,scs))
296 (:result-types ,el-type)
298 (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
299 (move value result)))))
302 (defmacro define-partial-reffer (name type size signed offset lowtag scs
303 el-type &optional translate)
304 (let ((scale (ecase size (:byte 1) (:short 2))))
308 `((:translate ,translate)))
310 (:args (object :scs (descriptor-reg) :to (:eval 0))
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)
317 (inst ,(ecase size (:byte 'add) (:short 'sh1add))
319 (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
320 (- (* ,offset n-word-bytes) ,lowtag) lip value)
322 `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
323 (define-vop (,(symbolicate name "-C"))
325 `((:translate ,translate)))
327 (:args (object :scs (descriptor-reg)))
330 (:constant (load/store-index ,scale
333 (:results (value :scs ,scs))
334 (:result-types ,el-type)
336 (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
337 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
340 `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
342 (defmacro define-partial-setter (name type size offset lowtag scs el-type
344 (let ((scale (ecase size (:byte 1) (:short 2))))
348 `((:translate ,translate)))
350 (:args (object :scs (descriptor-reg))
351 (index :scs (unsigned-reg))
352 (value :scs ,scs :target result))
353 (:arg-types ,type positive-fixnum ,el-type)
354 (:temporary (:scs (interior-reg)) lip)
355 (:results (result :scs ,scs))
356 (:result-types ,el-type)
358 (inst ,(ecase size (:byte 'add) (:short 'sh1add))
360 (inst ,(ecase size (:byte 'stb) (:short 'sth))
361 value (- (* ,offset n-word-bytes) ,lowtag) lip)
362 (move value result)))
363 (define-vop (,(symbolicate name "-C"))
365 `((:translate ,translate)))
367 (:args (object :scs (descriptor-reg))
368 (value :scs ,scs :target result))
371 (:constant (load/store-index ,scale
375 (:results (result :scs ,scs))
376 (:result-types ,el-type)
378 (inst ,(ecase size (:byte 'stb) (:short 'sth))
380 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
382 (move value result))))))