1 ;;;; the MIPS 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 (loadw y x sap-pointer-slot other-pointer-lowtag)))
24 (define-move-vop move-to-sap :move
25 (descriptor-reg) (sap-reg))
27 ;;; Move an untagged SAP to a tagged representation.
28 (define-vop (move-from-sap)
29 (:args (x :scs (sap-reg) :target sap))
30 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
31 (:temporary (:scs (non-descriptor-reg)) ndescr)
32 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
33 (:results (y :scs (descriptor-reg)))
34 (:note "system area pointer allocation")
37 (with-fixed-allocation (y pa-flag ndescr sap-widetag sap-size)
38 (storew sap y sap-pointer-slot other-pointer-lowtag))))
40 (define-move-vop move-from-sap :move
41 (sap-reg) (descriptor-reg))
43 ;;; Move untagged sap values.
44 (define-vop (sap-move)
47 :load-if (not (location= x y))))
48 (:results (y :scs (sap-reg)
49 :load-if (not (location= x y))))
55 (define-move-vop sap-move :move
58 ;;; Move untagged sap arguments/return-values.
59 (define-vop (move-sap-arg)
63 :load-if (not (sc-is y sap-reg))))
70 (storew x fp (tn-offset y))))))
72 (define-move-vop move-sap-arg :move-arg
73 (descriptor-reg sap-reg) (sap-reg))
75 ;;; Use standard MOVE-ARG + coercion to move an untagged sap to a
76 ;;; descriptor passing location.
77 (define-move-vop move-arg :move-arg
78 (sap-reg) (descriptor-reg))
80 ;;;; 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)
101 ;;;; POINTER+ and POINTER-
102 (define-vop (pointer+)
104 (:args (ptr :scs (sap-reg))
105 (offset :scs (signed-reg immediate)))
106 (:arg-types system-area-pointer signed-num)
107 (:results (res :scs (sap-reg)))
108 (:result-types system-area-pointer)
113 (inst addu res ptr offset))
115 (inst addu res ptr (tn-value offset))))))
117 (define-vop (pointer-)
119 (:args (ptr1 :scs (sap-reg))
120 (ptr2 :scs (sap-reg)))
121 (:arg-types system-area-pointer system-area-pointer)
123 (:results (res :scs (signed-reg)))
124 (:result-types signed-num)
126 (inst subu res ptr1 ptr2)))
128 ;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
129 (macrolet ((def-system-ref-and-set
130 (ref-name set-name sc type size &optional signed)
131 (let ((ref-name-c (symbolicate ref-name "-C"))
132 (set-name-c (symbolicate set-name "-C")))
134 (define-vop (,ref-name)
135 (:translate ,ref-name)
137 (:args (object :scs (sap-reg) :target sap)
138 (offset :scs (signed-reg)))
139 (:arg-types system-area-pointer signed-num)
140 (:results (result :scs (,sc)))
141 (:result-types ,type)
142 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
144 (inst addu sap object offset)
148 '((inst lb result sap 0))
149 '((inst lbu result sap 0))))
152 '((inst lh result sap 0))
153 '((inst lhu result sap 0))))
155 '((inst lw result sap 0)))
157 '((inst lwc1 result sap 0)))
159 (ecase *backend-byte-order*
161 '((inst lwc1 result sap n-word-bytes)
162 (inst lwc1-odd result sap 0)))
164 '((inst lwc1 result sap 0)
165 (inst lwc1-odd result sap n-word-bytes))))))
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 :double)
173 ;; We need to be able to add 4.
174 `(integer ,(- (ash 1 16))
178 (:results (result :scs (,sc)))
179 (:result-types ,type)
184 '((inst lb result object offset))
185 '((inst lbu result object offset))))
188 '((inst lh result object offset))
189 '((inst lhu result object offset))))
191 '((inst lw result object offset)))
193 '((inst lwc1 result object offset)))
195 (ecase *backend-byte-order*
197 '((inst lwc1 result object (+ offset n-word-bytes))
198 (inst lwc1-odd result object offset)))
200 '((inst lwc1 result object offset)
201 (inst lwc1-odd result object (+ offset n-word-bytes)))))))
203 (define-vop (,set-name)
204 (:translate ,set-name)
206 (:args (object :scs (sap-reg) :target sap)
207 (offset :scs (signed-reg))
208 (value :scs (,sc) :target result))
209 (:arg-types system-area-pointer signed-num ,type)
210 (:results (result :scs (,sc)))
211 (:result-types ,type)
212 (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
214 (inst addu sap object offset)
217 '((inst sb value sap 0)
218 (move result value)))
220 '((inst sh value sap 0)
221 (move result value)))
223 '((inst sw value sap 0)
224 (move result value)))
226 '((inst swc1 value sap 0)
227 (unless (location= result value)
228 (inst fmove :single result value))))
230 (ecase *backend-byte-order*
232 '((inst swc1 value sap n-word-bytes)
233 (inst swc1-odd value sap 0)
234 (unless (location= result value)
235 (inst fmove :double result value))))
237 '((inst swc1 value sap 0)
238 (inst swc1-odd value sap n-word-bytes)
239 (unless (location= result value)
240 (inst fmove :double result value)))))))))
241 (define-vop (,set-name-c)
242 (:translate ,set-name)
244 (:args (object :scs (sap-reg))
245 (value :scs (,sc) :target result))
246 (:arg-types system-area-pointer
247 (:constant ,(if (eq size :double)
248 ;; We need to be able to add 4.
249 `(integer ,(- (ash 1 16))
254 (:results (result :scs (,sc)))
255 (:result-types ,type)
259 '((inst sb value object offset)
260 (move result value)))
262 '((inst sh value object offset)
263 (move result value)))
265 '((inst sw value object offset)
266 (move result value)))
268 '((inst swc1 value object offset)
269 (unless (location= result value)
270 (inst fmove :single result value))))
272 (ecase *backend-byte-order*
274 '((inst swc1 value object (+ offset n-word-bytes))
275 (inst swc1-odd value object (+ offset n-word-bytes))
276 (unless (location= result value)
277 (inst fmove :double result value))))
279 '((inst swc1 value object offset)
280 (inst swc1-odd value object (+ offset n-word-bytes))
281 (unless (location= result value)
282 (inst fmove :double result value)))))))))))))
283 (def-system-ref-and-set sap-ref-8 %set-sap-ref-8
284 unsigned-reg positive-fixnum :byte nil)
285 (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
286 signed-reg tagged-num :byte t)
287 (def-system-ref-and-set sap-ref-16 %set-sap-ref-16
288 unsigned-reg positive-fixnum :short nil)
289 (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
290 signed-reg tagged-num :short t)
291 (def-system-ref-and-set sap-ref-32 %set-sap-ref-32
292 unsigned-reg unsigned-num :long nil)
293 (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
294 signed-reg signed-num :long t)
295 (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
296 sap-reg system-area-pointer :long)
297 (def-system-ref-and-set sap-ref-single %set-sap-ref-single
298 single-reg single-float :single)
299 (def-system-ref-and-set sap-ref-double %set-sap-ref-double
300 double-reg double-float :double))
302 ;;; Noise to convert normal lisp data objects into SAPs.
303 (define-vop (vector-sap)
304 (:translate vector-sap)
306 (:args (vector :scs (descriptor-reg)))
307 (:results (sap :scs (sap-reg)))
308 (:result-types system-area-pointer)
310 (inst addu sap vector
311 (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))
313 ;;; Transforms for 64-bit SAP accessors.
316 (deftransform sap-ref-64 ((sap offset) (* *))
317 '(logior (sap-ref-32 sap offset)
318 (ash (sap-ref-32 sap (+ offset 4)) 32)))
319 (deftransform signed-sap-ref-64 ((sap offset) (* *))
320 '(logior (sap-ref-32 sap offset)
321 (ash (signed-sap-ref-32 sap (+ offset 4)) 32)))
322 (deftransform %set-sap-ref-64 ((sap offset value) (* * *))
324 (%set-sap-ref-32 sap offset (logand value #xffffffff))
325 (%set-sap-ref-32 sap (+ offset 4) (ash value -32))))
326 (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *))
328 (%set-sap-ref-32 sap offset (logand value #xffffffff))
329 (%set-signed-sap-ref-32 sap (+ offset 4) (ash value -32)))))
332 (deftransform sap-ref-64 ((sap offset) (* *))
333 '(logior (ash (sap-ref-32 sap offset) 32)
334 (sap-ref-32 sap (+ offset 4))))
335 (deftransform signed-sap-ref-64 ((sap offset) (* *))
336 '(logior (ash (signed-sap-ref-32 sap offset) 32)
337 (sap-ref-32 sap (+ 4 offset))))
338 (deftransform %set-sap-ref-64 ((sap offset value) (* * *))
340 (%set-sap-ref-32 sap offset (ash value -32))
341 (%set-sap-ref-32 sap (+ offset 4) (logand value #xffffffff))))
342 (deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *))
344 (%set-signed-sap-ref-32 sap offset (ash value -32))
345 (%set-sap-ref-32 sap (+ 4 offset) (logand value #xffffffff)))))