3 ;;; Handy macro for defining top-level forms that depend on the compile
6 (defmacro expand (expr)
7 (let ((gensym (gensym)))
14 ;;; Instruction-like macros.
16 (defmacro move (dst src &optional (always-emit-code-p nil))
17 "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P
19 (once-only ((n-dst dst)
21 (if always-emit-code-p
22 `(inst move ,n-dst ,n-src)
23 `(unless (location= ,n-dst ,n-src)
24 (inst move ,n-dst ,n-src)))))
26 (defmacro def-mem-op (op inst shift load)
27 `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
29 (inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))
30 ,,@(when load '('(inst nop))))))
32 (def-mem-op loadw lw word-shift t)
33 (def-mem-op storew sw word-shift nil)
35 (defmacro load-symbol (reg symbol)
36 `(inst addu ,reg null-tn (static-symbol-offset ,symbol)))
38 (defmacro load-symbol-value (reg symbol)
41 (+ (static-symbol-offset ',symbol)
42 (ash symbol-value-slot word-shift)
43 (- other-pointer-lowtag)))
46 (defmacro store-symbol-value (reg symbol)
47 `(inst sw ,reg null-tn
48 (+ (static-symbol-offset ',symbol)
49 (ash symbol-value-slot word-shift)
50 (- other-pointer-lowtag))))
52 (defmacro load-type (target source &optional (offset 0))
53 "Loads the type bits of a pointer into target independent of
54 byte-ordering issues."
55 (once-only ((n-target target)
58 (ecase *backend-byte-order*
60 `(inst lbu ,n-target ,n-source ,n-offset ))
62 `(inst lbu ,n-target ,n-source (+ ,n-offset 3))))))
65 ;;; Macros to handle the fact that we cannot use the machine native call and
66 ;;; return instructions.
68 (defmacro lisp-jump (function lip)
69 "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
71 (inst addu ,lip ,function (- (ash simple-fun-code-offset word-shift)
74 (move code-tn ,function)))
76 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
77 "Return to RETURN-PC. LIP is an interior-reg temporary."
79 (inst addu ,lip ,return-pc
80 (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
83 `(move code-tn ,return-pc)
87 (defmacro emit-return-pc (label)
88 "Emit a return-pc header word. LABEL is the label to use for this return-pc."
92 (inst lra-header-word)))
98 ;;; Load-Stack-TN, Store-Stack-TN -- Interface
100 ;;; Move a stack TN to a register and vice-versa.
102 (defmacro load-stack-tn (reg stack)
105 (let ((offset (tn-offset stack)))
108 (loadw reg cfp-tn offset))))))
110 (defmacro store-stack-tn (stack reg)
111 `(let ((stack ,stack)
113 (let ((offset (tn-offset stack)))
116 (storew reg cfp-tn offset))))))
119 ;;; MAYBE-LOAD-STACK-TN -- Interface
121 (defmacro maybe-load-stack-tn (reg reg-or-stack)
122 "Move the TN Reg-Or-Stack into Reg if it isn't already there."
123 (once-only ((n-reg reg)
124 (n-stack reg-or-stack))
126 ((any-reg descriptor-reg)
128 ((any-reg descriptor-reg)
129 (move ,n-reg ,n-stack))
131 (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
134 ;;;; Storage allocation:
136 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
138 "Do stuff to allocate an other-pointer object of fixed Size with a single
139 word header having the specified Type-Code. The result is placed in
140 Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non-
141 descriptor temp (which may be randomly used by the body.) The body is
142 placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
143 `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
144 (inst or ,result-tn alloc-tn other-pointer-lowtag)
145 (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
146 (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
151 ;;;; Three Way Comparison
153 (defun three-way-comparison (x y condition flavor not-p target temp)
157 (inst bne x y target)
158 (inst beq x y target)))
162 (inst sltu temp x y))
164 (inst slt temp x y)))
166 (inst beq temp zero-tn target)
167 (inst bne temp zero-tn target)))
171 (inst sltu temp y x))
173 (inst slt temp y x)))
175 (inst beq temp zero-tn target)
176 (inst bne temp zero-tn target))))
184 (defvar *adjustable-vectors* nil)
186 (defmacro with-adjustable-vector ((var) &rest body)
187 `(let ((,var (or (pop *adjustable-vectors*)
189 :element-type '(unsigned-byte 8)
192 (setf (fill-pointer ,var) 0)
196 (push ,var *adjustable-vectors*))))
198 (eval-when (compile load eval)
199 (defun emit-error-break (vop kind code values)
200 (let ((vector (gensym)))
203 (note-this-location vop :internal-error)))
205 (with-adjustable-vector (,vector)
206 (write-var-integer (error-number-or-lose ',code) ,vector)
207 ,@(mapcar #'(lambda (tn)
209 (write-var-integer (make-sc-offset (sc-number
214 (inst byte (length ,vector))
215 (dotimes (i (length ,vector))
216 (inst byte (aref ,vector i))))
217 (align word-shift)))))
219 (defmacro error-call (vop error-code &rest values)
220 "Cause an error. ERROR-CODE is the error to cause."
222 (emit-error-break vop error-trap error-code values)))
225 (defmacro cerror-call (vop label error-code &rest values)
226 "Cause a continuable error. If the error is continued, execution resumes at
230 ,@(emit-error-break vop cerror-trap error-code values)))
232 (defmacro generate-error-code (vop error-code &rest values)
233 "Generate-Error-Code Error-code Value*
234 Emit code for an error with the specified Error-Code and context Values."
235 `(assemble (*elsewhere*)
236 (let ((start-lab (gen-label)))
237 (emit-label start-lab)
238 (error-call ,vop ,error-code ,@values)
241 (defmacro generate-cerror-code (vop error-code &rest values)
242 "Generate-CError-Code Error-code Value*
243 Emit code for a continuable error with the specified Error-Code and
244 context Values. If the error is continued, execution resumes after
245 the GENERATE-CERROR-CODE form."
246 (let ((continue (gensym "CONTINUE-LABEL-"))
247 (error (gensym "ERROR-LABEL-")))
248 `(let ((,continue (gen-label)))
249 (emit-label ,continue)
250 (assemble (*elsewhere*)
251 (let ((,error (gen-label)))
253 (cerror-call ,vop ,continue ,error-code ,@values)
257 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
258 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
260 (aver (= (tn-offset ,flag-tn) nl4-offset))
261 (aver (not (minusp ,extra)))
262 (without-scheduling ()
263 (inst li ,flag-tn ,extra)
264 (inst addu alloc-tn 1))
266 (without-scheduling ()
267 (let ((label (gen-label)))
271 (inst bgez ,flag-tn label)
272 (inst addu alloc-tn (1- ,extra))
274 (emit-label label)))))
278 ;;;; Memory accessor vop generators
280 (deftype load/store-index (scale lowtag min-offset
281 &optional (max-offset min-offset))
282 `(integer ,(- (truncate (+ (ash 1 16)
283 (* min-offset n-word-bytes)
286 ,(truncate (- (+ (1- (ash 1 16)) lowtag)
287 (* max-offset n-word-bytes))
290 (defmacro define-full-reffer (name type offset lowtag scs el-type
295 `((:translate ,translate)))
297 (:args (object :scs (descriptor-reg))
298 (index :scs (any-reg)))
299 (:arg-types ,type tagged-num)
300 (:temporary (:scs (interior-reg)) lip)
301 (:results (value :scs ,scs))
302 (:result-types ,el-type)
304 (inst add lip object index)
305 (inst lw value lip (- (* ,offset n-word-bytes) ,lowtag))
307 (define-vop (,(symbolicate name "-C"))
309 `((:translate ,translate)))
311 (:args (object :scs (descriptor-reg)))
314 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
316 (:results (value :scs ,scs))
317 (:result-types ,el-type)
319 (inst lw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
322 (defmacro define-full-setter (name type offset lowtag scs el-type
327 `((:translate ,translate)))
329 (:args (object :scs (descriptor-reg))
330 (index :scs (any-reg))
331 (value :scs ,scs :target result))
332 (:arg-types ,type tagged-num ,el-type)
333 (:temporary (:scs (interior-reg)) lip)
334 (:results (result :scs ,scs))
335 (:result-types ,el-type)
337 (inst add lip object index)
338 (inst sw value lip (- (* ,offset n-word-bytes) ,lowtag))
339 (move result value)))
340 (define-vop (,(symbolicate name "-C"))
342 `((:translate ,translate)))
344 (:args (object :scs (descriptor-reg))
348 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
351 (:results (result :scs ,scs))
352 (:result-types ,el-type)
354 (inst sw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
355 (move result value)))))
358 (defmacro define-partial-reffer (name type size signed offset lowtag scs
359 el-type &optional translate)
360 (let ((scale (ecase size (:byte 1) (:short 2))))
364 `((:translate ,translate)))
366 (:args (object :scs (descriptor-reg))
367 (index :scs (unsigned-reg)))
368 (:arg-types ,type positive-fixnum)
369 (:results (value :scs ,scs))
370 (:result-types ,el-type)
371 (:temporary (:scs (interior-reg)) lip)
373 (inst addu lip object index)
374 ,@(when (eq size :short)
375 '((inst addu lip index)))
377 (:byte (if signed 'lb 'lbu))
378 (:short (if signed 'lh 'lhu)))
379 value lip (- (* ,offset n-word-bytes) ,lowtag))
381 (define-vop (,(symbolicate name "-C"))
383 `((:translate ,translate)))
385 (:args (object :scs (descriptor-reg)))
388 (:constant (load/store-index ,scale
391 (:results (value :scs ,scs))
392 (:result-types ,el-type)
395 (:byte (if signed 'lb 'lbu))
396 (:short (if signed 'lh 'lhu)))
398 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
401 (defmacro define-partial-setter (name type size offset lowtag scs el-type
403 (let ((scale (ecase size (:byte 1) (:short 2))))
407 `((:translate ,translate)))
409 (:args (object :scs (descriptor-reg))
410 (index :scs (unsigned-reg))
411 (value :scs ,scs :target result))
412 (:arg-types ,type positive-fixnum ,el-type)
413 (:temporary (:scs (interior-reg)) lip)
414 (:results (result :scs ,scs))
415 (:result-types ,el-type)
417 (inst addu lip object index)
418 ,@(when (eq size :short)
419 '((inst addu lip index)))
420 (inst ,(ecase size (:byte 'sb) (:short 'sh))
421 value lip (- (* ,offset n-word-bytes) ,lowtag))
422 (move result value)))
423 (define-vop (,(symbolicate name "-C"))
425 `((:translate ,translate)))
427 (:args (object :scs (descriptor-reg))
428 (value :scs ,scs :target result))
431 (:constant (load/store-index ,scale
435 (:results (result :scs ,scs))
436 (:result-types ,el-type)
438 (inst ,(ecase size (:byte 'sb) (:short 'sh))
440 (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag))
441 (move result value))))))