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-lowtag
)))
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-widetag sap-size
)
36 (storeq sap y sap-pointer-slot other-pointer-lowtag
))))
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-arg)
59 :load-if
(not (sc-is y sap-reg
))))
66 (storeq x fp
(tn-offset y
))))))
67 (define-move-vop move-sap-arg
:move-arg
68 (descriptor-reg sap-reg
) (sap-reg))
70 ;;; Use standard MOVE-ARG + coercion to move an untagged sap to a
71 ;;; descriptor passing location.
72 (define-move-vop move-arg
:move-arg
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
)))
224 (+ offset n-word-bytes
)
226 (define-vop (,set-name
)
227 (:translate
,set-name
)
229 (:args
(object :scs
(sap-reg) :target sap
)
230 (offset :scs
(signed-reg))
231 (value :scs
(,sc
) :target result
))
232 (:arg-types system-area-pointer signed-num
,type
)
233 (:results
(result :scs
(,sc
)))
234 (:result-types
,type
)
235 (:temporary
(:scs
(sap-reg) :from
(:argument
0)) sap
)
236 ,@(when (or (eq size
:byte
) (eq size
:short
))
237 `((:temporary
(:sc non-descriptor-reg
) temp
)
238 (:temporary
(:sc non-descriptor-reg
) temp1
)
239 (:temporary
(:sc non-descriptor-reg
) temp2
)))
241 (inst addq object offset sap
)
244 '((inst lda temp
0 sap
)
245 (inst ldq_u temp1
0 sap
)
246 (inst insbl value temp temp2
)
247 (inst mskbl temp1 temp temp1
)
248 (inst bis temp1 temp2 temp1
)
249 (inst stq_u temp1
0 sap
)
250 (inst move value result
)))
252 '((inst lda temp
0 sap
)
253 (inst ldq_u temp1
0 sap
)
254 (inst mskwl temp1 temp temp1
)
255 (inst inswl value temp temp2
)
256 (inst bis temp1 temp2 temp
)
257 (inst stq_u temp
0 sap
)
258 (inst move value result
)))
260 '((inst stl value
0 sap
)
261 (move value result
)))
263 '((inst stq value
0 sap
)
264 (move value result
)))
266 '((unless (location= result value
)
267 (inst fmove value result
))
268 (inst sts value
0 sap
)))
270 '((unless (location= result value
)
271 (inst fmove value result
))
272 (inst stt value
0 sap
))))))
273 (define-vop (,set-name-c
)
274 (:translate
,set-name
)
276 (:args
(object :scs
(sap-reg))
277 (value :scs
(,sc
) :target result
))
278 (:arg-types system-area-pointer
279 (:constant
,(if (eq size
:double
)
280 ;; We need to be able to add 4.
281 `(integer ,(- (ash 1 16))
285 ,@(when (or (eq size
:byte
) (eq size
:short
))
286 `((:temporary
(:sc non-descriptor-reg
) temp
)
287 (:temporary
(:sc non-descriptor-reg
) temp1
)
288 (:temporary
(:sc non-descriptor-reg
) temp2
)))
290 (:results
(result :scs
(,sc
)))
291 (:result-types
,type
)
295 '((inst lda temp offset object
)
296 (inst ldq_u temp1 offset object
)
297 (inst insbl value temp temp2
)
298 (inst mskbl temp1 temp temp1
)
299 (inst bis temp1 temp2 temp1
)
300 (inst stq_u temp1 offset object
)
301 (inst move value result
)))
303 '((inst lda temp offset object
)
304 (inst ldq_u temp1 offset object
)
305 (inst mskwl temp1 temp temp1
)
306 (inst inswl value temp temp2
)
307 (inst bis temp1 temp2 temp
)
308 (inst stq_u temp offset object
)
309 (inst move value result
)))
311 '((inst stl value offset object
)
312 (move value result
)))
314 '((inst stq value offset object
)
315 (move value result
)))
317 '((unless (location= result value
)
318 (inst fmove value result
))
319 (inst sts value offset object
)))
321 '((unless (location= result value
)
322 (inst fmove value result
))
323 (inst stt value offset object
))))))))))
324 (def-system-ref-and-set sap-ref-8 %set-sap-ref-8
325 unsigned-reg positive-fixnum
:byte nil
)
326 (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
327 signed-reg tagged-num
:byte t
)
328 (def-system-ref-and-set sap-ref-16 %set-sap-ref-16
329 unsigned-reg positive-fixnum
:short nil
)
330 (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
331 signed-reg tagged-num
:short t
)
332 (def-system-ref-and-set sap-ref-32 %set-sap-ref-32
333 unsigned-reg unsigned-num
:long nil
)
334 (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
335 signed-reg signed-num
:long t
)
336 (def-system-ref-and-set sap-ref-64 %set-sap-ref-64
337 unsigned-reg unsigned-num
:quad nil
)
338 (def-system-ref-and-set signed-sap-ref-64 %set-signed-sap-ref-64
339 signed-reg signed-num
:quad t
)
340 (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
341 sap-reg system-area-pointer
:quad
)
342 (def-system-ref-and-set sap-ref-lispobj %set-sap-ref-lispobj
343 descriptor-reg
* :long
)
344 (def-system-ref-and-set sap-ref-single %set-sap-ref-single
345 single-reg single-float
:single
)
346 (def-system-ref-and-set sap-ref-double %set-sap-ref-double
347 double-reg double-float
:double
))
349 ;;; noise to convert normal Lisp data objects into SAPs
351 (define-vop (vector-sap)
352 (:translate vector-sap
)
354 (:args
(vector :scs
(descriptor-reg)))
355 (:results
(sap :scs
(sap-reg)))
356 (:result-types system-area-pointer
)
359 (- (* vector-data-offset n-word-bytes
) other-pointer-lowtag
)