1 ;;;; various useful macros for generating MIPS 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.
13 ;;; Handy macro for defining top-level forms that depend on the compile
16 (defmacro expand (expr)
17 (let ((gensym (gensym)))
24 ;;; Instruction-like macros.
26 (defmacro move (dst src &optional (always-emit-code-p nil))
27 "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P
29 (once-only ((n-dst dst)
31 (if always-emit-code-p
32 `(inst move ,n-dst ,n-src)
33 `(unless (location= ,n-dst ,n-src)
34 (inst move ,n-dst ,n-src)))))
36 (defmacro def-mem-op (op inst shift load)
37 `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
39 (inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))
40 ,,@(when load '('(inst nop))))))
42 (def-mem-op loadw lw word-shift t)
43 (def-mem-op storew sw word-shift nil)
45 (defmacro load-symbol (reg symbol)
46 `(inst addu ,reg null-tn (static-symbol-offset ,symbol)))
48 (defmacro load-symbol-value (reg symbol)
51 (+ (static-symbol-offset ',symbol)
52 (ash symbol-value-slot word-shift)
53 (- other-pointer-lowtag)))
56 (defmacro store-symbol-value (reg symbol)
57 `(inst sw ,reg null-tn
58 (+ (static-symbol-offset ',symbol)
59 (ash symbol-value-slot word-shift)
60 (- other-pointer-lowtag))))
62 (defmacro load-type (target source &optional (offset 0))
63 "Loads the type bits of a pointer into target independent of
64 byte-ordering issues."
65 (once-only ((n-target target)
68 (ecase *backend-byte-order*
70 `(inst lbu ,n-target ,n-source ,n-offset ))
72 `(inst lbu ,n-target ,n-source (+ ,n-offset 3))))))
75 ;;; Macros to handle the fact that we cannot use the machine native call and
76 ;;; return instructions.
78 (defmacro lisp-jump (function lip)
79 "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
81 (inst addu ,lip ,function (- (ash simple-fun-code-offset word-shift)
84 (move code-tn ,function)))
86 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
87 "Return to RETURN-PC. LIP is an interior-reg temporary."
89 (inst addu ,lip ,return-pc
90 (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
93 `(move code-tn ,return-pc)
97 (defmacro emit-return-pc (label)
98 "Emit a return-pc header word. LABEL is the label to use for this return-pc."
100 (align n-lowtag-bits)
102 (inst lra-header-word)))
108 ;;; Move a stack TN to a register and vice-versa.
109 (defmacro load-stack-tn (reg stack)
112 (let ((offset (tn-offset stack)))
115 (loadw reg cfp-tn offset))))))
116 (defmacro store-stack-tn (stack reg)
117 `(let ((stack ,stack)
119 (let ((offset (tn-offset stack)))
122 (storew reg cfp-tn offset))))))
124 (defmacro maybe-load-stack-tn (reg reg-or-stack)
125 "Move the TN Reg-Or-Stack into Reg if it isn't already there."
126 (once-only ((n-reg reg)
127 (n-stack reg-or-stack))
129 ((any-reg descriptor-reg)
131 ((any-reg descriptor-reg)
132 (move ,n-reg ,n-stack))
134 (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
137 ;;;; Storage allocation:
138 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
140 "Do stuff to allocate an other-pointer object of fixed Size with a single
141 word header having the specified Type-Code. The result is placed in
142 Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non-
143 descriptor temp (which may be randomly used by the body.) The body is
144 placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
145 `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
146 (inst or ,result-tn alloc-tn other-pointer-lowtag)
147 (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
148 (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
153 ;;;; Three Way Comparison
154 (defun three-way-comparison (x y condition flavor not-p target temp)
158 (inst bne x y target)
159 (inst beq x y target)))
163 (inst sltu temp x y))
165 (inst slt temp x y)))
167 (inst beq temp zero-tn target)
168 (inst bne temp zero-tn target)))
172 (inst sltu temp y x))
174 (inst slt temp y x)))
176 (inst beq temp zero-tn target)
177 (inst bne temp zero-tn target))))
183 (eval-when (compile load eval)
184 (defun emit-error-break (vop kind code values)
185 (let ((vector (gensym)))
188 (note-this-location vop :internal-error)))
190 (with-adjustable-vector (,vector)
191 (write-var-integer (error-number-or-lose ',code) ,vector)
192 ,@(mapcar #'(lambda (tn)
194 (write-var-integer (make-sc-offset (sc-number
199 (inst byte (length ,vector))
200 (dotimes (i (length ,vector))
201 (inst byte (aref ,vector i))))
202 (align word-shift)))))
204 (defmacro error-call (vop error-code &rest values)
205 "Cause an error. ERROR-CODE is the error to cause."
207 (emit-error-break vop error-trap error-code values)))
210 (defmacro cerror-call (vop label error-code &rest values)
211 "Cause a continuable error. If the error is continued, execution resumes at
215 ,@(emit-error-break vop cerror-trap error-code values)))
217 (defmacro generate-error-code (vop error-code &rest values)
218 "Generate-Error-Code Error-code Value*
219 Emit code for an error with the specified Error-Code and context Values."
220 `(assemble (*elsewhere*)
221 (let ((start-lab (gen-label)))
222 (emit-label start-lab)
223 (error-call ,vop ,error-code ,@values)
226 (defmacro generate-cerror-code (vop error-code &rest values)
227 "Generate-CError-Code Error-code Value*
228 Emit code for a continuable error with the specified Error-Code and
229 context Values. If the error is continued, execution resumes after
230 the GENERATE-CERROR-CODE form."
231 (with-unique-names (continue error)
232 `(let ((,continue (gen-label)))
233 (emit-label ,continue)
234 (assemble (*elsewhere*)
235 (let ((,error (gen-label)))
237 (cerror-call ,vop ,continue ,error-code ,@values)
242 ;;; handy macro for making sequences look atomic
243 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
245 (aver (= (tn-offset ,flag-tn) nl4-offset))
246 (aver (not (minusp ,extra)))
247 (without-scheduling ()
248 (inst li ,flag-tn ,extra)
249 (inst addu alloc-tn 1))
251 (without-scheduling ()
252 (let ((label (gen-label)))
256 (inst bgez ,flag-tn label)
257 (inst addu alloc-tn (1- ,extra))
259 (emit-label label)))))
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 add lip object index)
288 (inst lw value lip (- (* ,offset n-word-bytes) ,lowtag))
290 (define-vop (,(symbolicate name "-C"))
292 `((:translate ,translate)))
294 (:args (object :scs (descriptor-reg)))
297 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
299 (:results (value :scs ,scs))
300 (:result-types ,el-type)
302 (inst lw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
305 (defmacro define-full-setter (name type offset lowtag scs el-type
310 `((:translate ,translate)))
312 (:args (object :scs (descriptor-reg))
313 (index :scs (any-reg))
314 (value :scs ,scs :target result))
315 (:arg-types ,type tagged-num ,el-type)
316 (:temporary (:scs (interior-reg)) lip)
317 (:results (result :scs ,scs))
318 (:result-types ,el-type)
320 (inst add lip object index)
321 (inst sw value lip (- (* ,offset n-word-bytes) ,lowtag))
322 (move result value)))
323 (define-vop (,(symbolicate name "-C"))
325 `((:translate ,translate)))
327 (:args (object :scs (descriptor-reg))
331 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
334 (:results (result :scs ,scs))
335 (:result-types ,el-type)
337 (inst sw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
338 (move result value)))))
341 (defmacro define-partial-reffer (name type size signed offset lowtag scs
342 el-type &optional translate)
343 (let ((scale (ecase size (:byte 1) (:short 2))))
347 `((:translate ,translate)))
349 (:args (object :scs (descriptor-reg))
350 (index :scs (unsigned-reg)))
351 (:arg-types ,type positive-fixnum)
352 (:results (value :scs ,scs))
353 (:result-types ,el-type)
354 (:temporary (:scs (interior-reg)) lip)
356 (inst addu lip object index)
357 ,@(when (eq size :short)
358 '((inst addu lip index)))
360 (:byte (if signed 'lb 'lbu))
361 (:short (if signed 'lh 'lhu)))
362 value lip (- (* ,offset n-word-bytes) ,lowtag))
364 (define-vop (,(symbolicate name "-C"))
366 `((:translate ,translate)))
368 (:args (object :scs (descriptor-reg)))
371 (:constant (load/store-index ,scale
374 (:results (value :scs ,scs))
375 (:result-types ,el-type)
378 (:byte (if signed 'lb 'lbu))
379 (:short (if signed 'lh 'lhu)))
381 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
384 (defmacro define-partial-setter (name type size offset lowtag scs el-type
386 (let ((scale (ecase size (:byte 1) (:short 2))))
390 `((:translate ,translate)))
392 (:args (object :scs (descriptor-reg))
393 (index :scs (unsigned-reg))
394 (value :scs ,scs :target result))
395 (:arg-types ,type positive-fixnum ,el-type)
396 (:temporary (:scs (interior-reg)) lip)
397 (:results (result :scs ,scs))
398 (:result-types ,el-type)
400 (inst addu lip object index)
401 ,@(when (eq size :short)
402 '((inst addu lip index)))
403 (inst ,(ecase size (:byte 'sb) (:short 'sh))
404 value lip (- (* ,offset n-word-bytes) ,lowtag))
405 (move result value)))
406 (define-vop (,(symbolicate name "-C"))
408 `((:translate ,translate)))
410 (:args (object :scs (descriptor-reg))
411 (value :scs ,scs :target result))
414 (:constant (load/store-index ,scale
418 (:results (result :scs ,scs))
419 (:result-types ,el-type)
421 (inst ,(ecase size (:byte 'sb) (:short 'sh))
423 (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag))
424 (move result value))))))