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 (with-unique-names (continue error)
201 `(let ((,continue (gen-label)))
202 (emit-label ,continue)
203 (assemble (*elsewhere*)
204 (let ((,error (gen-label)))
206 (cerror-call ,vop ,continue ,error-code ,@values)
211 ;;; handy macro for making sequences look atomic
213 ;;; FLAG-TN must be wired to NL3. If a deferred interrupt happens
214 ;;; while we have the low bits of ALLOC-TN set, we add a "large"
215 ;;; constant to FLAG-TN. On exit, we add FLAG-TN to ALLOC-TN which (a)
216 ;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then
217 ;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
218 ;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
219 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
220 (let ((n-extra (gensym)))
221 `(let ((,n-extra ,extra))
222 (without-scheduling ()
223 ;; Extra debugging stuff:
226 (inst andi. ,flag-tn alloc-tn 7)
227 (inst twi :ne ,flag-tn 0))
228 (inst lr ,flag-tn (- ,n-extra 4))
229 (inst addi alloc-tn alloc-tn 4))
231 (without-scheduling ()
232 (inst add alloc-tn alloc-tn ,flag-tn)
233 (inst twi :lt alloc-tn 0))
236 (inst andi. ,flag-tn alloc-tn 7)
237 (inst twi :ne ,flag-tn 0)))))