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 (let ((continue (gensym "CONTINUE-LABEL-"))
232 (error (gensym "ERROR-LABEL-")))
233 `(let ((,continue (gen-label)))
234 (emit-label ,continue)
235 (assemble (*elsewhere*)
236 (let ((,error (gen-label)))
238 (cerror-call ,vop ,continue ,error-code ,@values)
242 ;;; PSEUDO-ATOMIC -- 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)))))
263 ;;;; Memory accessor vop generators
265 (deftype load/store-index (scale lowtag min-offset
266 &optional (max-offset min-offset))
267 `(integer ,(- (truncate (+ (ash 1 16)
268 (* min-offset n-word-bytes)
271 ,(truncate (- (+ (1- (ash 1 16)) lowtag)
272 (* max-offset n-word-bytes))
275 (defmacro define-full-reffer (name type offset lowtag scs el-type
280 `((:translate ,translate)))
282 (:args (object :scs (descriptor-reg))
283 (index :scs (any-reg)))
284 (:arg-types ,type tagged-num)
285 (:temporary (:scs (interior-reg)) lip)
286 (:results (value :scs ,scs))
287 (:result-types ,el-type)
289 (inst add lip object index)
290 (inst lw value lip (- (* ,offset n-word-bytes) ,lowtag))
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 lw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
307 (defmacro define-full-setter (name type offset lowtag scs el-type
312 `((:translate ,translate)))
314 (:args (object :scs (descriptor-reg))
315 (index :scs (any-reg))
316 (value :scs ,scs :target result))
317 (:arg-types ,type tagged-num ,el-type)
318 (:temporary (:scs (interior-reg)) lip)
319 (:results (result :scs ,scs))
320 (:result-types ,el-type)
322 (inst add lip object index)
323 (inst sw value lip (- (* ,offset n-word-bytes) ,lowtag))
324 (move result value)))
325 (define-vop (,(symbolicate name "-C"))
327 `((:translate ,translate)))
329 (:args (object :scs (descriptor-reg))
333 (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
336 (:results (result :scs ,scs))
337 (:result-types ,el-type)
339 (inst sw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
340 (move result value)))))
343 (defmacro define-partial-reffer (name type size signed offset lowtag scs
344 el-type &optional translate)
345 (let ((scale (ecase size (:byte 1) (:short 2))))
349 `((:translate ,translate)))
351 (:args (object :scs (descriptor-reg))
352 (index :scs (unsigned-reg)))
353 (:arg-types ,type positive-fixnum)
354 (:results (value :scs ,scs))
355 (:result-types ,el-type)
356 (:temporary (:scs (interior-reg)) lip)
358 (inst addu lip object index)
359 ,@(when (eq size :short)
360 '((inst addu lip index)))
362 (:byte (if signed 'lb 'lbu))
363 (:short (if signed 'lh 'lhu)))
364 value lip (- (* ,offset n-word-bytes) ,lowtag))
366 (define-vop (,(symbolicate name "-C"))
368 `((:translate ,translate)))
370 (:args (object :scs (descriptor-reg)))
373 (:constant (load/store-index ,scale
376 (:results (value :scs ,scs))
377 (:result-types ,el-type)
380 (:byte (if signed 'lb 'lbu))
381 (:short (if signed 'lh 'lhu)))
383 (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
386 (defmacro define-partial-setter (name type size offset lowtag scs el-type
388 (let ((scale (ecase size (:byte 1) (:short 2))))
392 `((:translate ,translate)))
394 (:args (object :scs (descriptor-reg))
395 (index :scs (unsigned-reg))
396 (value :scs ,scs :target result))
397 (:arg-types ,type positive-fixnum ,el-type)
398 (:temporary (:scs (interior-reg)) lip)
399 (:results (result :scs ,scs))
400 (:result-types ,el-type)
402 (inst addu lip object index)
403 ,@(when (eq size :short)
404 '((inst addu lip index)))
405 (inst ,(ecase size (:byte 'sb) (:short 'sh))
406 value lip (- (* ,offset n-word-bytes) ,lowtag))
407 (move result value)))
408 (define-vop (,(symbolicate name "-C"))
410 `((:translate ,translate)))
412 (:args (object :scs (descriptor-reg))
413 (value :scs ,scs :target result))
416 (:constant (load/store-index ,scale
420 (:results (result :scs ,scs))
421 (:result-types ,el-type)
423 (inst ,(ecase size (:byte 'sb) (:short 'sh))
425 (- (* ,offset n-word-bytes) (* index ,scale) ,lowtag))
426 (move result value))))))