6 ;;; Instruction-like macros.
8 (defmacro move (dst src)
9 "Move SRC into DST unless they are location=."
10 (once-only ((n-dst dst)
12 `(unless (location= ,n-dst ,n-src)
13 (inst mr ,n-dst ,n-src))))
16 ((frob (op inst shift)
17 `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
18 `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
19 (frob loadw lwz word-shift)
20 (frob storew stw word-shift))
22 (defmacro load-symbol (reg symbol)
23 `(inst addi ,reg null-tn (static-symbol-offset ,symbol)))
27 (let ((loader (intern (concatenate 'simple-string
30 (storer (intern (concatenate 'simple-string
33 (offset (intern (concatenate 'simple-string
37 (find-package "SB!VM"))))
39 (defmacro ,loader (reg symbol)
40 `(inst lwz ,reg null-tn
41 (+ (static-symbol-offset ',symbol)
42 (ash ,',offset word-shift)
43 (- other-pointer-lowtag))))
44 (defmacro ,storer (reg symbol)
45 `(inst stw ,reg null-tn
46 (+ (static-symbol-offset ',symbol)
47 (ash ,',offset word-shift)
48 (- 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 lbz ,n-target ,n-source ,n-offset))
62 `(inst lbz ,n-target ,n-source (+ ,n-offset 3))))))
64 ;;; Macros to handle the fact that we cannot use the machine native call and
65 ;;; return instructions.
67 (defmacro lisp-jump (function lip)
68 "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
70 ;; something is deeply bogus. look at this
71 ;; (loadw ,lip ,function sb!vm:function-code-offset sb!vm:function-pointer-type)
72 (inst addi ,lip ,function (- (* n-word-bytes sb!vm:simple-fun-code-offset) sb!vm:fun-pointer-lowtag))
74 (move code-tn ,function)
77 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
78 "Return to RETURN-PC."
80 (inst addi ,lip ,return-pc (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
83 `((move code-tn ,return-pc)))
86 (defmacro emit-return-pc (label)
87 "Emit a return-pc header word. LABEL is the label to use for this return-pc."
91 (inst lra-header-word)))
97 ;;; Load-Stack-TN, Store-Stack-TN -- Interface
99 ;;; Move a stack TN to a register and vice-versa.
101 (defmacro load-stack-tn (reg stack)
104 (let ((offset (tn-offset stack)))
107 (loadw reg cfp-tn offset))))))
109 (defmacro store-stack-tn (stack reg)
110 `(let ((stack ,stack)
112 (let ((offset (tn-offset stack)))
115 (storew reg cfp-tn offset))))))
118 ;;; MAYBE-LOAD-STACK-TN -- Interface
120 (defmacro maybe-load-stack-tn (reg reg-or-stack)
121 "Move the TN Reg-Or-Stack into Reg if it isn't already there."
122 (once-only ((n-reg reg)
123 (n-stack reg-or-stack))
125 ((any-reg descriptor-reg)
127 ((any-reg descriptor-reg)
128 (move ,n-reg ,n-stack))
130 (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
133 ;;;; Storage allocation:
135 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
137 "Do stuff to allocate an other-pointer object of fixed Size with a single
138 word header having the specified Type-Code. The result is placed in
139 Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
140 by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably
141 initializes the object."
142 (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
143 (type-code type-code) (size size))
144 `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
145 (inst ori ,result-tn alloc-tn other-pointer-lowtag)
146 (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
147 (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
151 ;;;; Type testing noise.
153 ;;; GEN-RANGE-TEST -- internal
155 ;;; Generate code that branches to TARGET iff REG contains one of VALUES.
156 ;;; If NOT-P is true, invert the test. Jumping to NOT-TARGET is the same
157 ;;; as falling out the bottom.
159 (defun gen-range-test (reg target not-target not-p min seperation max values)
164 (multiple-value-bind (equal less-or-equal greater-or-equal label)
166 (values :ne :gt :lt not-target)
167 (values :eq :le :ge target))
171 (push (cons start end) tests))))
172 (dolist (value values)
174 (error "~S is less than the specified minimum of ~S"
177 (error "~S is greater than the specified maximum of ~S"
179 ((not (zerop (rem (- value min) seperation)))
180 (error "~S isn't an even multiple of ~S from ~S"
181 value seperation min))
184 ((> value (+ end seperation))
189 (macrolet ((inst (name &rest args)
190 `(push (list 'inst ',name ,@args) insts)))
191 (do ((remaining (nreverse tests) (cdr remaining)))
193 (let ((test (car remaining))
194 (last (null (cdr remaining))))
197 (inst cmpwi reg test)
199 (inst b? equal target)
201 (let ((start (car test))
203 (cond ((and (= start min) (= end max))
204 (warn "The values ~S cover the entire range from ~
206 values min max seperation)
207 (push `(unless ,not-p (inst b ,target)) insts))
211 (inst b? less-or-equal target)
214 (inst cmpwi reg start)
216 (inst b? greater-or-equal target)
219 (inst cmpwi reg start)
220 (inst blt (if not-p target not-target))
223 (inst b? less-or-equal target)
224 (inst ble label))))))))))
227 (defun gen-other-immediate-test (reg target not-target not-p values)
228 (gen-range-test reg target not-target not-p
229 (+ other-immediate-0-lowtag lowtag-limit)
230 (- other-immediate-1-lowtag other-immediate-0-lowtag)
231 (ash 1 n-widetag-bits)
235 (defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
237 (let* ((fixnump (and (member even-fixnum-lowtag lowtags :test #'eql)
238 (member odd-fixnum-lowtag lowtags :test #'eql)))
239 (lowtags (sort (if fixnump
240 (delete even-fixnum-lowtag
241 (remove odd-fixnum-lowtag lowtags
246 (lowtag (if function-p
247 sb!vm:fun-pointer-lowtag
248 sb!vm:other-pointer-lowtag))
249 (hdrs (sort (copy-list hdrs) #'<))
250 (immed (sort (copy-list immed) #'<)))
253 `((inst andi. ,temp ,reg widetag-mask)
254 ,@(if (or fixnump lowtags hdrs)
255 (let ((fall-through (gensym)))
256 `((let (,fall-through (gen-label))
257 ,@(gen-other-immediate-test
258 temp (if not-p not-target target)
259 fall-through nil immed)
260 (emit-label ,fall-through))))
261 (gen-other-immediate-test temp target not-target not-p immed))))
263 `((inst andi. ,temp ,reg 3)
264 ,(if (or lowtags hdrs)
265 `(inst beq ,(if not-p not-target target))
266 `(inst b? ,(if not-p :ne :eq) ,target))))
267 (when (or lowtags hdrs)
268 `((inst andi. ,temp ,reg lowtag-mask)))
271 (let ((fall-through (gensym)))
272 `((let ((,fall-through (gen-label)))
273 ,@(gen-range-test temp (if not-p not-target target)
275 0 1 (1- lowtag-limit) lowtags)
276 (emit-label ,fall-through))))
277 (gen-range-test temp target not-target not-p 0 1
278 (1- lowtag-limit) lowtags)))
280 `((inst cmpwi ,temp ,lowtag)
281 (inst bne ,(if not-p target not-target))
282 (load-type ,temp ,reg (- ,lowtag))
283 ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
285 (defparameter immediate-types
286 (list base-char-widetag unbound-marker-widetag))
288 (defparameter function-subtypes
289 (list funcallable-instance-header-widetag
290 simple-fun-header-widetag closure-fun-header-widetag
291 closure-header-widetag))
293 (defmacro test-type (register temp target not-p &rest type-codes)
294 (let* ((type-codes (mapcar #'eval type-codes))
295 (lowtags (remove lowtag-limit type-codes :test #'<))
296 (extended (remove lowtag-limit type-codes :test #'>))
297 (immediates (intersection extended immediate-types :test #'eql))
298 (headers (set-difference extended immediate-types :test #'eql))
301 (error "Must supply at least on type for test-type."))
302 (when (and headers (member other-pointer-lowtag lowtags))
303 (warn "OTHER-POINTER-LOWTAG supersedes the use of ~S" headers)
305 (when (and immediates
306 (or (member other-immediate-0-lowtag lowtags)
307 (member other-immediate-1-lowtag lowtags)))
308 (warn "OTHER-IMMEDIATE-n-LOWTAG supersedes the use of ~S" immediates)
309 (setf immediates nil))
310 (when (intersection headers function-subtypes)
311 (unless (subsetp headers function-subtypes)
312 (error "Can't test for mix of function subtypes and normal ~
316 (let ((n-reg (gensym))
319 (not-target (gensym)))
320 `(let ((,n-reg ,register)
323 (,not-target (gen-label)))
324 (declare (ignorable ,n-temp))
325 ,@(if (constantp not-p)
326 (test-type-aux n-reg n-temp n-target not-target
327 (eval not-p) lowtags immediates headers
330 ,@(test-type-aux n-reg n-temp n-target not-target t
331 lowtags immediates headers
334 ,@(test-type-aux n-reg n-temp n-target not-target nil
335 lowtags immediates headers
337 (emit-label ,not-target)))))
342 (defvar *adjustable-vectors* nil)
344 (defmacro with-adjustable-vector ((var) &rest body)
345 `(let ((,var (or (pop *adjustable-vectors*)
347 :element-type '(unsigned-byte 8)
350 (declare (type (vector (unsigned-byte 8) 16) ,var))
351 (setf (fill-pointer ,var) 0)
355 (push ,var *adjustable-vectors*))))
357 (eval-when (:compile-toplevel :load-toplevel :execute)
358 (defun emit-error-break (vop kind code values)
359 (let ((vector (gensym)))
362 (note-this-location vop :internal-error)))
364 (with-adjustable-vector (,vector)
365 (write-var-integer (error-number-or-lose ',code) ,vector)
366 ,@(mapcar #'(lambda (tn)
368 (write-var-integer (make-sc-offset (sc-number
373 (inst byte (length ,vector))
374 (dotimes (i (length ,vector))
375 (inst byte (aref ,vector i))))
376 (align word-shift)))))
378 (defmacro error-call (vop error-code &rest values)
379 "Cause an error. ERROR-CODE is the error to cause."
381 (emit-error-break vop error-trap error-code values)))
384 (defmacro cerror-call (vop label error-code &rest values)
385 "Cause a continuable error. If the error is continued, execution resumes at
388 ,@(emit-error-break vop cerror-trap error-code values)
391 (defmacro generate-error-code (vop error-code &rest values)
392 "Generate-Error-Code Error-code Value*
393 Emit code for an error with the specified Error-Code and context Values."
394 `(assemble (*elsewhere*)
395 (let ((start-lab (gen-label)))
396 (emit-label start-lab)
397 (error-call ,vop ,error-code ,@values)
400 (defmacro generate-cerror-code (vop error-code &rest values)
401 "Generate-CError-Code Error-code Value*
402 Emit code for a continuable error with the specified Error-Code and
403 context Values. If the error is continued, execution resumes after
404 the GENERATE-CERROR-CODE form."
405 (let ((continue (gensym "CONTINUE-LABEL-"))
406 (error (gensym "ERROR-LABEL-")))
407 `(let ((,continue (gen-label)))
408 (emit-label ,continue)
409 (assemble (*elsewhere*)
410 (let ((,error (gen-label)))
412 (cerror-call ,vop ,continue ,error-code ,@values)
417 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
419 ;;; flag-tn must be wired to NL3. If a deferred interrupt happens
420 ;;; while we have the low bits of alloc-tn set, we add a "large"
421 ;;; constant to flag-tn. On exit, we add flag-tn to alloc-tn
422 ;;; which (a) aligns alloc-tn again and (b) makes alloc-tn go
423 ;;; negative. We then trap if alloc-tn's negative (handling the
424 ;;; deferred interrupt) and using flag-tn - minus the large constant -
425 ;;; to correct alloc-tn.
426 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
427 (let ((n-extra (gensym)))
428 `(let ((,n-extra ,extra))
429 (without-scheduling ()
430 ;; Extra debugging stuff:
433 (inst andi. ,flag-tn alloc-tn 7)
434 (inst twi :ne ,flag-tn 0))
435 (inst lr ,flag-tn (- ,n-extra 4))
436 (inst addi alloc-tn alloc-tn 4))
438 (without-scheduling ()
439 (inst add alloc-tn alloc-tn ,flag-tn)
440 (inst twi :lt alloc-tn 0))
443 (inst andi. ,flag-tn alloc-tn 7)
444 (inst twi :ne ,flag-tn 0)))))