1 ;;;; a bunch of handy macros for the PPC
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 mr ,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 lwz word-shift)
28 (frob storew stw word-shift))
30 (defmacro load-symbol (reg symbol)
31 `(inst addi ,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 lwz ,reg null-tn
49 (+ (static-symbol-offset ',symbol)
50 (ash ,',offset word-shift)
51 (- other-pointer-lowtag))))
52 (defmacro ,storer (reg symbol)
53 `(inst stw ,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))
61 "Loads the type bits of a pointer into target independent of
62 byte-ordering issues."
63 (once-only ((n-target target)
66 (ecase *backend-byte-order*
68 `(inst lbz ,n-target ,n-source ,n-offset))
70 `(inst lbz ,n-target ,n-source (+ ,n-offset 3))))))
72 ;;; Macros to handle the fact that we cannot use the machine native call and
73 ;;; return instructions.
75 (defmacro lisp-jump (function lip)
76 "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
78 ;; something is deeply bogus. look at this
79 ;; (loadw ,lip ,function sb!vm:function-code-offset sb!vm:function-pointer-type)
80 (inst addi ,lip ,function (- (* n-word-bytes sb!vm:simple-fun-code-offset) sb!vm:fun-pointer-lowtag))
82 (move code-tn ,function)
85 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
86 "Return to RETURN-PC."
88 (inst addi ,lip ,return-pc (- (* (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 ;;; Move a stack TN to a register and vice-versa.
106 (defmacro load-stack-tn (reg stack)
109 (let ((offset (tn-offset stack)))
112 (loadw reg cfp-tn offset))))))
113 (defmacro store-stack-tn (stack reg)
114 `(let ((stack ,stack)
116 (let ((offset (tn-offset stack)))
119 (storew reg cfp-tn offset))))))
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:
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)
152 (eval-when (:compile-toplevel :load-toplevel :execute)
153 (defun emit-error-break (vop kind code values)
154 (let ((vector (gensym)))
157 (note-this-location vop :internal-error)))
159 (with-adjustable-vector (,vector)
160 (write-var-integer (error-number-or-lose ',code) ,vector)
161 ,@(mapcar #'(lambda (tn)
163 (write-var-integer (make-sc-offset (sc-number
168 (inst byte (length ,vector))
169 (dotimes (i (length ,vector))
170 (inst byte (aref ,vector i))))
171 (align word-shift)))))
173 (defmacro error-call (vop error-code &rest values)
174 "Cause an error. ERROR-CODE is the error to cause."
176 (emit-error-break vop error-trap error-code values)))
179 (defmacro cerror-call (vop label error-code &rest values)
180 "Cause a continuable error. If the error is continued, execution resumes at
183 ,@(emit-error-break vop cerror-trap error-code values)
186 (defmacro generate-error-code (vop error-code &rest values)
187 "Generate-Error-Code Error-code Value*
188 Emit code for an error with the specified Error-Code and context Values."
189 `(assemble (*elsewhere*)
190 (let ((start-lab (gen-label)))
191 (emit-label start-lab)
192 (error-call ,vop ,error-code ,@values)
195 (defmacro generate-cerror-code (vop error-code &rest values)
196 "Generate-CError-Code Error-code Value*
197 Emit code for a continuable error with the specified Error-Code and
198 context Values. If the error is continued, execution resumes after
199 the GENERATE-CERROR-CODE form."
200 (let ((continue (gensym "CONTINUE-LABEL-"))
201 (error (gensym "ERROR-LABEL-")))
202 `(let ((,continue (gen-label)))
203 (emit-label ,continue)
204 (assemble (*elsewhere*)
205 (let ((,error (gen-label)))
207 (cerror-call ,vop ,continue ,error-code ,@values)
212 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
214 ;;; flag-tn must be wired to NL3. If a deferred interrupt happens
215 ;;; while we have the low bits of alloc-tn set, we add a "large"
216 ;;; constant to flag-tn. On exit, we add flag-tn to alloc-tn
217 ;;; which (a) aligns alloc-tn again and (b) makes alloc-tn go
218 ;;; negative. We then trap if alloc-tn's negative (handling the
219 ;;; deferred interrupt) and using flag-tn - minus the large constant -
220 ;;; to correct alloc-tn.
221 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
222 (let ((n-extra (gensym)))
223 `(let ((,n-extra ,extra))
224 (without-scheduling ()
225 ;; Extra debugging stuff:
228 (inst andi. ,flag-tn alloc-tn 7)
229 (inst twi :ne ,flag-tn 0))
230 (inst lr ,flag-tn (- ,n-extra 4))
231 (inst addi alloc-tn alloc-tn 4))
233 (without-scheduling ()
234 (inst add alloc-tn alloc-tn ,flag-tn)
235 (inst twi :lt alloc-tn 0))
238 (inst andi. ,flag-tn alloc-tn 7)
239 (inst twi :ne ,flag-tn 0)))))