4 ;;;; Moves and coercions:
6 ;;; Move a tagged SAP to an untagged representation.
8 (define-vop (move-to-sap)
9 (:args (x :scs (descriptor-reg)))
10 (:results (y :scs (sap-reg)))
11 (:note "system area pointer indirection")
13 (loadw y x sap-pointer-slot other-pointer-lowtag)))
16 (define-move-vop move-to-sap :move
17 (descriptor-reg) (sap-reg))
20 ;;; Move an untagged SAP to a tagged representation.
22 (define-vop (move-from-sap)
23 (:args (x :scs (sap-reg) :to (:eval 1)))
24 (:temporary (:scs (non-descriptor-reg)) ndescr)
25 (:results (y :scs (descriptor-reg) :from (:eval 0)))
26 (:note "system area pointer allocation")
28 (with-fixed-allocation (y ndescr sap-widetag sap-size)
29 (storew x y sap-pointer-slot other-pointer-lowtag))))
31 (define-move-vop move-from-sap :move
32 (sap-reg) (descriptor-reg))
35 ;;; Move untagged sap values.
37 (define-vop (sap-move)
40 :load-if (not (location= x y))))
41 (:results (y :scs (sap-reg)
42 :load-if (not (location= x y))))
48 (define-move-vop sap-move :move
52 ;;; Move untagged sap arguments/return-values.
54 (define-vop (move-sap-argument)
58 :load-if (not (sc-is y sap-reg))))
65 (storew x fp (tn-offset y))))))
67 (define-move-vop move-sap-argument :move-arg
68 (descriptor-reg sap-reg) (sap-reg))
71 ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
72 ;;; descriptor passing location.
74 (define-move-vop move-argument :move-arg
75 (sap-reg) (descriptor-reg))
79 ;;;; SAP-INT and INT-SAP
82 (:args (sap :scs (sap-reg) :target int))
83 (:arg-types system-area-pointer)
84 (:results (int :scs (unsigned-reg)))
85 (:result-types unsigned-num)
92 (:args (int :scs (unsigned-reg) :target sap))
93 (:arg-types unsigned-num)
94 (:results (sap :scs (sap-reg)))
95 (:result-types system-area-pointer)
103 ;;;; POINTER+ and POINTER-
105 (define-vop (pointer+)
107 (:args (ptr :scs (sap-reg) :target res)
108 (offset :scs (signed-reg)))
109 (:arg-types system-area-pointer signed-num)
110 (:results (res :scs (sap-reg)))
111 (:result-types system-area-pointer)
114 (inst add ptr offset res)))
116 (define-vop (pointer+-c)
118 (:args (ptr :scs (sap-reg)))
120 (:arg-types system-area-pointer (:constant (signed-byte 11)))
121 (:results (res :scs (sap-reg)))
122 (:result-types system-area-pointer)
125 (inst addi offset ptr res)))
127 (define-vop (pointer-)
129 (:args (ptr1 :scs (sap-reg))
130 (ptr2 :scs (sap-reg)))
131 (:arg-types system-area-pointer system-area-pointer)
133 (:results (res :scs (signed-reg)))
134 (:result-types signed-num)
136 (inst sub ptr1 ptr2 res)))
140 ;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
142 (macrolet ((def-system-ref-and-set
143 (ref-name set-name sc type size &optional signed)
144 (let ((ref-name-c (symbolicate ref-name "-C"))
145 (set-name-c (symbolicate set-name "-C")))
147 (define-vop (,ref-name)
148 (:translate ,ref-name)
150 (:args (object :scs (sap-reg))
151 (offset :scs (signed-reg)))
152 (:arg-types system-area-pointer signed-num)
153 (:results (result :scs (,sc)))
154 (:result-types ,type)
161 offset object result)
162 ,@(when (and signed (not (eq size :long)))
163 `((inst extrs result 31 ,(ecase size
167 (define-vop (,ref-name-c)
168 (:translate ,ref-name)
170 (:args (object :scs (sap-reg)))
171 (:arg-types system-area-pointer
172 (:constant ,(if (eq size :float)
176 (:results (result :scs (,sc)))
177 (:result-types ,type)
184 offset object result)
185 ,@(when (and signed (not (eq size :long)))
186 `((inst extrs result 31 ,(ecase size
190 (define-vop (,set-name)
191 (:translate ,set-name)
193 (:args (object :scs (sap-reg)
194 ,@(unless (eq size :float) '(:target sap)))
195 (offset :scs (signed-reg))
196 (value :scs (,sc) :target result))
197 (:arg-types system-area-pointer signed-num ,type)
198 (:results (result :scs (,sc)))
199 (:result-types ,type)
200 ,@(unless (eq size :float)
201 '((:temporary (:scs (sap-reg) :from (:argument 0)) sap)))
203 ,@(if (eq size :float)
204 `((inst fstx value offset object)
205 (unless (location= value result)
206 (inst funop :copy value result)))
207 `((inst add object offset sap)
208 (inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
210 (move value result)))))
211 (define-vop (,set-name-c)
212 (:translate ,set-name)
214 (:args (object :scs (sap-reg))
215 (value :scs (,sc) :target result))
216 (:arg-types system-area-pointer
217 (:constant ,(if (eq size :float)
222 (:results (result :scs (,sc)))
223 (:result-types ,type)
225 ,@(if (eq size :float)
226 `((inst fsts value offset object)
227 (unless (location= value result)
228 (inst funop :copy value result)))
229 `((inst ,(ecase size (:byte 'stb) (:short 'sth) (:long 'stw))
231 (move value result)))))))))
232 (def-system-ref-and-set sap-ref-8 %set-sap-ref-8
233 unsigned-reg positive-fixnum :byte nil)
234 (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
235 signed-reg tagged-num :byte t)
236 (def-system-ref-and-set sap-ref-16 %set-sap-ref-16
237 unsigned-reg positive-fixnum :short nil)
238 (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
239 signed-reg tagged-num :short t)
240 (def-system-ref-and-set sap-ref-32 %set-sap-ref-32
241 unsigned-reg unsigned-num :long nil)
242 (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
243 signed-reg signed-num :long t)
244 (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
245 sap-reg system-area-pointer :long)
246 (def-system-ref-and-set sap-ref-single %set-sap-ref-single
247 single-reg single-float :float)
248 (def-system-ref-and-set sap-ref-double %set-sap-ref-double
249 double-reg double-float :float))
252 ;;; Noise to convert normal lisp data objects into SAPs.
254 (define-vop (vector-sap)
255 (:translate vector-sap)
257 (:args (vector :scs (descriptor-reg)))
258 (:results (sap :scs (sap-reg)))
259 (:result-types system-area-pointer)
262 (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
267 ;;; Transforms for 64-bit SAP accessors.
269 ;;; FIXME: So these are now commented out on the SPARC, PPC and HPPA
270 ;;; backends. Did they ever serve a purpose? Could they in future? --
273 (deftransform sap-ref-64 ((sap offset) (* *))
274 '(logior (ash (sap-ref-32 sap offset) 32)
275 (sap-ref-32 sap (+ offset 4))))
277 (deftransform signed-sap-ref-64 ((sap offset) (* *))
278 '(logior (ash (signed-sap-ref-32 sap offset) 32)
279 (sap-ref-32 sap (+ 4 offset))))
281 (deftransform %set-sap-ref-64 ((sap offset value) (* * *))
283 (%set-sap-ref-32 sap offset (ash value -32))
284 (%set-sap-ref-32 sap (+ offset 4) (logand value #xffffffff))))
286 (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *))
288 (%set-signed-sap-ref-32 sap offset (ash value -32))
289 (%set-sap-ref-32 sap (+ 4 offset) (logand value #xffffffff))))