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 (with-unique-names (continue error)
188 `(let ((,continue (gen-label)))
189 (emit-label ,continue)
190 (assemble (*elsewhere*)
191 (let ((,error (gen-label)))
193 (cerror-call ,vop ,continue ,error-code ,@values)
198 ;;; handy macro for making sequences look atomic
199 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
200 (let ((n-extra (gensym)))
201 `(let ((,n-extra ,extra))
202 (inst addi 4 alloc-tn alloc-tn)
204 (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))
206 ;;;; indexed references
208 (deftype load/store-index (scale lowtag min-offset
209 &optional (max-offset min-offset))
210 `(integer ,(- (truncate (+ (ash 1 14)
211 (* min-offset n-word-bytes)
214 ,(truncate (- (+ (1- (ash 1 14)) lowtag)
215 (* max-offset n-word-bytes))
218 (defmacro define-full-reffer (name type offset lowtag scs el-type
223 `((:translate ,translate)))
225 (:args (object :scs (descriptor-reg) :to (:eval 0))
226 (index :scs (any-reg) :target temp))
227 (:arg-types ,type tagged-num)
228 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) temp)
229 (:results (value :scs ,scs))
230 (:result-types ,el-type)
232 (inst addi (- (* ,offset n-word-bytes) ,lowtag) index temp)
233 (inst ldwx temp object value)))
234 (define-vop (,(symbolicate name "-C"))
236 `((:translate ,translate)))
238 (:args (object :scs (descriptor-reg)))
241 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
243 (:results (value :scs ,scs))
244 (:result-types ,el-type)
246 (inst ldw (- (* (+ ,offset index) n-word-bytes) ,lowtag)
249 (defmacro define-full-setter (name type offset lowtag scs el-type
254 `((:translate ,translate)))
256 (:args (object :scs (descriptor-reg))
257 (index :scs (any-reg))
258 (value :scs ,scs :target result))
259 (:arg-types ,type tagged-num ,el-type)
260 (:temporary (:scs (interior-reg)) lip)
261 (:results (result :scs ,scs))
262 (:result-types ,el-type)
264 (inst add object index lip)
265 (inst stw value (- (* ,offset n-word-bytes) ,lowtag) lip)
266 (move value result)))
267 (define-vop (,(symbolicate name "-C"))
269 `((:translate ,translate)))
271 (:args (object :scs (descriptor-reg))
275 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
278 (:results (result :scs ,scs))
279 (:result-types ,el-type)
281 (inst stw value (- (* (+ ,offset index) n-word-bytes) ,lowtag) object)
282 (move value result)))))
285 (defmacro define-partial-reffer (name type size signed offset lowtag scs
286 el-type &optional translate)
287 (let ((scale (ecase size (:byte 1) (:short 2))))
291 `((:translate ,translate)))
293 (:args (object :scs (descriptor-reg) :to (:eval 0))
294 (index :scs (unsigned-reg)))
295 (:arg-types ,type positive-fixnum)
296 (:results (value :scs ,scs))
297 (:result-types ,el-type)
298 (:temporary (:scs (interior-reg)) lip)
300 (inst ,(ecase size (:byte 'add) (:short 'sh1add))
302 (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
303 (- (* ,offset n-word-bytes) ,lowtag) lip value)
305 `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
306 (define-vop (,(symbolicate name "-C"))
308 `((:translate ,translate)))
310 (:args (object :scs (descriptor-reg)))
313 (:constant (load/store-index ,scale
316 (:results (value :scs ,scs))
317 (:result-types ,el-type)
319 (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
320 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
323 `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
325 (defmacro define-partial-setter (name type size offset lowtag scs el-type
327 (let ((scale (ecase size (:byte 1) (:short 2))))
331 `((:translate ,translate)))
333 (:args (object :scs (descriptor-reg))
334 (index :scs (unsigned-reg))
335 (value :scs ,scs :target result))
336 (:arg-types ,type positive-fixnum ,el-type)
337 (:temporary (:scs (interior-reg)) lip)
338 (:results (result :scs ,scs))
339 (:result-types ,el-type)
341 (inst ,(ecase size (:byte 'add) (:short 'sh1add))
343 (inst ,(ecase size (:byte 'stb) (:short 'sth))
344 value (- (* ,offset n-word-bytes) ,lowtag) lip)
345 (move value result)))
346 (define-vop (,(symbolicate name "-C"))
348 `((:translate ,translate)))
350 (:args (object :scs (descriptor-reg))
351 (value :scs ,scs :target result))
354 (:constant (load/store-index ,scale
358 (:results (result :scs ,scs))
359 (:result-types ,el-type)
361 (inst ,(ecase size (:byte 'stb) (:short 'sth))
363 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
365 (move value result))))))