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.
15 (defmacro expand (expr)
16 (let ((gensym (gensym)))
22 ;;; Instruction-like macros.
23 ;;; FIXME-lav: add if always-emit-code-p is :e= then error if location=
24 (defmacro move (src dst &optional always-emit-code-p)
26 "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P is nil)."
27 (once-only ((n-src src)
29 `(if (location= ,n-dst ,n-src)
30 (when ,always-emit-code-p
32 (inst move ,n-src ,n-dst))))
34 (defmacro loadw (result base &optional (offset 0) (lowtag 0))
35 (once-only ((result result) (base base))
36 `(inst ldw (- (ash ,offset word-shift) ,lowtag) ,base ,result)))
38 (defmacro storew (value base &optional (offset 0) (lowtag 0))
39 (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
40 `(inst stw ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
42 (defmacro load-symbol (reg symbol)
43 (once-only ((reg reg) (symbol symbol))
44 `(let ((offset (static-symbol-offset ,symbol)))
46 ((typep offset '(signed-byte 11))
47 (inst addi offset null-tn ,reg))
49 (inst ldil offset ,reg)
50 (inst ldo offset null-tn ,reg :unsigned t))))))
52 (defmacro load-symbol-value (reg symbol)
54 (+ (static-symbol-offset ',symbol)
55 (ash symbol-value-slot word-shift)
56 (- other-pointer-lowtag))
59 (defmacro store-symbol-value (reg symbol)
60 `(inst stw ,reg (+ (static-symbol-offset ',symbol)
61 (ash symbol-value-slot word-shift)
62 (- other-pointer-lowtag))
65 (defmacro load-type (target source &optional (offset 0))
67 "Loads the type bits of a pointer into target independent of
68 byte-ordering issues."
69 (once-only ((n-target target)
72 (ecase *backend-byte-order*
74 `(inst ldb ,n-offset ,n-source ,n-target))
76 `(inst ldb (+ ,n-offset (1- n-word-bytes)) ,n-source ,n-target)))))
78 (defmacro set-lowtag (tag src dst)
81 (inst dep ,tag 31 n-lowtag-bits ,dst)))
83 ;;; Macros to handle the fact that we cannot use the machine native call and
84 ;;; return instructions.
86 (defmacro lisp-jump (function)
88 "Jump to the lisp function FUNCTION."
90 (inst addi (- (ash simple-fun-code-offset word-shift)
91 fun-pointer-lowtag) ,function lip-tn)
93 (move ,function code-tn t)))
95 (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
97 "Return to RETURN-PC."
99 (inst addi (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
101 (inst bv lip-tn ,@(unless frob-code '(:nullify t)))
103 `((move ,return-pc code-tn t)))))
105 (defmacro emit-return-pc (label)
107 "Emit a return-pc header word. LABEL is the label to use for this
110 ;; alignment causes the return point to land on two address,
111 ;; where the first must be nop pad.
112 (emit-alignment n-lowtag-bits)
114 (inst lra-header-word)))
119 ;;; Move a stack TN to a register and vice-versa.
120 (defmacro load-stack-tn (reg stack)
123 (let ((offset (tn-offset stack)))
126 (loadw reg cfp-tn offset))))))
128 (defmacro store-stack-tn (stack reg)
129 `(let ((stack ,stack)
131 (let ((offset (tn-offset stack)))
134 (storew reg cfp-tn offset))))))
136 (defmacro maybe-load-stack-tn (reg reg-or-stack)
138 "Move the TN Reg-Or-Stack into Reg if it isn't already there."
139 (once-only ((n-reg reg)
140 (n-stack reg-or-stack))
142 ((any-reg descriptor-reg)
144 ((any-reg descriptor-reg)
145 (move ,n-stack ,n-reg))
147 (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
150 ;;;; Storage allocation:
152 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code
153 size dynamic-extent-p
154 &key (lowtag other-pointer-lowtag)
158 "Do stuff to allocate an other-pointer object of fixed Size with a single
159 word header having the specified Type-Code. The result is placed in
160 Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
161 by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably
162 initializes the object."
163 (declare (ignore flag-tn))
164 (once-only ((result-tn result-tn) (temp-tn temp-tn)
165 (type-code type-code) (size size)
167 (let ((write-body `((inst li (logior (ash (1- ,size) n-widetag-bits) ,type-code) ,temp-tn)
168 (storew ,temp-tn ,result-tn 0 ,lowtag))))
169 `(if ,dynamic-extent-p
172 (set-lowtag ,lowtag csp-tn ,result-tn)
173 (inst addi (pad-data-block ,size) csp-tn csp-tn)
175 `((when ,type-code ,@write-body))
178 (pseudo-atomic (:extra (pad-data-block ,size))
179 (set-lowtag ,lowtag alloc-tn ,result-tn)
181 `((when ,type-code ,@write-body))
185 ;;; is used for stack allocation of dynamic-extent objects
186 ;;; FIXME-lav, if using defun, atleast surround in assembly-form ? macro better ?
187 (defun align-csp (temp)
188 (declare (ignore temp))
189 (let ((aligned (gen-label)))
190 (inst extru csp-tn 31 n-lowtag-bits zero-tn :<>)
191 (inst b aligned :nullify t)
192 (inst addi n-word-bytes csp-tn csp-tn)
193 (storew zero-tn csp-tn -1)
194 (emit-label aligned)))
198 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
199 (defun emit-error-break (vop kind code values)
200 (let ((vector (gensym)))
203 (note-this-location vop :internal-error)))
205 (with-adjustable-vector (,vector)
206 (write-var-integer (error-number-or-lose ',code) ,vector)
207 ,@(mapcar #'(lambda (tn)
209 (write-var-integer (make-sc-offset (sc-number
214 (inst byte (length ,vector))
215 (dotimes (i (length ,vector))
216 (inst byte (aref ,vector i))))
217 (emit-alignment word-shift)))))
219 (defmacro error-call (vop error-code &rest values)
221 "Cause an error. ERROR-CODE is the error to cause."
223 (emit-error-break vop error-trap error-code values)))
226 (defmacro cerror-call (vop label error-code &rest values)
228 "Cause a continuable error. If the error is continued, execution resumes at
231 (without-scheduling ()
233 ,@(emit-error-break vop cerror-trap error-code values))))
235 (defmacro generate-error-code (vop error-code &rest values)
237 "Generate-Error-Code Error-code Value*
238 Emit code for an error with the specified Error-Code and context Values."
239 `(assemble (*elsewhere*)
240 (let ((start-lab (gen-label)))
241 (emit-label start-lab)
242 (error-call ,vop ,error-code ,@values)
245 (defmacro generate-cerror-code (vop error-code &rest values)
247 "Generate-CError-Code Error-code Value*
248 Emit code for a continuable error with the specified Error-Code and
249 context Values. If the error is continued, execution resumes after
250 the GENERATE-CERROR-CODE form."
251 (with-unique-names (continue error)
252 `(let ((,continue (gen-label)))
253 (emit-label ,continue)
254 (assemble (*elsewhere*)
255 (let ((,error (gen-label)))
257 (cerror-call ,vop ,continue ,error-code ,@values)
262 ;;; handy macro for making sequences look atomic
263 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
264 (let ((n-extra (gensym)))
265 `(let ((,n-extra ,extra))
266 (inst addi 4 alloc-tn alloc-tn)
268 (inst addit (- ,n-extra 4) alloc-tn alloc-tn :od))))
270 ;;;; indexed references
272 (deftype load/store-index (scale lowtag min-offset
273 &optional (max-offset min-offset))
274 `(integer ,(- (truncate (+ (ash 1 14)
275 (* min-offset n-word-bytes)
278 ,(truncate (- (+ (1- (ash 1 14)) lowtag)
279 (* max-offset n-word-bytes))
282 (defmacro define-full-reffer (name type offset lowtag scs el-type
287 `((:translate ,translate)))
289 (:args (object :scs (descriptor-reg))
290 (index :scs (any-reg)))
291 (:arg-types ,type tagged-num)
292 (:temporary (:scs (interior-reg)) lip)
293 (:results (value :scs ,scs))
294 (:result-types ,el-type)
296 (inst add object index lip)
297 (loadw value lip ,offset ,lowtag)))
298 (define-vop (,(symbolicate name "-C"))
300 `((:translate ,translate)))
302 (:args (object :scs (descriptor-reg)))
305 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
307 (:results (value :scs ,scs))
308 (:result-types ,el-type)
310 (loadw value object (+ ,offset index) ,lowtag)))))
312 (defmacro define-full-setter (name type offset lowtag scs el-type
317 `((:translate ,translate)))
319 (:args (object :scs (descriptor-reg))
320 (index :scs (any-reg))
321 (value :scs ,scs :target result))
322 (:arg-types ,type tagged-num ,el-type)
323 (:temporary (:scs (interior-reg)) lip)
324 (:results (result :scs ,scs))
325 (:result-types ,el-type)
327 (inst add object index lip)
328 (storew value lip ,offset ,lowtag)
329 (move value result)))
330 (define-vop (,(symbolicate name "-C"))
332 `((:translate ,translate)))
334 (:args (object :scs (descriptor-reg))
338 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
341 (:results (result :scs ,scs))
342 (:result-types ,el-type)
344 (storew value object (+ ,offset index) ,lowtag)
345 (move value result)))))
348 (defmacro define-partial-reffer (name type size signed offset lowtag scs
349 el-type &optional translate)
350 (let ((scale (ecase size (:byte 1) (:short 2))))
354 `((:translate ,translate)))
356 (:args (object :scs (descriptor-reg) :to (:eval 0))
357 (index :scs (unsigned-reg)))
358 (:arg-types ,type positive-fixnum)
359 (:results (value :scs ,scs))
360 (:result-types ,el-type)
361 (:temporary (:scs (interior-reg)) lip)
363 (inst ,(ecase size (:byte 'add) (:short 'sh1add))
365 (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
366 (- (* ,offset n-word-bytes) ,lowtag) lip value)
368 `((inst extrs value 31 ,(* scale n-byte-bits) value)))))
369 (define-vop (,(symbolicate name "-C"))
371 `((:translate ,translate)))
373 (:args (object :scs (descriptor-reg)))
376 (:constant (load/store-index ,scale
379 (:results (value :scs ,scs))
380 (:result-types ,el-type)
382 (inst ,(ecase size (:byte 'ldb) (:short 'ldh))
383 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
386 `((inst extrs value 31 ,(* scale n-byte-bits) value))))))))
388 (defmacro define-partial-setter (name type size offset lowtag scs el-type
390 (let ((scale (ecase size (:byte 1) (:short 2))))
394 `((:translate ,translate)))
396 (:args (object :scs (descriptor-reg))
397 (index :scs (unsigned-reg))
398 (value :scs ,scs :target result))
399 (:arg-types ,type positive-fixnum ,el-type)
400 (:temporary (:scs (interior-reg)) lip)
401 (:results (result :scs ,scs))
402 (:result-types ,el-type)
404 (inst ,(ecase size (:byte 'add) (:short 'sh1add))
406 (inst ,(ecase size (:byte 'stb) (:short 'sth))
407 value (- (* ,offset n-word-bytes) ,lowtag) lip)
408 (move value result)))
409 (define-vop (,(symbolicate name "-C"))
411 `((:translate ,translate)))
413 (:args (object :scs (descriptor-reg))
414 (value :scs ,scs :target result))
417 (:constant (load/store-index ,scale
421 (:results (result :scs ,scs))
422 (:result-types ,el-type)
424 (inst ,(ecase size (:byte 'stb) (:short 'sth))
426 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag)
428 (move value result))))))
431 (def!macro with-pinned-objects ((&rest objects) &body body)
432 "Arrange with the garbage collector that the pages occupied by
433 OBJECTS will not be moved in memory for the duration of BODY.
434 Useful for e.g. foreign calls where another thread may trigger
435 garbage collection. This is currently implemented by disabling GC"
436 (declare (ignore objects)) ;should we eval these for side-effect?