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 (with-unique-names (continue error)
228 `(let ((,continue (gen-label)))
229 (emit-label ,continue)
230 (assemble (*elsewhere*)
231 (let ((,error (gen-label)))
233 (cerror-call ,vop ,continue ,error-code ,@values)
237 ;;; a handy macro for making sequences look atomic
238 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
240 (inst addq alloc-tn 1 alloc-tn)
242 (inst lda alloc-tn (1- ,extra) alloc-tn)
243 (inst stl zero-tn 0 alloc-tn)))
245 ;;;; memory accessor vop generators
247 (defmacro define-full-reffer (name type offset lowtag scs el-type
252 `((:translate ,translate)))
254 (:args (object :scs (descriptor-reg))
255 (index :scs (any-reg)))
256 (:arg-types ,type tagged-num)
257 (:temporary (:scs (interior-reg)) lip)
258 (:results (value :scs ,scs))
259 (:result-types ,el-type)
261 (inst addq object index lip)
262 (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip)
263 ,@(when (equal scs '(unsigned-reg))
264 '((inst mskll value 4 value)))))
265 (define-vop (,(symbolicate name "-C"))
267 `((:translate ,translate)))
269 (:args (object :scs (descriptor-reg)))
272 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
274 (:results (value :scs ,scs))
275 (:result-types ,el-type)
277 (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
279 ,@(when (equal scs '(unsigned-reg))
280 '((inst mskll value 4 value)))))))
282 (defmacro define-full-setter (name type offset lowtag scs el-type
283 &optional translate #!+gengc (remember t))
287 `((:translate ,translate)))
289 (:args (object :scs (descriptor-reg))
290 (index :scs (any-reg))
291 (value :scs ,scs :target result))
292 (:arg-types ,type tagged-num ,el-type)
293 (:temporary (:scs (interior-reg)) lip)
294 (:results (result :scs ,scs))
295 (:result-types ,el-type)
297 (inst addq index object lip)
298 (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip)
299 (move value result)))
300 (define-vop (,(symbolicate name "-C"))
302 `((:translate ,translate)))
304 (:args (object :scs (descriptor-reg))
308 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
311 (:results (result :scs ,scs))
312 (:result-types ,el-type)
314 (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
316 (move value result)))))
319 (defmacro define-partial-reffer (name type size signed offset lowtag scs
320 el-type &optional translate)
321 (let ((scale (ecase size (:byte 1) (:short 2))))
325 `((:translate ,translate)))
327 (:args (object :scs (descriptor-reg))
328 (index :scs (unsigned-reg)))
329 (:arg-types ,type positive-fixnum)
330 (:results (value :scs ,scs))
331 (:result-types ,el-type)
332 (:temporary (:scs (interior-reg)) lip)
333 (:temporary (:sc non-descriptor-reg) temp)
334 (:temporary (:sc non-descriptor-reg) temp1)
336 (inst addq object index lip)
337 ,@(when (eq size :short)
338 '((inst addq index lip lip)))
342 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
344 (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag))
346 (inst extqh temp temp1 temp)
347 (inst sra temp 56 value))
350 (- (* ,offset n-word-bytes) ,lowtag)
352 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
354 (inst extbl temp temp1 value))))
357 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
359 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
361 (inst extwl temp temp1 temp)
362 (inst sll temp 48 temp)
363 (inst sra temp 48 value))
364 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
366 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
367 (inst extwl temp temp1 value)))))))
368 (define-vop (,(symbolicate name "-C"))
370 `((:translate ,translate)))
372 (:args (object :scs (descriptor-reg)))
375 (:constant (load/store-index ,scale
378 (:results (value :scs ,scs))
379 (:result-types ,el-type)
380 (:temporary (:sc non-descriptor-reg) temp)
381 (:temporary (:sc non-descriptor-reg) temp1)
386 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
387 (* index ,scale)) ,lowtag)
389 (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes)
390 (* index ,scale)) ,lowtag))
392 (inst extqh temp temp1 temp)
393 (inst sra temp 56 value))
394 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
395 (* index ,scale)) ,lowtag)
397 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
398 (* index ,scale)) ,lowtag)
400 (inst extbl temp temp1 value))))
403 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
404 (* index ,scale)) ,lowtag)
406 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
407 (* index ,scale)) ,lowtag)
409 (inst extwl temp temp1 temp)
410 (inst sll temp 48 temp)
411 (inst sra temp 48 value))
412 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
413 (* index ,scale)) ,lowtag)
415 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
416 (* index ,scale)) ,lowtag)
418 (inst extwl temp temp1 value))))))))))
420 (defmacro define-partial-setter (name type size offset lowtag scs el-type
422 (let ((scale (ecase size (:byte 1) (:short 2))))
426 `((:translate ,translate)))
428 (:args (object :scs (descriptor-reg))
429 (index :scs (unsigned-reg))
430 (value :scs ,scs :target result))
431 (:arg-types ,type positive-fixnum ,el-type)
432 (:temporary (:scs (interior-reg)) lip)
433 (:temporary (:sc non-descriptor-reg) temp)
434 (:temporary (:sc non-descriptor-reg) temp1)
435 (:temporary (:sc non-descriptor-reg) temp2)
436 (:results (result :scs ,scs))
437 (:result-types ,el-type)
439 (inst addq object index lip)
440 ,@(when (eq size :short)
441 '((inst addq lip index lip)))
444 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
445 (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
446 (inst insbl value temp temp2)
447 (inst mskbl temp1 temp temp1)
448 (inst bis temp1 temp2 temp1)
449 (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)))
451 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
452 (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
453 (inst mskwl temp1 temp temp1)
454 (inst inswl value temp temp2)
455 (inst bis temp1 temp2 temp)
456 (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip))))
457 (move value result)))
458 (define-vop (,(symbolicate name "-C"))
460 `((:translate ,translate)))
462 (:args (object :scs (descriptor-reg))
463 (value :scs ,scs :target result))
466 (:constant (load/store-index ,scale
470 (:temporary (:sc non-descriptor-reg) temp)
471 (:temporary (:sc non-descriptor-reg) temp1)
472 (:temporary (:sc non-descriptor-reg) temp2)
473 (:results (result :scs ,scs))
474 (:result-types ,el-type)
478 `((inst lda temp (- (* ,offset n-word-bytes)
479 (* index ,scale) ,lowtag)
481 (inst ldq_u temp1 (- (* ,offset n-word-bytes)
482 (* index ,scale) ,lowtag)
484 (inst insbl value temp temp2)
485 (inst mskbl temp1 temp temp1)
486 (inst bis temp1 temp2 temp1)
487 (inst stq_u temp1 (- (* ,offset n-word-bytes)
488 (* index ,scale) ,lowtag) object)))
490 `((inst lda temp (- (* ,offset n-word-bytes)
491 (* index ,scale) ,lowtag)
493 (inst ldq_u temp1 (- (* ,offset n-word-bytes)
494 (* index ,scale) ,lowtag)
496 (inst mskwl temp1 temp temp1)
497 (inst inswl value temp temp2)
498 (inst bis temp1 temp2 temp)
499 (inst stq_u temp (- (* ,offset n-word-bytes)
500 (* index ,scale) ,lowtag) object))))
501 (move value result))))))