1 ;;;; the Alpha VM definition of SAP operations
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 ;;;; moves and coercions
16 ;;; Move a tagged SAP to an untagged representation.
17 (define-vop (move-to-sap)
18 (:args (x :scs (descriptor-reg)))
19 (:results (y :scs (sap-reg)))
20 (:note "system area pointer indirection")
22 (loadq y x sap-pointer-slot other-pointer-type)))
23 (define-move-vop move-to-sap :move
24 (descriptor-reg) (sap-reg))
26 ;;; Move an untagged SAP to a tagged representation.
27 (define-vop (move-from-sap)
28 (:args (x :scs (sap-reg) :target sap))
29 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
30 (:temporary (:scs (non-descriptor-reg)) ndescr)
31 (:results (y :scs (descriptor-reg)))
32 (:note "system area pointer allocation")
35 (with-fixed-allocation (y ndescr sap-type sap-size)
36 (storeq sap y sap-pointer-slot other-pointer-type))))
37 (define-move-vop move-from-sap :move
38 (sap-reg) (descriptor-reg))
40 ;;; Move untagged SAP values.
41 (define-vop (sap-move)
44 :load-if (not (location= x y))))
45 (:results (y :scs (sap-reg)
46 :load-if (not (location= x y))))
51 (define-move-vop sap-move :move
54 ;;; Move untagged SAP arguments/return-values.
55 (define-vop (move-sap-argument)
59 :load-if (not (sc-is y sap-reg))))
66 (storeq x fp (tn-offset y))))))
67 (define-move-vop move-sap-argument :move-argument
68 (descriptor-reg sap-reg) (sap-reg))
70 ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
71 ;;; descriptor passing location.
72 (define-move-vop move-argument :move-argument
73 (sap-reg) (descriptor-reg))
75 ;;;; SAP-INT and INT-SAP
78 (:args (sap :scs (sap-reg) :target int))
79 (:arg-types system-area-pointer)
80 (:results (int :scs (unsigned-reg)))
81 (:result-types unsigned-num)
88 (:args (int :scs (unsigned-reg) :target sap))
89 (:arg-types unsigned-num)
90 (:results (sap :scs (sap-reg)))
91 (:result-types system-area-pointer)
97 ;;;; POINTER+ and POINTER-
99 (define-vop (pointer+)
101 (:args (ptr :scs (sap-reg))
102 (offset :scs (signed-reg immediate)))
103 (:arg-types system-area-pointer signed-num)
104 (:results (res :scs (sap-reg)))
105 (:result-types system-area-pointer)
110 (inst addq offset ptr res))
112 (inst lda res (tn-value offset) ptr)))))
114 (define-vop (pointer-)
116 (:args (ptr1 :scs (sap-reg))
117 (ptr2 :scs (sap-reg)))
118 (:arg-types system-area-pointer system-area-pointer)
120 (:results (res :scs (signed-reg)))
121 (:result-types signed-num)
123 (inst subq ptr1 ptr2 res)))
125 ;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
127 (macrolet ((def-system-ref-and-set
128 (ref-name set-name sc type size &optional signed)
129 (let ((ref-name-c (symbolicate ref-name "-C"))
130 (set-name-c (symbolicate set-name "-C")))
132 (define-vop (,ref-name)
133 (:translate ,ref-name)
135 (:args (object :scs (sap-reg) :target sap)
136 (offset :scs (signed-reg)))
137 (:arg-types system-area-pointer signed-num)
138 ,@(when (or (eq size :byte) (eq size :short))
139 `((:temporary (:sc non-descriptor-reg) temp)
140 (:temporary (:sc non-descriptor-reg) temp1)))
141 (:results (result :scs (,sc)))
142 (:result-types ,type)
143 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
145 (inst addq object offset sap)
149 '((inst ldq_u temp 0 sap)
150 (inst lda temp1 1 sap)
151 (inst extqh temp temp1 temp)
152 (inst sra temp 56 result))
153 '((inst ldq_u temp 0 sap)
154 (inst lda temp1 0 sap)
155 (inst extbl temp temp1 result))))
158 '((inst ldq_u temp 0 sap)
159 (inst lda temp1 0 sap)
160 (inst extwl temp temp1 temp)
161 (inst sll temp 48 temp)
162 (inst sra temp 48 result))
163 '((inst ldq_u temp 0 sap)
164 (inst lda temp1 0 sap)
165 (inst extwl temp temp1 result))))
167 `((inst ldl result 0 sap)
169 '((inst mskll result 4 result)))))
171 '((inst ldq result 0 sap)))
173 '((inst lds result 0 sap)))
175 '((inst ldt result 0 sap))))))
176 (define-vop (,ref-name-c)
177 (:translate ,ref-name)
179 (:args (object :scs (sap-reg)))
180 (:arg-types system-area-pointer
181 (:constant ,(if (eq size :double)
182 ;; We need to be able to add 4.
183 `(integer ,(- (ash 1 16))
186 ,@(when (or (eq size :byte) (eq size :short))
187 `((:temporary (:scs (non-descriptor-reg)) temp)
188 (:temporary (:sc non-descriptor-reg) temp1)))
190 (:results (result :scs (,sc)))
191 (:result-types ,type)
196 '((inst ldq_u temp offset object)
197 (inst lda temp1 (1+ offset) object)
198 (inst extqh temp temp1 temp)
199 (inst sra temp 56 result))
200 '((inst ldq_u temp offset object)
201 (inst lda temp1 offset object)
202 (inst extbl temp temp1 result))))
205 '((inst ldq_u temp offset object)
206 (inst lda temp1 offset object)
207 (inst extwl temp temp1 temp)
208 (inst sll temp 48 temp)
209 (inst sra temp 48 result))
210 '((inst ldq_u temp offset object)
211 (inst lda temp1 offset object)
212 (inst extwl temp temp1 result))))
214 `((inst ldl result offset object)
216 '((inst mskll result 4 result)))))
218 '((inst ldq result offset object)))
220 '((inst lds result offset object)))
222 '((inst ldt result (+ offset word-bytes) object))))))
223 (define-vop (,set-name)
224 (:translate ,set-name)
226 (:args (object :scs (sap-reg) :target sap)
227 (offset :scs (signed-reg))
228 (value :scs (,sc) :target result))
229 (:arg-types system-area-pointer signed-num ,type)
230 (:results (result :scs (,sc)))
231 (:result-types ,type)
232 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
233 ,@(when (or (eq size :byte) (eq size :short))
234 `((:temporary (:sc non-descriptor-reg) temp)
235 (:temporary (:sc non-descriptor-reg) temp1)
236 (:temporary (:sc non-descriptor-reg) temp2)))
238 (inst addq object offset sap)
241 '((inst lda temp 0 sap)
242 (inst ldq_u temp1 0 sap)
243 (inst insbl value temp temp2)
244 (inst mskbl temp1 temp temp1)
245 (inst bis temp1 temp2 temp1)
246 (inst stq_u temp1 0 sap)
247 (inst move value result)))
249 '((inst lda temp 0 sap)
250 (inst ldq_u temp1 0 sap)
251 (inst mskwl temp1 temp temp1)
252 (inst inswl value temp temp2)
253 (inst bis temp1 temp2 temp)
254 (inst stq_u temp 0 sap)
255 (inst move value result)))
257 '((inst stl value 0 sap)
258 (move value result)))
260 '((inst stq value 0 sap)
261 (move value result)))
263 '((unless (location= result value)
264 (inst fmove value result))
265 (inst sts value 0 sap)))
267 '((unless (location= result value)
268 (inst fmove value result))
269 (inst stt value 0 sap))))))
270 (define-vop (,set-name-c)
271 (:translate ,set-name)
273 (:args (object :scs (sap-reg))
274 (value :scs (,sc) :target result))
275 (:arg-types system-area-pointer
276 (:constant ,(if (eq size :double)
277 ;; We need to be able to add 4.
278 `(integer ,(- (ash 1 16))
282 ,@(when (or (eq size :byte) (eq size :short))
283 `((:temporary (:sc non-descriptor-reg) temp)
284 (:temporary (:sc non-descriptor-reg) temp1)
285 (:temporary (:sc non-descriptor-reg) temp2)))
287 (:results (result :scs (,sc)))
288 (:result-types ,type)
292 '((inst lda temp offset object)
293 (inst ldq_u temp1 offset object)
294 (inst insbl value temp temp2)
295 (inst mskbl temp1 temp temp1)
296 (inst bis temp1 temp2 temp1)
297 (inst stq_u temp1 offset object)
298 (inst move value result)))
300 '((inst lda temp offset object)
301 (inst ldq_u temp1 offset object)
302 (inst mskwl temp1 temp temp1)
303 (inst inswl value temp temp2)
304 (inst bis temp1 temp2 temp)
305 (inst stq_u temp offset object)
306 (inst move value result)))
308 '((inst stl value offset object)
309 (move value result)))
311 '((inst stq value offset object)
312 (move value result)))
314 '((unless (location= result value)
315 (inst fmove value result))
316 (inst sts value offset object)))
318 '((unless (location= result value)
319 (inst fmove value result))
320 (inst stt value offset object))))))))))
321 (def-system-ref-and-set sap-ref-8 %set-sap-ref-8
322 unsigned-reg positive-fixnum :byte nil)
323 (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
324 signed-reg tagged-num :byte t)
325 (def-system-ref-and-set sap-ref-16 %set-sap-ref-16
326 unsigned-reg positive-fixnum :short nil)
327 (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
328 signed-reg tagged-num :short t)
329 (def-system-ref-and-set sap-ref-32 %set-sap-ref-32
330 unsigned-reg unsigned-num :long nil)
331 (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
332 signed-reg signed-num :long t)
333 (def-system-ref-and-set sap-ref-64 %set-sap-ref-64
334 unsigned-reg unsigned-num :quad nil)
335 (def-system-ref-and-set signed-sap-ref-64 %set-signed-sap-ref-64
336 signed-reg signed-num :quad t)
337 (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
338 sap-reg system-area-pointer :quad)
339 (def-system-ref-and-set sap-ref-single %set-sap-ref-single
340 single-reg single-float :single)
341 (def-system-ref-and-set sap-ref-double %set-sap-ref-double
342 double-reg double-float :double))
344 ;;; noise to convert normal Lisp data objects into SAPs
346 (define-vop (vector-sap)
347 (:translate vector-sap)
349 (:args (vector :scs (descriptor-reg)))
350 (:results (sap :scs (sap-reg)))
351 (:result-types system-area-pointer)
354 (- (* vector-data-offset word-bytes) other-pointer-type)