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)
180 (defvar *adjustable-vectors* nil)
182 (defmacro with-adjustable-vector ((var) &rest body)
183 `(let ((,var (or (pop *adjustable-vectors*)
185 :element-type '(unsigned-byte 8)
188 (setf (fill-pointer ,var) 0)
192 (push ,var *adjustable-vectors*))))
194 (eval-when (:compile-toplevel :load-toplevel :execute)
195 (defun emit-error-break (vop kind code values)
196 (let ((vector (gensym)))
199 (note-this-location vop :internal-error)))
201 (with-adjustable-vector (,vector)
202 (write-var-integer (error-number-or-lose ',code) ,vector)
203 ,@(mapcar (lambda (tn)
205 (write-var-integer (make-sc-offset (sc-number
210 (inst byte (length ,vector))
211 (dotimes (i (length ,vector))
212 (inst byte (aref ,vector i))))
213 (align word-shift)))))
215 (defmacro error-call (vop error-code &rest values)
216 "Cause an error. ERROR-CODE is the error to cause."
218 (emit-error-break vop error-trap error-code values)))
221 (defmacro cerror-call (vop label error-code &rest values)
222 "Cause a continuable error. If the error is continued, execution resumes at
225 (inst br zero-tn ,label)
226 ,@(emit-error-break vop cerror-trap error-code values)))
228 (defmacro generate-error-code (vop error-code &rest values)
229 "Generate-Error-Code Error-code Value*
230 Emit code for an error with the specified Error-Code and context Values."
231 `(assemble (*elsewhere*)
232 (let ((start-lab (gen-label)))
233 (emit-label start-lab)
234 (error-call ,vop ,error-code ,@values)
237 (defmacro generate-cerror-code (vop error-code &rest values)
238 "Generate-CError-Code Error-code Value*
239 Emit code for a continuable error with the specified Error-Code and
240 context Values. If the error is continued, execution resumes after
241 the GENERATE-CERROR-CODE form."
242 (let ((continue (gensym "CONTINUE-LABEL-"))
243 (error (gensym "ERROR-LABEL-")))
244 `(let ((,continue (gen-label)))
245 (emit-label ,continue)
246 (assemble (*elsewhere*)
247 (let ((,error (gen-label)))
249 (cerror-call ,vop ,continue ,error-code ,@values)
253 ;;; a handy macro for making sequences look atomic
254 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
256 (inst addq alloc-tn 1 alloc-tn)
258 (inst lda alloc-tn (1- ,extra) alloc-tn)
259 (inst stl zero-tn 0 alloc-tn)))
261 ;;;; memory accessor vop generators
263 (deftype load/store-index (scale lowtag min-offset
264 &optional (max-offset min-offset))
265 `(integer ,(- (truncate (+ (ash 1 16)
266 (* min-offset n-word-bytes)
269 ,(truncate (- (+ (1- (ash 1 16)) lowtag)
270 (* max-offset n-word-bytes))
273 (defmacro define-full-reffer (name type offset lowtag scs el-type
278 `((:translate ,translate)))
280 (:args (object :scs (descriptor-reg))
281 (index :scs (any-reg)))
282 (:arg-types ,type tagged-num)
283 (:temporary (:scs (interior-reg)) lip)
284 (:results (value :scs ,scs))
285 (:result-types ,el-type)
287 (inst addq object index lip)
288 (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip)
289 ,@(when (equal scs '(unsigned-reg))
290 '((inst mskll value 4 value)))))
291 (define-vop (,(symbolicate name "-C"))
293 `((:translate ,translate)))
295 (:args (object :scs (descriptor-reg)))
298 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
300 (:results (value :scs ,scs))
301 (:result-types ,el-type)
303 (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
305 ,@(when (equal scs '(unsigned-reg))
306 '((inst mskll value 4 value)))))))
308 (defmacro define-full-setter (name type offset lowtag scs el-type
309 &optional translate #+gengc (remember t))
313 `((:translate ,translate)))
315 (:args (object :scs (descriptor-reg))
316 (index :scs (any-reg))
317 (value :scs ,scs :target result))
318 (:arg-types ,type tagged-num ,el-type)
319 (:temporary (:scs (interior-reg)) lip)
320 (:results (result :scs ,scs))
321 (:result-types ,el-type)
323 (inst addq index object lip)
324 (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip)
325 (move value result)))
326 (define-vop (,(symbolicate name "-C"))
328 `((:translate ,translate)))
330 (:args (object :scs (descriptor-reg))
334 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
337 (:results (result :scs ,scs))
338 (:result-types ,el-type)
340 (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
342 (move value result)))))
345 (defmacro define-partial-reffer (name type size signed offset lowtag scs
346 el-type &optional translate)
347 (let ((scale (ecase size (:byte 1) (:short 2))))
351 `((:translate ,translate)))
353 (:args (object :scs (descriptor-reg))
354 (index :scs (unsigned-reg)))
355 (:arg-types ,type positive-fixnum)
356 (:results (value :scs ,scs))
357 (:result-types ,el-type)
358 (:temporary (:scs (interior-reg)) lip)
359 (:temporary (:sc non-descriptor-reg) temp)
360 (:temporary (:sc non-descriptor-reg) temp1)
362 (inst addq object index lip)
363 ,@(when (eq size :short)
364 '((inst addq index lip lip)))
368 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
370 (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag))
372 (inst extqh temp temp1 temp)
373 (inst sra temp 56 value))
376 (- (* ,offset n-word-bytes) ,lowtag)
378 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
380 (inst extbl temp temp1 value))))
383 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
385 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
387 (inst extwl temp temp1 temp)
388 (inst sll temp 48 temp)
389 (inst sra temp 48 value))
390 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
392 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
393 (inst extwl temp temp1 value)))))))
394 (define-vop (,(symbolicate name "-C"))
396 `((:translate ,translate)))
398 (:args (object :scs (descriptor-reg)))
401 (:constant (load/store-index ,scale
404 (:results (value :scs ,scs))
405 (:result-types ,el-type)
406 (:temporary (:sc non-descriptor-reg) temp)
407 (:temporary (:sc non-descriptor-reg) temp1)
412 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
413 (* index ,scale)) ,lowtag)
415 (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes)
416 (* index ,scale)) ,lowtag))
418 (inst extqh temp temp1 temp)
419 (inst sra temp 56 value))
420 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
421 (* index ,scale)) ,lowtag)
423 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
424 (* index ,scale)) ,lowtag)
426 (inst extbl temp temp1 value))))
429 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
430 (* index ,scale)) ,lowtag)
432 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
433 (* index ,scale)) ,lowtag)
435 (inst extwl temp temp1 temp)
436 (inst sll temp 48 temp)
437 (inst sra temp 48 value))
438 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
439 (* index ,scale)) ,lowtag)
441 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
442 (* index ,scale)) ,lowtag)
444 (inst extwl temp temp1 value))))))))))
446 (defmacro define-partial-setter (name type size offset lowtag scs el-type
448 (let ((scale (ecase size (:byte 1) (:short 2))))
452 `((:translate ,translate)))
454 (:args (object :scs (descriptor-reg))
455 (index :scs (unsigned-reg))
456 (value :scs ,scs :target result))
457 (:arg-types ,type positive-fixnum ,el-type)
458 (:temporary (:scs (interior-reg)) lip)
459 (:temporary (:sc non-descriptor-reg) temp)
460 (:temporary (:sc non-descriptor-reg) temp1)
461 (:temporary (:sc non-descriptor-reg) temp2)
462 (:results (result :scs ,scs))
463 (:result-types ,el-type)
465 (inst addq object index lip)
466 ,@(when (eq size :short)
467 '((inst addq lip index lip)))
470 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
471 (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
472 (inst insbl value temp temp2)
473 (inst mskbl temp1 temp temp1)
474 (inst bis temp1 temp2 temp1)
475 (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)))
477 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
478 (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
479 (inst mskwl temp1 temp temp1)
480 (inst inswl value temp temp2)
481 (inst bis temp1 temp2 temp)
482 (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip))))
483 (move value result)))
484 (define-vop (,(symbolicate name "-C"))
486 `((:translate ,translate)))
488 (:args (object :scs (descriptor-reg))
489 (value :scs ,scs :target result))
492 (:constant (load/store-index ,scale
496 (:temporary (:sc non-descriptor-reg) temp)
497 (:temporary (:sc non-descriptor-reg) temp1)
498 (:temporary (:sc non-descriptor-reg) temp2)
499 (:results (result :scs ,scs))
500 (:result-types ,el-type)
504 `((inst lda temp (- (* ,offset n-word-bytes)
505 (* index ,scale) ,lowtag)
507 (inst ldq_u temp1 (- (* ,offset n-word-bytes)
508 (* index ,scale) ,lowtag)
510 (inst insbl value temp temp2)
511 (inst mskbl temp1 temp temp1)
512 (inst bis temp1 temp2 temp1)
513 (inst stq_u temp1 (- (* ,offset n-word-bytes)
514 (* index ,scale) ,lowtag) object)))
516 `((inst lda temp (- (* ,offset n-word-bytes)
517 (* index ,scale) ,lowtag)
519 (inst ldq_u temp1 (- (* ,offset n-word-bytes)
520 (* index ,scale) ,lowtag)
522 (inst mskwl temp1 temp temp1)
523 (inst inswl value temp temp2)
524 (inst bis temp1 temp2 temp)
525 (inst stq_u temp (- (* ,offset n-word-bytes)
526 (* index ,scale) ,lowtag) object))))
527 (move value result))))))