2 ;;; Written by William Lott.
7 ;;;; Moves and coercions:
9 ;;; Move a tagged SAP to an untagged representation.
11 (define-vop (move-to-sap)
12 (:args (x :scs (any-reg descriptor-reg)))
13 (:results (y :scs (sap-reg)))
14 (:note "pointer to SAP coercion")
16 (loadw y x sap-pointer-slot other-pointer-lowtag)))
19 (define-move-vop move-to-sap :move
20 (descriptor-reg) (sap-reg))
23 ;;; Move an untagged SAP to a tagged representation.
25 (define-vop (move-from-sap)
26 (:args (sap :scs (sap-reg) :to :save))
27 (:temporary (:scs (non-descriptor-reg)) ndescr)
28 (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
29 (:results (res :scs (descriptor-reg)))
30 (:note "SAP to pointer coercion")
32 (with-fixed-allocation (res pa-flag ndescr sap-widetag sap-size)
33 (storew sap res sap-pointer-slot other-pointer-lowtag))))
35 (define-move-vop move-from-sap :move
36 (sap-reg) (descriptor-reg))
39 ;;; 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))))
53 (define-move-vop sap-move :move
57 ;;; Move untagged sap arguments/return-values.
59 (define-vop (move-sap-arg)
63 :load-if (not (sc-is y sap-reg))))
65 (:note "SAP argument move")
71 (storew x fp (tn-offset y))))))
73 (define-move-vop move-sap-arg :move-arg
74 (descriptor-reg sap-reg) (sap-reg))
77 ;;; Use standard MOVE-ARG + coercion to move an untagged sap to a
78 ;;; descriptor passing location.
80 (define-move-vop move-arg :move-arg
81 (sap-reg) (descriptor-reg))
85 ;;;; SAP-INT and INT-SAP
88 (:args (sap :scs (sap-reg) :target int))
89 (:arg-types system-area-pointer)
90 (:results (int :scs (unsigned-reg)))
91 (:result-types unsigned-num)
98 (:args (int :scs (unsigned-reg) :target sap))
99 (:arg-types unsigned-num)
100 (:results (sap :scs (sap-reg)))
101 (:result-types system-area-pointer)
109 ;;;; POINTER+ and POINTER-
111 (define-vop (pointer+)
113 (:args (ptr :scs (sap-reg))
114 (offset :scs (signed-reg)))
115 (:arg-types system-area-pointer signed-num)
116 (:results (res :scs (sap-reg)))
117 (:result-types system-area-pointer)
120 (inst add res ptr offset)))
122 (define-vop (pointer+-c)
124 (:args (ptr :scs (sap-reg)))
126 (:arg-types system-area-pointer (:constant (signed-byte 16)))
127 (:results (res :scs (sap-reg)))
128 (:result-types system-area-pointer)
131 (inst addi res ptr offset)))
133 (define-vop (pointer-)
135 (:args (ptr1 :scs (sap-reg))
136 (ptr2 :scs (sap-reg)))
137 (:arg-types system-area-pointer system-area-pointer)
139 (:results (res :scs (signed-reg)))
140 (:result-types signed-num)
142 (inst sub res ptr1 ptr2)))
146 ;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
148 (macrolet ((def-system-ref-and-set
149 (ref-name set-name sc type size &optional signed)
150 (let ((ref-name-c (symbolicate ref-name "-C"))
151 (set-name-c (symbolicate set-name "-C")))
153 (define-vop (,ref-name)
154 (:translate ,ref-name)
156 (:args (sap :scs (sap-reg))
157 (offset :scs (signed-reg)))
158 (:arg-types system-area-pointer signed-num)
159 (:results (result :scs (,sc)))
160 (:result-types ,type)
164 (:short (if signed 'lhax 'lhzx))
169 ,@(when (and (eq size :byte) signed)
170 '((inst extsb result result)))))
171 (define-vop (,ref-name-c)
172 (:translate ,ref-name)
174 (:args (sap :scs (sap-reg)))
175 (:arg-types system-area-pointer (:constant (signed-byte 16)))
177 (:results (result :scs (,sc)))
178 (:result-types ,type)
182 (:short (if signed 'lha 'lhz))
187 ,@(when (and (eq size :byte) signed)
188 '((inst extsb result result)))))
189 (define-vop (,set-name)
190 (:translate ,set-name)
192 (:args (sap :scs (sap-reg))
193 (offset :scs (signed-reg))
194 (value :scs (,sc) :target result))
195 (:arg-types system-area-pointer signed-num ,type)
196 (:results (result :scs (,sc)))
197 (:result-types ,type)
206 (unless (location= result value)
209 '((inst frsp result value)))
211 '((inst fmr result value)))
213 '((inst mr result value)))))))
214 (define-vop (,set-name-c)
215 (:translate ,set-name)
217 (:args (sap :scs (sap-reg))
218 (value :scs (,sc) :target result))
219 (:arg-types system-area-pointer (:constant (signed-byte 16)) ,type)
221 (:results (result :scs (,sc)))
222 (:result-types ,type)
231 (unless (location= result value)
234 '((inst frsp result value)))
236 '((inst fmr result value)))
238 '((inst mr result value)))))))))))
239 (def-system-ref-and-set sap-ref-8 %set-sap-ref-8
240 unsigned-reg positive-fixnum :byte nil)
241 (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
242 signed-reg tagged-num :byte t)
243 (def-system-ref-and-set sap-ref-16 %set-sap-ref-16
244 unsigned-reg positive-fixnum :short nil)
245 (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
246 signed-reg tagged-num :short t)
247 (def-system-ref-and-set sap-ref-32 %set-sap-ref-32
248 unsigned-reg unsigned-num :long nil)
249 (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
250 signed-reg signed-num :long t)
251 (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
252 sap-reg system-area-pointer :long)
253 (def-system-ref-and-set sap-ref-single %set-sap-ref-single
254 single-reg single-float :single)
255 (def-system-ref-and-set sap-ref-double %set-sap-ref-double
256 double-reg double-float :double))
260 ;;; Noise to convert normal lisp data objects into SAPs.
262 (define-vop (vector-sap)
263 (:translate vector-sap)
265 (:args (vector :scs (descriptor-reg)))
266 (:results (sap :scs (sap-reg)))
267 (:result-types system-area-pointer)
269 (inst addi sap vector
270 (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
273 ;;; Transforms for 64-bit SAP accessors.
275 (deftransform sap-ref-64 ((sap offset) (* *))
276 '(logior (ash (sap-ref-32 sap offset) 32)
277 (sap-ref-32 sap (+ offset 4))))
279 (deftransform signed-sap-ref-64 ((sap offset) (* *))
280 '(logior (ash (signed-sap-ref-32 sap offset) 32)
281 (sap-ref-32 sap (+ 4 offset))))
283 (deftransform %set-sap-ref-64 ((sap offset value) (* * *))
285 (%set-sap-ref-32 sap offset (ash value -32))
286 (%set-sap-ref-32 sap (+ offset 4) (logand value #xffffffff))))
288 (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *))
290 (%set-signed-sap-ref-32 sap offset (ash value -32))
291 (%set-sap-ref-32 sap (+ 4 offset) (logand value #xffffffff))))