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 (declare (type (vector (unsigned-byte 8) 16) ,var))
189 (setf (fill-pointer ,var) 0)
193 (push ,var *adjustable-vectors*))))
195 (eval-when (:compile-toplevel :load-toplevel :execute)
196 (defun emit-error-break (vop kind code values)
197 (let ((vector (gensym)))
200 (note-this-location vop :internal-error)))
202 (with-adjustable-vector (,vector)
203 (write-var-integer (error-number-or-lose ',code) ,vector)
204 ,@(mapcar (lambda (tn)
206 (write-var-integer (make-sc-offset (sc-number
211 (inst byte (length ,vector))
212 (dotimes (i (length ,vector))
213 (inst byte (aref ,vector i))))
214 (align word-shift)))))
216 (defmacro error-call (vop error-code &rest values)
217 "Cause an error. ERROR-CODE is the error to cause."
219 (emit-error-break vop error-trap error-code values)))
222 (defmacro cerror-call (vop label error-code &rest values)
223 "Cause a continuable error. If the error is continued, execution resumes at
226 (inst br zero-tn ,label)
227 ,@(emit-error-break vop cerror-trap error-code values)))
229 (defmacro generate-error-code (vop error-code &rest values)
230 "Generate-Error-Code Error-code Value*
231 Emit code for an error with the specified Error-Code and context Values."
232 `(assemble (*elsewhere*)
233 (let ((start-lab (gen-label)))
234 (emit-label start-lab)
235 (error-call ,vop ,error-code ,@values)
238 (defmacro generate-cerror-code (vop error-code &rest values)
239 "Generate-CError-Code Error-code Value*
240 Emit code for a continuable error with the specified Error-Code and
241 context Values. If the error is continued, execution resumes after
242 the GENERATE-CERROR-CODE form."
243 (let ((continue (gensym "CONTINUE-LABEL-"))
244 (error (gensym "ERROR-LABEL-")))
245 `(let ((,continue (gen-label)))
246 (emit-label ,continue)
247 (assemble (*elsewhere*)
248 (let ((,error (gen-label)))
250 (cerror-call ,vop ,continue ,error-code ,@values)
254 ;;; a handy macro for making sequences look atomic
255 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
257 (inst addq alloc-tn 1 alloc-tn)
259 (inst lda alloc-tn (1- ,extra) alloc-tn)
260 (inst stl zero-tn 0 alloc-tn)))
262 ;;;; memory accessor vop generators
264 (deftype load/store-index (scale lowtag min-offset
265 &optional (max-offset min-offset))
266 `(integer ,(- (truncate (+ (ash 1 16)
267 (* min-offset n-word-bytes)
270 ,(truncate (- (+ (1- (ash 1 16)) lowtag)
271 (* max-offset n-word-bytes))
274 (defmacro define-full-reffer (name type offset lowtag scs el-type
279 `((:translate ,translate)))
281 (:args (object :scs (descriptor-reg))
282 (index :scs (any-reg)))
283 (:arg-types ,type tagged-num)
284 (:temporary (:scs (interior-reg)) lip)
285 (:results (value :scs ,scs))
286 (:result-types ,el-type)
288 (inst addq object index lip)
289 (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip)
290 ,@(when (equal scs '(unsigned-reg))
291 '((inst mskll value 4 value)))))
292 (define-vop (,(symbolicate name "-C"))
294 `((:translate ,translate)))
296 (:args (object :scs (descriptor-reg)))
299 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
301 (:results (value :scs ,scs))
302 (:result-types ,el-type)
304 (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
306 ,@(when (equal scs '(unsigned-reg))
307 '((inst mskll value 4 value)))))))
309 (defmacro define-full-setter (name type offset lowtag scs el-type
310 &optional translate #!+gengc (remember t))
314 `((:translate ,translate)))
316 (:args (object :scs (descriptor-reg))
317 (index :scs (any-reg))
318 (value :scs ,scs :target result))
319 (:arg-types ,type tagged-num ,el-type)
320 (:temporary (:scs (interior-reg)) lip)
321 (:results (result :scs ,scs))
322 (:result-types ,el-type)
324 (inst addq index object lip)
325 (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip)
326 (move value result)))
327 (define-vop (,(symbolicate name "-C"))
329 `((:translate ,translate)))
331 (:args (object :scs (descriptor-reg))
335 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
338 (:results (result :scs ,scs))
339 (:result-types ,el-type)
341 (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
343 (move value result)))))
346 (defmacro define-partial-reffer (name type size signed offset lowtag scs
347 el-type &optional translate)
348 (let ((scale (ecase size (:byte 1) (:short 2))))
352 `((:translate ,translate)))
354 (:args (object :scs (descriptor-reg))
355 (index :scs (unsigned-reg)))
356 (:arg-types ,type positive-fixnum)
357 (:results (value :scs ,scs))
358 (:result-types ,el-type)
359 (:temporary (:scs (interior-reg)) lip)
360 (:temporary (:sc non-descriptor-reg) temp)
361 (:temporary (:sc non-descriptor-reg) temp1)
363 (inst addq object index lip)
364 ,@(when (eq size :short)
365 '((inst addq index lip lip)))
369 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
371 (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag))
373 (inst extqh temp temp1 temp)
374 (inst sra temp 56 value))
377 (- (* ,offset n-word-bytes) ,lowtag)
379 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
381 (inst extbl temp temp1 value))))
384 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
386 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
388 (inst extwl temp temp1 temp)
389 (inst sll temp 48 temp)
390 (inst sra temp 48 value))
391 `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
393 (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
394 (inst extwl temp temp1 value)))))))
395 (define-vop (,(symbolicate name "-C"))
397 `((:translate ,translate)))
399 (:args (object :scs (descriptor-reg)))
402 (:constant (load/store-index ,scale
405 (:results (value :scs ,scs))
406 (:result-types ,el-type)
407 (:temporary (:sc non-descriptor-reg) temp)
408 (:temporary (:sc non-descriptor-reg) temp1)
413 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
414 (* index ,scale)) ,lowtag)
416 (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes)
417 (* index ,scale)) ,lowtag))
419 (inst extqh temp temp1 temp)
420 (inst sra temp 56 value))
421 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
422 (* index ,scale)) ,lowtag)
424 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
425 (* index ,scale)) ,lowtag)
427 (inst extbl temp temp1 value))))
430 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
431 (* index ,scale)) ,lowtag)
433 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
434 (* index ,scale)) ,lowtag)
436 (inst extwl temp temp1 temp)
437 (inst sll temp 48 temp)
438 (inst sra temp 48 value))
439 `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
440 (* index ,scale)) ,lowtag)
442 (inst lda temp1 (- (+ (* ,offset n-word-bytes)
443 (* index ,scale)) ,lowtag)
445 (inst extwl temp temp1 value))))))))))
447 (defmacro define-partial-setter (name type size offset lowtag scs el-type
449 (let ((scale (ecase size (:byte 1) (:short 2))))
453 `((:translate ,translate)))
455 (:args (object :scs (descriptor-reg))
456 (index :scs (unsigned-reg))
457 (value :scs ,scs :target result))
458 (:arg-types ,type positive-fixnum ,el-type)
459 (:temporary (:scs (interior-reg)) lip)
460 (:temporary (:sc non-descriptor-reg) temp)
461 (:temporary (:sc non-descriptor-reg) temp1)
462 (:temporary (:sc non-descriptor-reg) temp2)
463 (:results (result :scs ,scs))
464 (:result-types ,el-type)
466 (inst addq object index lip)
467 ,@(when (eq size :short)
468 '((inst addq lip index lip)))
471 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
472 (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
473 (inst insbl value temp temp2)
474 (inst mskbl temp1 temp temp1)
475 (inst bis temp1 temp2 temp1)
476 (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)))
478 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
479 (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
480 (inst mskwl temp1 temp temp1)
481 (inst inswl value temp temp2)
482 (inst bis temp1 temp2 temp)
483 (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip))))
484 (move value result)))
485 (define-vop (,(symbolicate name "-C"))
487 `((:translate ,translate)))
489 (:args (object :scs (descriptor-reg))
490 (value :scs ,scs :target result))
493 (:constant (load/store-index ,scale
497 (:temporary (:sc non-descriptor-reg) temp)
498 (:temporary (:sc non-descriptor-reg) temp1)
499 (:temporary (:sc non-descriptor-reg) temp2)
500 (:results (result :scs ,scs))
501 (:result-types ,el-type)
505 `((inst lda temp (- (* ,offset n-word-bytes)
506 (* index ,scale) ,lowtag)
508 (inst ldq_u temp1 (- (* ,offset n-word-bytes)
509 (* index ,scale) ,lowtag)
511 (inst insbl value temp temp2)
512 (inst mskbl temp1 temp temp1)
513 (inst bis temp1 temp2 temp1)
514 (inst stq_u temp1 (- (* ,offset n-word-bytes)
515 (* index ,scale) ,lowtag) object)))
517 `((inst lda temp (- (* ,offset n-word-bytes)
518 (* index ,scale) ,lowtag)
520 (inst ldq_u temp1 (- (* ,offset n-word-bytes)
521 (* index ,scale) ,lowtag)
523 (inst mskwl temp1 temp temp1)
524 (inst inswl value temp temp2)
525 (inst bis temp1 temp2 temp)
526 (inst stq_u temp (- (* ,offset n-word-bytes)
527 (* index ,scale) ,lowtag) object))))
528 (move value result))))))