1 ;;;; various useful macros for generating HPPA 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 (src dst)
17 "Move SRC into DST unless they are location=."
18 (once-only ((src src) (dst dst))
19 `(unless (location= ,src ,dst)
20 (inst move ,src ,dst))))
22 (defmacro loadw (result base &optional (offset 0) (lowtag 0))
23 (once-only ((result result) (base base))
24 `(inst ldw (- (ash ,offset word-shift) ,lowtag) ,base ,result)))
26 (defmacro storew (value base &optional (offset 0) (lowtag 0))
27 (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
28 `(inst stw ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
30 (defmacro load-symbol (reg symbol)
31 (once-only ((reg reg) (symbol symbol))
32 `(inst addi (static-symbol-offset ,symbol) null-tn ,reg)))
34 (defmacro load-symbol-value (reg symbol)
36 (+ (static-symbol-offset ',symbol)
37 (ash symbol-value-slot word-shift)
38 (- other-pointer-lowtag))
42 (defmacro store-symbol-value (reg symbol)
43 `(inst stw ,reg (+ (static-symbol-offset ',symbol)
44 (ash symbol-value-slot word-shift)
45 (- other-pointer-lowtag))
48 (defmacro load-type (target source &optional (offset 0))
49 "Loads the type bits of a pointer into target independent of
50 byte-ordering issues."
51 (ecase *backend-byte-order*
53 `(inst ldb ,offset ,source ,target))
55 `(inst ldb (+ ,offset 3) ,source ,target))))
57 ;;; Macros to handle the fact that we cannot use the machine native call and
58 ;;; return instructions.
60 (defmacro lisp-jump (function)
61 "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
64 (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
68 (move ,function code-tn)))
70 (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
71 "Return to RETURN-PC."
73 (inst addi (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
75 (inst bv lip-tn ,@(unless frob-code '(:nullify t)))
77 `((move ,return-pc code-tn)))))
79 (defmacro emit-return-pc (label)
80 "Emit a return-pc header word. LABEL is the label to use for this
85 (inst lra-header-word)))
90 ;;; Move a stack TN to a register and vice-versa.
91 (defmacro load-stack-tn (reg stack)
94 (let ((offset (tn-offset stack)))
97 (loadw reg cfp-tn offset))))))
98 (defmacro store-stack-tn (stack reg)
101 (let ((offset (tn-offset stack)))
104 (storew reg cfp-tn offset))))))
106 (defmacro maybe-load-stack-tn (reg reg-or-stack)
107 "Move the TN Reg-Or-Stack into Reg if it isn't already there."
108 (once-only ((n-reg reg)
109 (n-stack reg-or-stack))
111 ((any-reg descriptor-reg)
113 ((any-reg descriptor-reg)
114 (move ,n-stack ,n-reg))
116 (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
119 ;;;; Storage allocation:
121 (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
123 "Do stuff to allocate an other-pointer object of fixed Size with a single
124 word header having the specified Type-Code. The result is placed in
125 Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
126 by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably
127 initializes the object."
128 (once-only ((result-tn result-tn) (temp-tn temp-tn)
129 (type-code type-code) (size size))
130 `(pseudo-atomic (:extra (pad-data-block ,size))
131 (inst move alloc-tn ,result-tn)
132 (inst dep other-pointer-lowtag 31 3 ,result-tn)
133 (inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)
134 (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
139 (eval-when (compile load eval)
140 (defun emit-error-break (vop kind code values)
141 (let ((vector (gensym)))
144 (note-this-location vop :internal-error)))
146 (with-adjustable-vector (,vector)
147 (write-var-integer (error-number-or-lose ',code) ,vector)
148 ,@(mapcar #'(lambda (tn)
150 (write-var-integer (make-sc-offset (sc-number
155 (inst byte (length ,vector))
156 (dotimes (i (length ,vector))
157 (inst byte (aref ,vector i))))
158 (align word-shift)))))
160 (defmacro error-call (vop error-code &rest values)
161 "Cause an error. ERROR-CODE is the error to cause."
163 (emit-error-break vop error-trap error-code values)))
166 (defmacro cerror-call (vop label error-code &rest values)
167 "Cause a continuable error. If the error is continued, execution resumes at
171 ,@(emit-error-break vop cerror-trap error-code values)))
173 (defmacro generate-error-code (vop error-code &rest values)
174 "Generate-Error-Code Error-code Value*
175 Emit code for an error with the specified Error-Code and context Values."
176 `(assemble (*elsewhere*)
177 (let ((start-lab (gen-label)))
178 (emit-label start-lab)
179 (error-call ,vop ,error-code ,@values)
182 (defmacro generate-cerror-code (vop error-code &rest values)
183 "Generate-CError-Code Error-code Value*
184 Emit code for a continuable error with the specified Error-Code and
185 context Values. If the error is continued, execution resumes after
186 the GENERATE-CERROR-CODE form."
187 (let ((continue (gensym "CONTINUE-LABEL-"))
188 (error (gensym "ERROR-LABEL-")))
189 `(let ((,continue (gen-label)))
190 (emit-label ,continue)
191 (assemble (*elsewhere*)
192 (let ((,error (gen-label)))
194 (cerror-call ,vop ,continue ,error-code ,@values)
199 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
201 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
202 (let ((n-extra (gensym)))
203 `(let ((,n-extra ,extra))
204 (inst addi 4 alloc-tn alloc-tn)
206 (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))
210 ;;;; Indexed references:
212 (deftype load/store-index (scale lowtag min-offset
213 &optional (max-offset min-offset))
214 `(integer ,(- (truncate (+ (ash 1 14)
215 (* min-offset n-word-bytes)
218 ,(truncate (- (+ (1- (ash 1 14)) lowtag)
219 (* max-offset n-word-bytes))
222 (defmacro define-full-reffer (name type offset lowtag scs el-type
227 `((:translate ,translate)))
229 (:args (object :scs (descriptor-reg) :to (:eval 0))
230 (index :scs (any-reg) :target temp))
231 (:arg-types ,type tagged-num)
232 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
233 (:results (value :scs ,scs))
234 (:result-types ,el-type)
236 (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
237 (inst ldwx temp object value)))
238 (define-vop (,(symbolicate name "-C"))
240 `((:translate ,translate)))
242 (:args (object :scs (descriptor-reg)))
245 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
247 (:results (value :scs ,scs))
248 (:result-types ,el-type)
250 (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag)
253 (defmacro define-full-setter (name type offset lowtag scs el-type
258 `((:translate ,translate)))
260 (:args (object :scs (descriptor-reg))
261 (index :scs (any-reg))
262 (value :scs ,scs :target result))
263 (:arg-types ,type tagged-num ,el-type)
264 (:temporary (:scs (interior-reg)) lip)
265 (:results (result :scs ,scs))
266 (:result-types ,el-type)
268 (inst add object index lip)
269 (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
270 (move value result)))
271 (define-vop (,(symbolicate name "-C"))
273 `((:translate ,translate)))
275 (:args (object :scs (descriptor-reg))
279 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
282 (:results (result :scs ,scs))
283 (:result-types ,el-type)
285 (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
286 (move value result)))))
289 (defmacro define-partial-reffer (name type size signed offset lowtag scs
290 el-type &optional translate)
291 (let ((scale (ecase size (:byte 1) (:short 2))))
295 `((:translate ,translate)))
297 (:args (object :scs (descriptor-reg) :to (:eval 0))
298 (index :scs (unsigned-reg)))
299 (:arg-types ,type positive-fixnum)
300 (:results (value :scs ,scs))
301 (:result-types ,el-type)
302 (:temporary (:scs (interior-reg)) lip)
304 (inst ,(ecase size (:byte 'add) (:short 'sh1add))
306 (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
307 (- (* ,offset n-word-bytes) ,lowtag) lip value)
309 `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
310 (define-vop (,(symbolicate name "-C"))
312 `((:translate ,translate)))
314 (:args (object :scs (descriptor-reg)))
317 (:constant (load/store-index ,scale
320 (:results (value :scs ,scs))
321 (:result-types ,el-type)
323 (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
324 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
327 `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
329 (defmacro define-partial-setter (name type size offset lowtag scs el-type
331 (let ((scale (ecase size (:byte 1) (:short 2))))
335 `((:translate ,translate)))
337 (:args (object :scs (descriptor-reg))
338 (index :scs (unsigned-reg))
339 (value :scs ,scs :target result))
340 (:arg-types ,type positive-fixnum ,el-type)
341 (:temporary (:scs (interior-reg)) lip)
342 (:results (result :scs ,scs))
343 (:result-types ,el-type)
345 (inst ,(ecase size (:byte 'add) (:short 'sh1add))
347 (inst ,(ecase size (:byte 'stb) (:short 'sth))
348 value (- (* ,offset n-word-bytes) ,lowtag) lip)
349 (move value result)))
350 (define-vop (,(symbolicate name "-C"))
352 `((:translate ,translate)))
354 (:args (object :scs (descriptor-reg))
355 (value :scs ,scs :target result))
358 (:constant (load/store-index ,scale
362 (:results (result :scs ,scs))
363 (:result-types ,el-type)
365 (inst ,(ecase size (:byte 'stb) (:short 'sth))
367 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
369 (move value result))))))