1 ;;; -*- Package: VM; Log: C.Log -*-
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
9 ;;; **********************************************************************
11 ;;; This file contains the Alpha VM definition of SAP operations.
13 ;;; Written by William Lott.
14 ;;; Alpha conversion by Sean Hallgren.
20 ;;;; Moves and coercions:
22 ;;; Move a tagged SAP to an untagged representation.
25 (define-vop (move-to-sap)
26 (:args (x :scs (descriptor-reg)))
27 (:results (y :scs (sap-reg)))
28 (:note "system area pointer indirection")
30 (loadq y x sap-pointer-slot other-pointer-type)))
33 (define-move-vop move-to-sap :move
34 (descriptor-reg) (sap-reg))
37 ;;; Move an untagged SAP to a tagged representation.
39 (define-vop (move-from-sap)
40 (:args (x :scs (sap-reg) :target sap))
41 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
42 (:temporary (:scs (non-descriptor-reg)) ndescr)
43 (:results (y :scs (descriptor-reg)))
44 (:note "system area pointer allocation")
47 (with-fixed-allocation (y ndescr sap-type sap-size)
48 (storeq sap y sap-pointer-slot other-pointer-type))))
50 (define-move-vop move-from-sap :move
51 (sap-reg) (descriptor-reg))
54 ;;; Move untagged sap values.
56 (define-vop (sap-move)
59 :load-if (not (location= x y))))
60 (:results (y :scs (sap-reg)
61 :load-if (not (location= x y))))
67 (define-move-vop sap-move :move
71 ;;; Move untagged sap arguments/return-values.
73 (define-vop (move-sap-argument)
77 :load-if (not (sc-is y sap-reg))))
84 (storeq x fp (tn-offset y))))))
86 (define-move-vop move-sap-argument :move-argument
87 (descriptor-reg sap-reg) (sap-reg))
90 ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
91 ;;; descriptor passing location.
93 (define-move-vop move-argument :move-argument
94 (sap-reg) (descriptor-reg))
98 ;;;; SAP-INT and INT-SAP
100 (define-vop (sap-int)
101 (:args (sap :scs (sap-reg) :target int))
102 (:arg-types system-area-pointer)
103 (:results (int :scs (unsigned-reg)))
104 (:result-types unsigned-num)
110 (define-vop (int-sap)
111 (:args (int :scs (unsigned-reg) :target sap))
112 (:arg-types unsigned-num)
113 (:results (sap :scs (sap-reg)))
114 (:result-types system-area-pointer)
122 ;;;; POINTER+ and POINTER-
124 (define-vop (pointer+)
126 (:args (ptr :scs (sap-reg))
127 (offset :scs (signed-reg immediate)))
128 (:arg-types system-area-pointer signed-num)
129 (:results (res :scs (sap-reg)))
130 (:result-types system-area-pointer)
135 (inst addq offset ptr res))
137 (inst lda res (tn-value offset) ptr)))))
139 (define-vop (pointer-)
141 (:args (ptr1 :scs (sap-reg))
142 (ptr2 :scs (sap-reg)))
143 (:arg-types system-area-pointer system-area-pointer)
145 (:results (res :scs (signed-reg)))
146 (:result-types signed-num)
148 (inst subq ptr1 ptr2 res)))
151 ;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
153 (macrolet ((def-system-ref-and-set
154 (ref-name set-name sc type size &optional signed)
155 (let ((ref-name-c (symbolicate ref-name "-C"))
156 (set-name-c (symbolicate set-name "-C")))
158 (define-vop (,ref-name)
159 (:translate ,ref-name)
161 (:args (object :scs (sap-reg) :target sap)
162 (offset :scs (signed-reg)))
163 (:arg-types system-area-pointer signed-num)
164 ,@(when (or (eq size :byte) (eq size :short))
165 `((:temporary (:sc non-descriptor-reg) temp)
166 (:temporary (:sc non-descriptor-reg) temp1)))
167 (:results (result :scs (,sc)))
168 (:result-types ,type)
169 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
171 (inst addq object offset sap)
175 '((inst ldq_u temp 0 sap)
176 (inst lda temp1 1 sap)
177 (inst extqh temp temp1 temp)
178 (inst sra temp 56 result))
179 '((inst ldq_u temp 0 sap)
180 (inst lda temp1 0 sap)
181 (inst extbl temp temp1 result))))
184 '((inst ldq_u temp 0 sap)
185 (inst lda temp1 0 sap)
186 (inst extwl temp temp1 temp)
187 (inst sll temp 48 temp)
188 (inst sra temp 48 result))
189 '((inst ldq_u temp 0 sap)
190 (inst lda temp1 0 sap)
191 (inst extwl temp temp1 result))))
193 `((inst ldl result 0 sap)
195 '((inst mskll result 4 result)))))
197 '((inst ldq result 0 sap)))
199 '((inst lds result 0 sap)))
201 '((inst ldt result 0 sap))))))
202 (define-vop (,ref-name-c)
203 (:translate ,ref-name)
205 (:args (object :scs (sap-reg)))
206 (:arg-types system-area-pointer
207 (:constant ,(if (eq size :double)
208 ;; We need to be able to add 4.
209 `(integer ,(- (ash 1 16))
212 ,@(when (or (eq size :byte) (eq size :short))
213 `((:temporary (:scs (non-descriptor-reg)) temp)
214 (:temporary (:sc non-descriptor-reg) temp1)))
216 (:results (result :scs (,sc)))
217 (:result-types ,type)
222 '((inst ldq_u temp offset object)
223 (inst lda temp1 (1+ offset) object)
224 (inst extqh temp temp1 temp)
225 (inst sra temp 56 result))
226 '((inst ldq_u temp offset object)
227 (inst lda temp1 offset object)
228 (inst extbl temp temp1 result))))
231 '((inst ldq_u temp offset object)
232 (inst lda temp1 offset object)
233 (inst extwl temp temp1 temp)
234 (inst sll temp 48 temp)
235 (inst sra temp 48 result))
236 '((inst ldq_u temp offset object)
237 (inst lda temp1 offset object)
238 (inst extwl temp temp1 result))))
240 `((inst ldl result offset object)
242 '((inst mskll result 4 result)))))
244 '((inst ldq result offset object)))
246 '((inst lds result offset object)))
248 '((inst ldt result (+ offset word-bytes) object))))))
249 (define-vop (,set-name)
250 (:translate ,set-name)
252 (:args (object :scs (sap-reg) :target sap)
253 (offset :scs (signed-reg))
254 (value :scs (,sc) :target result))
255 (:arg-types system-area-pointer signed-num ,type)
256 (:results (result :scs (,sc)))
257 (:result-types ,type)
258 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
259 ,@(when (or (eq size :byte) (eq size :short))
260 `((:temporary (:sc non-descriptor-reg) temp)
261 (:temporary (:sc non-descriptor-reg) temp1)
262 (:temporary (:sc non-descriptor-reg) temp2)))
264 (inst addq object offset sap)
267 '((inst lda temp 0 sap)
268 (inst ldq_u temp1 0 sap)
269 (inst insbl value temp temp2)
270 (inst mskbl temp1 temp temp1)
271 (inst bis temp1 temp2 temp1)
272 (inst stq_u temp1 0 sap)
273 (inst move value result)))
275 '((inst lda temp 0 sap)
276 (inst ldq_u temp1 0 sap)
277 (inst mskwl temp1 temp temp1)
278 (inst inswl value temp temp2)
279 (inst bis temp1 temp2 temp)
280 (inst stq_u temp 0 sap)
281 (inst move value result)))
283 '((inst stl value 0 sap)
284 (move value result)))
286 '((inst stq value 0 sap)
287 (move value result)))
289 '((unless (location= result value)
290 (inst fmove value result))
291 (inst sts value 0 sap)))
293 '((unless (location= result value)
294 (inst fmove value result))
295 (inst stt value 0 sap))))))
296 (define-vop (,set-name-c)
297 (:translate ,set-name)
299 (:args (object :scs (sap-reg))
300 (value :scs (,sc) :target result))
301 (:arg-types system-area-pointer
302 (:constant ,(if (eq size :double)
303 ;; We need to be able to add 4.
304 `(integer ,(- (ash 1 16))
308 ,@(when (or (eq size :byte) (eq size :short))
309 `((:temporary (:sc non-descriptor-reg) temp)
310 (:temporary (:sc non-descriptor-reg) temp1)
311 (:temporary (:sc non-descriptor-reg) temp2)))
313 (:results (result :scs (,sc)))
314 (:result-types ,type)
318 '((inst lda temp offset object)
319 (inst ldq_u temp1 offset object)
320 (inst insbl value temp temp2)
321 (inst mskbl temp1 temp temp1)
322 (inst bis temp1 temp2 temp1)
323 (inst stq_u temp1 offset object)
324 (inst move value result)))
326 '((inst lda temp offset object)
327 (inst ldq_u temp1 offset object)
328 (inst mskwl temp1 temp temp1)
329 (inst inswl value temp temp2)
330 (inst bis temp1 temp2 temp)
331 (inst stq_u temp offset object)
332 (inst move value result)))
334 '((inst stl value offset object)
335 (move value result)))
337 '((inst stq value offset object)
338 (move value result)))
340 '((unless (location= result value)
341 (inst fmove value result))
342 (inst sts value offset object)))
344 '((unless (location= result value)
345 (inst fmove value result))
346 (inst stt value offset object))))))))))
347 (def-system-ref-and-set sap-ref-8 %set-sap-ref-8
348 unsigned-reg positive-fixnum :byte nil)
349 (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
350 signed-reg tagged-num :byte t)
351 (def-system-ref-and-set sap-ref-16 %set-sap-ref-16
352 unsigned-reg positive-fixnum :short nil)
353 (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
354 signed-reg tagged-num :short t)
355 (def-system-ref-and-set sap-ref-32 %set-sap-ref-32
356 unsigned-reg unsigned-num :long nil)
357 (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
358 signed-reg signed-num :long t)
359 (def-system-ref-and-set sap-ref-64 %set-sap-ref-64
360 unsigned-reg unsigned-num :quad nil)
361 (def-system-ref-and-set signed-sap-ref-64 %set-signed-sap-ref-64
362 signed-reg signed-num :quad t)
363 (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
364 sap-reg system-area-pointer :quad)
365 (def-system-ref-and-set sap-ref-single %set-sap-ref-single
366 single-reg single-float :single)
367 (def-system-ref-and-set sap-ref-double %set-sap-ref-double
368 double-reg double-float :double))
371 ;;; Noise to convert normal lisp data objects into SAPs.
373 (define-vop (vector-sap)
374 (:translate vector-sap)
376 (:args (vector :scs (descriptor-reg)))
377 (:results (sap :scs (sap-reg)))
378 (:result-types system-area-pointer)
381 (- (* vector-data-offset word-bytes) other-pointer-type)