1 ;;;; various useful macros for generating Sparc 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 ;;; Instruction-like macros.
16 (defmacro move (dst src)
17 "Move SRC into DST unless they are location=."
18 (once-only ((n-dst dst)
20 `(unless (location= ,n-dst ,n-src)
21 (inst move ,n-dst ,n-src))))
24 ((frob (op inst shift)
25 `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
26 `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
27 (frob loadw ld word-shift)
28 (frob storew st word-shift))
30 (defmacro load-symbol (reg symbol)
31 `(inst add ,reg null-tn (static-symbol-offset ,symbol)))
35 (let ((loader (intern (concatenate 'simple-string
38 (storer (intern (concatenate 'simple-string
41 (offset (intern (concatenate 'simple-string
45 (find-package "SB!VM"))))
47 (defmacro ,loader (reg symbol)
48 `(inst ld ,reg null-tn
49 (+ (static-symbol-offset ',symbol)
50 (ash ,',offset word-shift)
51 (- other-pointer-lowtag))))
52 (defmacro ,storer (reg symbol)
53 `(inst st ,reg null-tn
54 (+ (static-symbol-offset ',symbol)
55 (ash ,',offset word-shift)
56 (- other-pointer-lowtag))))))))
60 (defmacro load-type (target source &optional (offset 0))
62 "Loads the type bits of a pointer into target independent of
63 byte-ordering issues."
64 (once-only ((n-target target)
67 ;; FIXME: although I don't understand entirely, I'm going to do
68 ;; what whn does in x86/macros.lisp -- Christophe
69 (ecase *backend-byte-order*
71 `(inst ldub ,n-target ,n-source ,n-offset))
73 `(inst ldub ,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 (fun)
79 "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
82 (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
85 (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
86 "Return to RETURN-PC."
89 (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
91 `(move code-tn ,return-pc)
94 (defmacro emit-return-pc (label)
95 "Emit a return-pc header word. LABEL is the label to use for this return-pc."
99 (inst lra-header-word)))
105 ;;; Load-Stack-TN, Store-Stack-TN -- Interface
107 ;;; 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))))))
117 (defmacro store-stack-tn (stack reg)
118 `(let ((stack ,stack)
120 (let ((offset (tn-offset stack)))
123 (storew reg cfp-tn offset))))))
126 ;;; MAYBE-LOAD-STACK-TN -- Interface
128 (defmacro maybe-load-stack-tn (reg reg-or-stack)
129 "Move the TN Reg-Or-Stack into Reg if it isn't already there."
130 (once-only ((n-reg reg)
131 (n-stack reg-or-stack))
133 ((any-reg descriptor-reg)
135 ((any-reg descriptor-reg)
136 (move ,n-reg ,n-stack))
138 (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
141 ;;;; Storage allocation:
143 (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
145 "Do stuff to allocate an other-pointer object of fixed Size with a single
146 word header having the specified Type-Code. The result is placed in
147 Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
148 by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably
149 initializes the object."
150 (once-only ((result-tn result-tn) (temp-tn temp-tn)
151 (type-code type-code) (size size))
152 `(pseudo-atomic (:extra (pad-data-block ,size))
153 (inst or ,result-tn alloc-tn other-pointer-lowtag)
154 (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
155 (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
161 (defvar *adjustable-vectors* nil)
163 (defmacro with-adjustable-vector ((var) &rest body)
164 `(let ((,var (or (pop *adjustable-vectors*)
166 :element-type '(unsigned-byte 8)
169 (setf (fill-pointer ,var) 0)
173 (push ,var *adjustable-vectors*))))
175 (eval-when (:compile-toplevel :load-toplevel :execute)
176 (defun emit-error-break (vop kind code values)
177 (let ((vector (gensym)))
180 (note-this-location vop :internal-error)))
182 (with-adjustable-vector (,vector)
183 (write-var-integer (error-number-or-lose ',code) ,vector)
184 ,@(mapcar #'(lambda (tn)
186 (write-var-integer (make-sc-offset (sc-number
191 (inst byte (length ,vector))
192 (dotimes (i (length ,vector))
193 (inst byte (aref ,vector i))))
194 (align word-shift)))))
196 (defmacro error-call (vop error-code &rest values)
197 "Cause an error. ERROR-CODE is the error to cause."
199 (emit-error-break vop error-trap error-code values)))
202 (defmacro cerror-call (vop label error-code &rest values)
203 "Cause a continuable error. If the error is continued, execution resumes at
207 ,@(emit-error-break vop cerror-trap error-code values)))
209 (defmacro generate-error-code (vop error-code &rest values)
210 "Generate-Error-Code Error-code Value*
211 Emit code for an error with the specified Error-Code and context Values."
212 `(assemble (*elsewhere*)
213 (let ((start-lab (gen-label)))
214 (emit-label start-lab)
215 (error-call ,vop ,error-code ,@values)
218 (defmacro generate-cerror-code (vop error-code &rest values)
219 "Generate-CError-Code Error-code Value*
220 Emit code for a continuable error with the specified Error-Code and
221 context Values. If the error is continued, execution resumes after
222 the GENERATE-CERROR-CODE form."
223 (let ((continue (gensym "CONTINUE-LABEL-"))
224 (error (gensym "ERROR-LABEL-")))
225 `(let ((,continue (gen-label)))
226 (emit-label ,continue)
227 (assemble (*elsewhere*)
228 (let ((,error (gen-label)))
230 (cerror-call ,vop ,continue ,error-code ,@values)
235 ;;; a handy macro for making sequences look atomic
236 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
237 (let ((n-extra (gensym)))
238 `(let ((,n-extra ,extra))
239 ;; Set the pseudo-atomic flag.
240 (without-scheduling ()
241 (inst add alloc-tn 4))
243 ;; Reset the pseudo-atomic flag.
244 (without-scheduling ()
245 #+nil (inst taddcctv alloc-tn (- ,n-extra 4))
246 ;; Remove the pseudo-atomic flag.
247 (inst add alloc-tn (- ,n-extra 4))
248 ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1).
249 (inst andcc zero-tn alloc-tn 3)
250 ;; The C code needs to process this correctly and fixup alloc-tn.
251 (inst t :ne pseudo-atomic-trap)))))
253 ;;; FIXME: test typing macros. Should(?) be in type-vops.lisp, except
254 ;;; that they're also used in subprim.lisp
256 (defun cost-to-test-types (type-codes)
257 (+ (* 2 (length type-codes))
258 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
260 (defparameter *immediate-types*
261 (list base-char-widetag unbound-marker-widetag))
263 (defparameter *fun-header-widetags*
264 (list funcallable-instance-header-widetag
265 simple-fun-header-widetag
266 closure-fun-header-widetag
267 closure-header-widetag))
269 (defun gen-range-test (reg target not-target not-p min seperation max values)
274 (multiple-value-bind (equal less-or-equal greater-or-equal label)
276 (values :ne :gt :lt not-target)
277 (values :eq :le :ge target))
281 (push (cons start end) tests))))
282 (dolist (value values)
284 (error "~S is less than the specified minimum of ~S"
287 (error "~S is greater than the specified maximum of ~S"
289 ((not (zerop (rem (- value min) seperation)))
290 (error "~S isn't an even multiple of ~S from ~S"
291 value seperation min))
294 ((> value (+ end seperation))
299 (macrolet ((inst (name &rest args)
300 `(push (list 'inst ',name ,@args) insts)))
301 (do ((remaining (nreverse tests) (cdr remaining)))
303 (let ((test (car remaining))
304 (last (null (cdr remaining))))
309 (inst b equal target)
311 (let ((start (car test))
313 (cond ((and (= start min) (= end max))
314 (warn "The values ~S cover the entire range from ~
316 values min max seperation)
317 (push `(unless ,not-p (inst b ,target)) insts))
321 (inst b less-or-equal target)
326 (inst b greater-or-equal target)
330 (inst b :lt (if not-p target not-target))
333 (inst b less-or-equal target)
334 (inst b :le label))))))))))
337 (defun gen-other-immediate-test (reg target not-target not-p values)
338 (gen-range-test reg target not-target not-p
339 (+ other-immediate-0-lowtag lowtag-limit)
340 (- other-immediate-1-lowtag other-immediate-0-lowtag)
341 (ash 1 n-widetag-bits)
344 (defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
346 (let* ((fixnump (and (member even-fixnum-lowtag lowtags :test #'eql)
347 (member odd-fixnum-lowtag lowtags :test #'eql)))
348 (lowtags (sort (if fixnump
349 (delete even-fixnum-lowtag
350 (remove odd-fixnum-lowtag lowtags
355 (lowtag (if function-p
357 other-pointer-lowtag))
358 (hdrs (sort (copy-list hdrs) #'<))
359 (immed (sort (copy-list immed) #'<)))
362 `((inst and ,temp ,reg widetag-mask)
363 ,@(if (or fixnump lowtags hdrs)
364 (let ((fall-through (gensym)))
365 `((let (,fall-through (gen-label))
366 ,@(gen-other-immediate-test
367 temp (if not-p not-target target)
368 fall-through nil immed)
369 (emit-label ,fall-through))))
370 (gen-other-immediate-test temp target not-target not-p immed))))
372 `((inst andcc zero-tn ,reg fixnum-tag-mask)
373 ,(if (or lowtags hdrs)
374 `(inst b :eq ,(if not-p not-target target)
375 #!+sparc-v9 ,(if not-p :pn :pt))
376 `(inst b ,(if not-p :ne :eq) ,target
377 #!+sparc-v9 ,(if not-p :pn :pt)))))
378 (when (or lowtags hdrs)
379 `((inst and ,temp ,reg lowtag-mask)))
382 (let ((fall-through (gensym)))
383 `((let ((,fall-through (gen-label)))
384 ,@(gen-range-test temp (if not-p not-target target)
386 0 1 (1- lowtag-limit) lowtags)
387 (emit-label ,fall-through))))
388 (gen-range-test temp target not-target not-p 0 1
389 (1- lowtag-limit) lowtags)))
391 `((inst cmp ,temp ,lowtag)
392 (inst b :ne ,(if not-p target not-target)
393 #!+sparc-v9 ,(if not-p :pn :pt))
395 (load-type ,temp ,reg (- ,lowtag))
396 ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
398 (defmacro test-type (register temp target not-p &rest type-codes)
399 (let* ((type-codes (mapcar #'eval type-codes))
400 (lowtags (remove lowtag-limit type-codes :test #'<))
401 (extended (remove lowtag-limit type-codes :test #'>))
402 (immediates (intersection extended *immediate-types* :test #'eql))
403 (headers (set-difference extended *immediate-types* :test #'eql))
406 (error "Must supply at least on type for test-type."))
407 (when (and headers (member other-pointer-lowtag lowtags))
408 (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers)
410 (when (and immediates
411 (or (member other-immediate-0-lowtag lowtags)
412 (member other-immediate-1-lowtag lowtags)))
413 (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
414 (setf immediates nil))
415 (when (intersection headers *fun-header-widetags*)
416 (unless (subsetp headers *fun-header-widetags*)
417 (error "Can't test for mix of function subtypes and normal ~
421 (let ((n-reg (gensym))
424 (not-target (gensym)))
425 `(let ((,n-reg ,register)
428 (,not-target (gen-label)))
429 (declare (ignorable ,n-temp))
430 ,@(if (constantp not-p)
431 (test-type-aux n-reg n-temp n-target not-target
432 (eval not-p) lowtags immediates headers
435 ,@(test-type-aux n-reg n-temp n-target not-target t
436 lowtags immediates headers
439 ,@(test-type-aux n-reg n-temp n-target not-target nil
440 lowtags immediates headers
443 (emit-label ,not-target)))))