1 ;;;; various useful macros for generating Alpha 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 ;;; a handy macro for defining top level forms that depend on the
15 ;;; compile environment
16 (defmacro expand (expr)
17 (let ((gensym (gensym)))
23 ;;; instruction-like macros
26 ;;(defmacro move (dst src)
28 ;; "Move SRC into DST unless they are location=."
29 ;; (once-only ((n-dst dst)
31 ;; `(unless (location= ,n-dst ,n-src)
32 ;; (inst mov ,n-dst ,n-src))))
34 (defmacro move (src dst)
35 "Move SRC into DST unless they are location=."
36 (once-only ((n-src src) (n-dst dst))
37 `(unless (location= ,n-src ,n-dst)
38 (inst move ,n-src ,n-dst))))
40 (defmacro loadw (result base &optional (offset 0) (lowtag 0))
41 (once-only ((result result) (base base))
42 `(inst ldl ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
44 (defmacro loadq (result base &optional (offset 0) (lowtag 0))
45 (once-only ((result result) (base base))
46 `(inst ldq ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
48 (defmacro storew (value base &optional (offset 0) (lowtag 0))
49 (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
50 `(inst stl ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
52 (defmacro storeq (value base &optional (offset 0) (lowtag 0))
53 (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
54 `(inst stq ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
56 (defmacro load-symbol (reg symbol)
57 (once-only ((reg reg) (symbol symbol))
58 `(inst lda ,reg (static-symbol-offset ,symbol) null-tn)))
60 (defmacro load-symbol-value (reg symbol)
62 (+ (static-symbol-offset ',symbol)
63 (ash symbol-value-slot word-shift)
64 (- other-pointer-lowtag))
67 (defmacro store-symbol-value (reg symbol)
69 (+ (static-symbol-offset ',symbol)
70 (ash symbol-value-slot word-shift)
71 (- other-pointer-lowtag))
74 (defmacro load-type (target source &optional (offset 0))
75 "Loads the type bits of a pointer into target independent of
76 byte-ordering issues."
77 (once-only ((n-target target)
81 (inst ldl ,n-target ,n-offset ,n-source)
82 (inst and ,n-target #xff ,n-target))))
84 ;;; macros to handle the fact that we cannot use the machine native
85 ;;; call and return instructions
87 (defmacro lisp-jump (function lip)
88 "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
90 (inst lda ,lip (- (ash sb!vm:simple-fun-code-offset sb!vm:word-shift)
91 sb!vm:fun-pointer-lowtag)
93 (move ,function code-tn)
94 (inst jsr zero-tn ,lip 1)))
96 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
97 "Return to RETURN-PC. LIP is an interior-reg temporary."
100 (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
103 `((move ,return-pc code-tn)))
104 (inst ret zero-tn ,lip 1)))
107 (defmacro emit-return-pc (label)
108 "Emit a return-pc header word. LABEL is the label to use for this
111 (align n-lowtag-bits)
113 (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))))))
127 (defmacro store-stack-tn (stack reg)
128 `(let ((stack ,stack)
130 (let ((offset (tn-offset stack)))
133 (storew reg cfp-tn offset))))))
135 ;;; Move the TN Reg-Or-Stack into Reg if it isn't already there.
136 (defmacro maybe-load-stack-tn (reg reg-or-stack)
137 (once-only ((n-reg reg)
138 (n-stack reg-or-stack))
140 ((any-reg descriptor-reg)
142 ((any-reg descriptor-reg)
143 (move ,n-stack ,n-reg))
145 (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
147 ;;; Move the TN Reg-Or-Stack into Reg if it isn't already there.
148 (defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp)
149 (once-only ((n-reg reg)
150 (n-stack reg-or-stack))
153 ((any-reg descriptor-reg)
155 ((any-reg descriptor-reg)
156 (move ,n-stack ,n-reg))
158 (loadw ,n-reg cfp-tn (tn-offset ,n-stack))
159 (inst mskll nsp-tn 0 ,temp)
160 (inst bis ,temp ,n-reg ,n-reg))))))))
162 ;;;; storage allocation
164 ;;; Do stuff to allocate an other-pointer object of fixed SIZE with a
165 ;;; single word header having the specified WIDETAG value. The result is
166 ;;; placed in RESULT-TN, Flag-Tn must be wired to NL3-OFFSET, and
167 ;;; Temp-TN is a non- descriptor temp (which may be randomly used by
168 ;;; the body.) The body is placed inside the PSEUDO-ATOMIC, and
169 ;;; presumably initializes the object.
170 (defmacro with-fixed-allocation ((result-tn temp-tn widetag size)
172 `(pseudo-atomic (:extra (pad-data-block ,size))
173 (inst bis alloc-tn other-pointer-lowtag ,result-tn)
174 (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn)
175 (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
179 (eval-when (:compile-toplevel :load-toplevel :execute)
180 (defun emit-error-break (vop kind code values)
181 (let ((vector (gensym)))
184 (note-this-location vop :internal-error)))
186 (with-adjustable-vector (,vector)
187 (write-var-integer (error-number-or-lose ',code) ,vector)
188 ,@(mapcar (lambda (tn)
190 (write-var-integer (make-sc-offset (sc-number
195 (inst byte (length ,vector))
196 (dotimes (i (length ,vector))
197 (inst byte (aref ,vector i))))
198 (align word-shift)))))
200 (defmacro error-call (vop error-code &rest values)
201 "Cause an error. ERROR-CODE is the error to cause."
203 (emit-error-break vop error-trap error-code values)))
206 (defmacro cerror-call (vop label error-code &rest values)
207 "Cause a continuable error. If the error is continued, execution resumes at
210 (inst br zero-tn ,label)
211 ,@(emit-error-break vop cerror-trap error-code values)))
213 (defmacro generate-error-code (vop error-code &rest values)
214 "Generate-Error-Code Error-code Value*
215 Emit code for an error with the specified Error-Code and context Values."
216 `(assemble (*elsewhere*)
217 (let ((start-lab (gen-label)))
218 (emit-label start-lab)
219 (error-call ,vop ,error-code ,@values)
222 (defmacro generate-cerror-code (vop error-code &rest values)
223 "Generate-CError-Code Error-code Value*
224 Emit code for a continuable error with the specified Error-Code and
225 context Values. If the error is continued, execution resumes after
226 the GENERATE-CERROR-CODE form."
227 (let ((continue (gensym "CONTINUE-LABEL-"))
228 (error (gensym "ERROR-LABEL-")))
229 `(let ((,continue (gen-label)))
230 (emit-label ,continue)
231 (assemble (*elsewhere*)
232 (let ((,error (gen-label)))
234 (cerror-call ,vop ,continue ,error-code ,@values)
238 ;;; a handy macro for making sequences look atomic
239 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
241 (inst addq alloc-tn 1 alloc-tn)
243 (inst lda alloc-tn (1- ,extra) alloc-tn)
244 (inst stl zero-tn 0 alloc-tn)))
246 ;;;; memory accessor vop generators
248 (defmacro define-full-reffer (name type offset lowtag scs el-type
253 `((:translate ,translate)))
255 (:args (object :scs (descriptor-reg))
256 (index :scs (any-reg)))
257 (:arg-types ,type tagged-num)
258 (:temporary (:scs (interior-reg)) lip)
259 (:results (value :scs ,scs))
260 (:result-types ,el-type)
262 (inst addq object index lip)
263 (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip)
264 ,@(when (equal scs '(unsigned-reg))
265 '((inst mskll value 4 value)))))
266 (define-vop (,(symbolicate name "-C"))
268 `((:translate ,translate)))
270 (:args (object :scs (descriptor-reg)))
273 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
275 (:results (value :scs ,scs))
276 (:result-types ,el-type)
278 (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
280 ,@(when (equal scs '(unsigned-reg))
281 '((inst mskll value 4 value)))))))
283 (defmacro define-full-setter (name type offset lowtag scs el-type
284 &optional translate #!+gengc (remember t))
288 `((:translate ,translate)))
290 (:args (object :scs (descriptor-reg))
291 (index :scs (any-reg))
292 (value :scs ,scs :target result))
293 (:arg-types ,type tagged-num ,el-type)
294 (:temporary (:scs (interior-reg)) lip)
295 (:results (result :scs ,scs))
296 (:result-types ,el-type)
298 (inst addq index object lip)
299 (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip)
300 (move value result)))
301 (define-vop (,(symbolicate name "-C"))
303 `((:translate ,translate)))
305 (:args (object :scs (descriptor-reg))
309 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
312 (:results (result :scs ,scs))
313 (:result-types ,el-type)
315 (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
317 (move value result)))))
320 (defmacro define-partial-reffer (name type size signed offset lowtag scs
321 el-type &optional translate)
322 (let ((scale (ecase size (:byte 1) (:short 2))))
326 `((:translate ,translate)))
328 (:args (object :scs (descriptor-reg))
329 (index :scs (unsigned-reg)))
330 (:arg-types ,type positive-fixnum)
331 (:results (value :scs ,scs))
332 (:result-types ,el-type)
333 (:temporary (:scs (interior-reg)) lip)
334 (:temporary (:sc non-descriptor-reg) temp)
335 (:temporary (:sc non-descriptor-reg) temp1)
337 (inst addq object index lip)
338 ,@(when (eq size :short)
339 '((inst addq index lip lip)))
343 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
345 (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag))
347 (inst extqh temp temp1 temp)
348 (inst sra temp 56 value))
351 (- (* ,offset n-word-bytes) ,lowtag)
353 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
355 (inst extbl temp temp1 value))))
358 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
360 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
362 (inst extwl temp temp1 temp)
363 (inst sll temp 48 temp)
364 (inst sra temp 48 value))
365 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
367 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
368 (inst extwl temp temp1 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)
381 (:temporary (:sc non-descriptor-reg) temp)
382 (:temporary (:sc non-descriptor-reg) temp1)
387 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
388 (* index ,scale)) ,lowtag)
390 (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes)
391 (* index ,scale)) ,lowtag))
393 (inst extqh temp temp1 temp)
394 (inst sra temp 56 value))
395 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
396 (* index ,scale)) ,lowtag)
398 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
399 (* index ,scale)) ,lowtag)
401 (inst extbl temp temp1 value))))
404 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
405 (* index ,scale)) ,lowtag)
407 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
408 (* index ,scale)) ,lowtag)
410 (inst extwl temp temp1 temp)
411 (inst sll temp 48 temp)
412 (inst sra temp 48 value))
413 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
414 (* index ,scale)) ,lowtag)
416 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
417 (* index ,scale)) ,lowtag)
419 (inst extwl temp temp1 value))))))))))
421 (defmacro define-partial-setter (name type size offset lowtag scs el-type
423 (let ((scale (ecase size (:byte 1) (:short 2))))
427 `((:translate ,translate)))
429 (:args (object :scs (descriptor-reg))
430 (index :scs (unsigned-reg))
431 (value :scs ,scs :target result))
432 (:arg-types ,type positive-fixnum ,el-type)
433 (:temporary (:scs (interior-reg)) lip)
434 (:temporary (:sc non-descriptor-reg) temp)
435 (:temporary (:sc non-descriptor-reg) temp1)
436 (:temporary (:sc non-descriptor-reg) temp2)
437 (:results (result :scs ,scs))
438 (:result-types ,el-type)
440 (inst addq object index lip)
441 ,@(when (eq size :short)
442 '((inst addq lip index lip)))
445 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
446 (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
447 (inst insbl value temp temp2)
448 (inst mskbl temp1 temp temp1)
449 (inst bis temp1 temp2 temp1)
450 (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)))
452 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
453 (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
454 (inst mskwl temp1 temp temp1)
455 (inst inswl value temp temp2)
456 (inst bis temp1 temp2 temp)
457 (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip))))
458 (move value result)))
459 (define-vop (,(symbolicate name "-C"))
461 `((:translate ,translate)))
463 (:args (object :scs (descriptor-reg))
464 (value :scs ,scs :target result))
467 (:constant (load/store-index ,scale
471 (:temporary (:sc non-descriptor-reg) temp)
472 (:temporary (:sc non-descriptor-reg) temp1)
473 (:temporary (:sc non-descriptor-reg) temp2)
474 (:results (result :scs ,scs))
475 (:result-types ,el-type)
479 `((inst lda temp (- (* ,offset n-word-bytes)
480 (* index ,scale) ,lowtag)
482 (inst ldq_u temp1 (- (* ,offset n-word-bytes)
483 (* index ,scale) ,lowtag)
485 (inst insbl value temp temp2)
486 (inst mskbl temp1 temp temp1)
487 (inst bis temp1 temp2 temp1)
488 (inst stq_u temp1 (- (* ,offset n-word-bytes)
489 (* index ,scale) ,lowtag) object)))
491 `((inst lda temp (- (* ,offset n-word-bytes)
492 (* index ,scale) ,lowtag)
494 (inst ldq_u temp1 (- (* ,offset n-word-bytes)
495 (* index ,scale) ,lowtag)
497 (inst mskwl temp1 temp temp1)
498 (inst inswl value temp temp2)
499 (inst bis temp1 temp2 temp)
500 (inst stq_u temp (- (* ,offset n-word-bytes)
501 (* index ,scale) ,lowtag) object))))
502 (move value result))))))