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-type))
67 (defmacro store-symbol-value (reg symbol)
69 (+ (static-symbol-offset ',symbol)
70 (ash symbol-value-slot word-shift)
71 (- other-pointer-type))
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:function-code-offset sb!vm:word-shift)
91 sb!vm:function-pointer-type)
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) word-bytes) other-pointer-type)
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
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 Type-Code. 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 type-code size)
172 `(pseudo-atomic (:extra (pad-data-block ,size))
173 (inst bis alloc-tn other-pointer-type ,result-tn)
174 (inst li (logior (ash (1- ,size) type-bits) ,type-code) ,temp-tn)
175 (storew ,temp-tn ,result-tn 0 other-pointer-type)
183 (defvar *adjustable-vectors* nil)
185 (defmacro with-adjustable-vector ((var) &rest body)
186 `(let ((,var (or (pop *adjustable-vectors*)
188 :element-type '(unsigned-byte 8)
191 (setf (fill-pointer ,var) 0)
195 (push ,var *adjustable-vectors*))))
197 (eval-when (:compile-toplevel :load-toplevel :execute)
198 (defun emit-error-break (vop kind code values)
199 (let ((vector (gensym)))
202 (note-this-location vop :internal-error)))
204 (with-adjustable-vector (,vector)
205 (write-var-integer (error-number-or-lose ',code) ,vector)
206 ,@(mapcar #'(lambda (tn)
208 (write-var-integer (make-sc-offset (sc-number
213 (inst byte (length ,vector))
214 (dotimes (i (length ,vector))
215 (inst byte (aref ,vector i))))
216 (align word-shift)))))
218 (defmacro error-call (vop error-code &rest values)
219 "Cause an error. ERROR-CODE is the error to cause."
221 (emit-error-break vop error-trap error-code values)))
224 (defmacro cerror-call (vop label error-code &rest values)
225 "Cause a continuable error. If the error is continued, execution resumes at
228 (inst br zero-tn ,label)
229 ,@(emit-error-break vop cerror-trap error-code values)))
231 (defmacro generate-error-code (vop error-code &rest values)
232 "Generate-Error-Code Error-code Value*
233 Emit code for an error with the specified Error-Code and context Values."
234 `(assemble (*elsewhere*)
235 (let ((start-lab (gen-label)))
236 (emit-label start-lab)
237 (error-call ,vop ,error-code ,@values)
240 (defmacro generate-cerror-code (vop error-code &rest values)
241 "Generate-CError-Code Error-code Value*
242 Emit code for a continuable error with the specified Error-Code and
243 context Values. If the error is continued, execution resumes after
244 the GENERATE-CERROR-CODE form."
245 (let ((continue (gensym "CONTINUE-LABEL-"))
246 (error (gensym "ERROR-LABEL-")))
247 `(let ((,continue (gen-label)))
248 (emit-label ,continue)
249 (assemble (*elsewhere*)
250 (let ((,error (gen-label)))
252 (cerror-call ,vop ,continue ,error-code ,@values)
256 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
258 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
260 (inst addq alloc-tn 1 alloc-tn)
262 (inst lda alloc-tn (1- ,extra) alloc-tn)
263 (inst stl zero-tn 0 alloc-tn)))
267 ;;;; Memory accessor vop generators
269 (deftype load/store-index (scale lowtag min-offset
270 &optional (max-offset min-offset))
271 `(integer ,(- (truncate (+ (ash 1 16)
272 (* min-offset word-bytes)
275 ,(truncate (- (+ (1- (ash 1 16)) lowtag)
276 (* max-offset word-bytes))
279 (defmacro define-full-reffer (name type offset lowtag scs el-type
284 `((:translate ,translate)))
286 (:args (object :scs (descriptor-reg))
287 (index :scs (any-reg)))
288 (:arg-types ,type tagged-num)
289 (:temporary (:scs (interior-reg)) lip)
290 (:results (value :scs ,scs))
291 (:result-types ,el-type)
293 (inst addq object index lip)
294 (inst ldl value (- (* ,offset word-bytes) ,lowtag) lip)
295 ,@(when (equal scs '(unsigned-reg))
296 '((inst mskll value 4 value)))))
297 (define-vop (,(symbolicate name "-C"))
299 `((:translate ,translate)))
301 (:args (object :scs (descriptor-reg)))
304 (:constant (load/store-index ,word-bytes ,(eval lowtag)
306 (:results (value :scs ,scs))
307 (:result-types ,el-type)
309 (inst ldl value (- (* (+ ,offset index) word-bytes) ,lowtag)
311 ,@(when (equal scs '(unsigned-reg))
312 '((inst mskll value 4 value)))))))
314 (defmacro define-full-setter (name type offset lowtag scs el-type
315 &optional translate #+gengc (remember t))
319 `((:translate ,translate)))
321 (:args (object :scs (descriptor-reg))
322 (index :scs (any-reg))
323 (value :scs ,scs :target result))
324 (:arg-types ,type tagged-num ,el-type)
325 (:temporary (:scs (interior-reg)) lip)
326 (:results (result :scs ,scs))
327 (:result-types ,el-type)
329 (inst addq index object lip)
330 (inst stl value (- (* ,offset word-bytes) ,lowtag) lip)
331 (move value result)))
332 (define-vop (,(symbolicate name "-C"))
334 `((:translate ,translate)))
336 (:args (object :scs (descriptor-reg))
340 (:constant (load/store-index ,word-bytes ,(eval lowtag)
343 (:results (result :scs ,scs))
344 (:result-types ,el-type)
346 (inst stl value (- (* (+ ,offset index) word-bytes) ,lowtag)
348 (move value result)))))
351 (defmacro define-partial-reffer (name type size signed offset lowtag scs
352 el-type &optional translate)
353 (let ((scale (ecase size (:byte 1) (:short 2))))
357 `((:translate ,translate)))
359 (:args (object :scs (descriptor-reg))
360 (index :scs (unsigned-reg)))
361 (:arg-types ,type positive-fixnum)
362 (:results (value :scs ,scs))
363 (:result-types ,el-type)
364 (:temporary (:scs (interior-reg)) lip)
365 (:temporary (:sc non-descriptor-reg) temp)
366 (:temporary (:sc non-descriptor-reg) temp1)
368 (inst addq object index lip)
369 ,@(when (eq size :short)
370 '((inst addq index lip lip)))
374 `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
376 (inst lda temp1 (1+ (- (* ,offset word-bytes) ,lowtag))
378 (inst extqh temp temp1 temp)
379 (inst sra temp 56 value))
380 `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) lip)
381 (inst lda temp1 (- (* ,offset word-bytes) ,lowtag)
383 (inst extbl temp temp1 value))))
386 `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
388 (inst lda temp1 (- (* ,offset word-bytes) ,lowtag)
390 (inst extwl temp temp1 temp)
391 (inst sll temp 48 temp)
392 (inst sra temp 48 value))
393 `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
395 (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) lip)
396 (inst extwl temp temp1 value)))))))
397 (define-vop (,(symbolicate name "-C"))
399 `((:translate ,translate)))
401 (:args (object :scs (descriptor-reg)))
404 (:constant (load/store-index ,scale
407 (:results (value :scs ,scs))
408 (:result-types ,el-type)
409 (:temporary (:sc non-descriptor-reg) temp)
410 (:temporary (:sc non-descriptor-reg) temp1)
415 `((inst ldq_u temp (- (+ (* ,offset word-bytes)
416 (* index ,scale)) ,lowtag)
418 (inst lda temp1 (1+ (- (+ (* ,offset word-bytes)
419 (* index ,scale)) ,lowtag))
421 (inst extqh temp temp1 temp)
422 (inst sra temp 56 value))
423 `((inst ldq_u temp (- (+ (* ,offset word-bytes)
424 (* index ,scale)) ,lowtag)
426 (inst lda temp1 (- (+ (* ,offset word-bytes)
427 (* index ,scale)) ,lowtag)
429 (inst extbl temp temp1 value))))
432 `((inst ldq_u temp (- (+ (* ,offset word-bytes)
433 (* index ,scale)) ,lowtag)
435 (inst lda temp1 (- (+ (* ,offset word-bytes)
436 (* index ,scale)) ,lowtag)
438 (inst extwl temp temp1 temp)
439 (inst sll temp 48 temp)
440 (inst sra temp 48 value))
441 `((inst ldq_u temp (- (+ (* ,offset word-bytes)
442 (* index ,scale)) ,lowtag)
444 (inst lda temp1 (- (+ (* ,offset word-bytes)
445 (* index ,scale)) ,lowtag)
447 (inst extwl temp temp1 value))))))))))
449 (defmacro define-partial-setter (name type size offset lowtag scs el-type
451 (let ((scale (ecase size (:byte 1) (:short 2))))
455 `((:translate ,translate)))
457 (:args (object :scs (descriptor-reg))
458 (index :scs (unsigned-reg))
459 (value :scs ,scs :target result))
460 (:arg-types ,type positive-fixnum ,el-type)
461 (:temporary (:scs (interior-reg)) lip)
462 (:temporary (:sc non-descriptor-reg) temp)
463 (:temporary (:sc non-descriptor-reg) temp1)
464 (:temporary (:sc non-descriptor-reg) temp2)
465 (:results (result :scs ,scs))
466 (:result-types ,el-type)
468 (inst addq object index lip)
469 ,@(when (eq size :short)
470 '((inst addq lip index lip)))
473 `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip)
474 (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)
475 (inst insbl value temp temp2)
476 (inst mskbl temp1 temp temp1)
477 (inst bis temp1 temp2 temp1)
478 (inst stq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)))
480 `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip)
481 (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)
482 (inst mskwl temp1 temp temp1)
483 (inst inswl value temp temp2)
484 (inst bis temp1 temp2 temp)
485 (inst stq_u temp (- (* ,offset word-bytes) ,lowtag) lip))))
486 (move value result)))
487 (define-vop (,(symbolicate name "-C"))
489 `((:translate ,translate)))
491 (:args (object :scs (descriptor-reg))
492 (value :scs ,scs :target result))
495 (:constant (load/store-index ,scale
499 (:temporary (:sc non-descriptor-reg) temp)
500 (:temporary (:sc non-descriptor-reg) temp1)
501 (:temporary (:sc non-descriptor-reg) temp2)
502 (:results (result :scs ,scs))
503 (:result-types ,el-type)
507 `((inst lda temp (- (* ,offset word-bytes)
508 (* index ,scale) ,lowtag)
510 (inst ldq_u temp1 (- (* ,offset word-bytes)
511 (* index ,scale) ,lowtag)
513 (inst insbl value temp temp2)
514 (inst mskbl temp1 temp temp1)
515 (inst bis temp1 temp2 temp1)
516 (inst stq_u temp1 (- (* ,offset word-bytes)
517 (* index ,scale) ,lowtag) object)))
519 `((inst lda temp (- (* ,offset word-bytes)
520 (* index ,scale) ,lowtag)
522 (inst ldq_u temp1 (- (* ,offset word-bytes)
523 (* index ,scale) ,lowtag)
525 (inst mskwl temp1 temp temp1)
526 (inst inswl value temp temp2)
527 (inst bis temp1 temp2 temp)
528 (inst stq_u temp (- (* ,offset word-bytes)
529 (* index ,scale) ,lowtag) object))))
530 (move value result))))))