1 ;;;; the Sparc definitions for array 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 ;;;; allocator for the array header.
16 (define-vop (make-array-header)
17 (:translate make-array-header
)
19 (:args
(type :scs
(any-reg))
20 (rank :scs
(any-reg)))
21 (:arg-types tagged-num tagged-num
)
22 (:temporary
(:scs
(descriptor-reg) :to
(:result
0) :target result
) header
)
23 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
24 (:results
(result :scs
(descriptor-reg)))
27 (inst or header alloc-tn other-pointer-lowtag
)
28 (inst add ndescr rank
(* (1+ array-dimensions-offset
) n-word-bytes
))
30 (inst add alloc-tn ndescr
)
31 (inst add ndescr rank
(fixnumize (1- array-dimensions-offset
)))
32 (inst sll ndescr ndescr n-widetag-bits
)
33 (inst or ndescr ndescr type
)
34 ;; Remove the extraneous fixnum tag bits because TYPE and RANK
36 (inst srl ndescr ndescr n-fixnum-tag-bits
)
37 (storew ndescr header
0 other-pointer-lowtag
))
38 (move result header
)))
41 ;;;; Additional accessors and setters for the array header.
43 (defknown sb
!impl
::%array-dimension
(t fixnum
) fixnum
45 (defknown sb
!impl
::%set-array-dimension
(t fixnum fixnum
) fixnum
48 (define-vop (%array-dimension word-index-ref
)
49 (:translate sb
!impl
::%array-dimension
)
51 (:variant array-dimensions-offset other-pointer-lowtag
))
53 (define-vop (%set-array-dimension word-index-set
)
54 (:translate sb
!impl
::%set-array-dimension
)
56 (:variant array-dimensions-offset other-pointer-lowtag
))
60 (defknown sb
!impl
::%array-rank
(t) fixnum
(flushable))
62 (define-vop (array-rank-vop)
63 (:translate sb
!impl
::%array-rank
)
65 (:args
(x :scs
(descriptor-reg)))
66 (:temporary
(:scs
(non-descriptor-reg)) temp
)
67 (:results
(res :scs
(any-reg descriptor-reg
)))
69 (loadw temp x
0 other-pointer-lowtag
)
70 (inst sra temp n-widetag-bits
)
71 (inst sub temp
(1- array-dimensions-offset
))
72 (inst sll res temp n-fixnum-tag-bits
)))
76 ;;;; Bounds checking routine.
79 (define-vop (check-bound)
80 (:translate %check-bound
)
82 (:args
(array :scs
(descriptor-reg))
83 (bound :scs
(any-reg descriptor-reg
))
84 (index :scs
(any-reg descriptor-reg
) :target result
))
85 (:results
(result :scs
(any-reg descriptor-reg
)))
87 (:save-p
:compute-only
)
89 (let ((error (generate-error-code vop invalid-array-index-error
91 (inst cmp index bound
)
94 (move result index
))))
98 ;;;; Accessors/Setters
100 ;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
101 ;;; elements are represented in integer registers and are built out of
102 ;;; 8, 16, or 32 bit elements.
104 (macrolet ((def-data-vector-frobs (type variant element-type
&rest scs
)
106 (define-vop (,(symbolicate "DATA-VECTOR-REF/" (string type
))
107 ,(symbolicate (string variant
) "-REF"))
108 (:note
"inline array access")
109 (:variant vector-data-offset other-pointer-lowtag
)
110 (:translate data-vector-ref
)
111 (:arg-types
,type positive-fixnum
)
112 (:results
(value :scs
,scs
))
113 (:result-types
,element-type
))
114 (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type
))
115 ,(symbolicate (string variant
) "-SET"))
116 (:note
"inline array store")
117 (:variant vector-data-offset other-pointer-lowtag
)
118 (:translate data-vector-set
)
119 (:arg-types
,type positive-fixnum
,element-type
)
120 (:args
(object :scs
(descriptor-reg))
121 (index :scs
(any-reg zero immediate
))
123 (:results
(result :scs
,scs
))
124 (:result-types
,element-type
)))))
126 (def-data-vector-frobs simple-base-string byte-index
127 base-char base-char-reg
)
128 (def-data-vector-frobs simple-vector word-index
129 * descriptor-reg any-reg
)
131 (def-data-vector-frobs simple-array-unsigned-byte-7 byte-index
132 positive-fixnum unsigned-reg
)
133 (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
134 positive-fixnum unsigned-reg
)
135 (def-data-vector-frobs simple-array-unsigned-byte-15 halfword-index
136 positive-fixnum unsigned-reg
)
137 (def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
138 positive-fixnum unsigned-reg
)
139 (def-data-vector-frobs simple-array-unsigned-byte-31 word-index
140 unsigned-num unsigned-reg
)
141 (def-data-vector-frobs simple-array-unsigned-byte-32 word-index
142 unsigned-num unsigned-reg
)
144 (def-data-vector-frobs simple-array-unsigned-byte-29 word-index
145 positive-fixnum any-reg
)
146 (def-data-vector-frobs simple-array-signed-byte-30 word-index
148 (def-data-vector-frobs simple-array-signed-byte-32 word-index
149 signed-num signed-reg
))
151 ;;; Integer vectors whose elements are smaller than a byte. I.e. bit, 2-bit,
152 ;;; and 4-bit vectors.
153 (macrolet ((def-small-data-vector-frobs (type bits
)
154 (let* ((elements-per-word (floor n-word-bits bits
))
155 (bit-shift (1- (integer-length elements-per-word
))))
157 (define-vop (,(symbolicate "DATA-VECTOR-REF/" type
))
158 (:note
"inline array access")
159 (:translate data-vector-ref
)
161 (:args
(object :scs
(descriptor-reg))
162 (index :scs
(unsigned-reg)))
163 (:arg-types
,type positive-fixnum
)
164 (:results
(value :scs
(any-reg)))
165 (:result-types positive-fixnum
)
166 (:temporary
(:scs
(non-descriptor-reg) :to
(:result
0)) temp result
)
168 (inst srl temp index
,bit-shift
)
169 (inst sll temp n-fixnum-tag-bits
)
170 (inst add temp
(- (* vector-data-offset n-word-bytes
)
171 other-pointer-lowtag
))
172 (inst ld result object temp
)
173 (inst and temp index
,(1- elements-per-word
))
174 (inst xor temp
,(1- elements-per-word
))
176 `((inst sll temp
,(1- (integer-length bits
)))))
177 (inst srl result temp
)
178 (inst and result
,(1- (ash 1 bits
)))
179 (inst sll value result
2)))
180 (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" type
))
181 (:translate data-vector-ref
)
183 (:args
(object :scs
(descriptor-reg)))
184 (:arg-types
,type
(:constant index
))
186 (:results
(result :scs
(unsigned-reg)))
187 (:result-types positive-fixnum
)
188 (:temporary
(:scs
(non-descriptor-reg)) temp
)
190 (multiple-value-bind (word extra
)
191 (floor index
,elements-per-word
)
192 (setf extra
(logxor extra
(1- ,elements-per-word
)))
193 (let ((offset (- (* (+ word vector-data-offset
) n-word-bytes
)
194 other-pointer-lowtag
)))
195 (cond ((typep offset
'(signed-byte 13))
196 (inst ld result object offset
))
198 (inst li temp offset
)
199 (inst ld result object temp
))))
200 (unless (zerop extra
)
201 (inst srl result
(* extra
,bits
)))
202 (unless (= extra
,(1- elements-per-word
))
203 (inst and result
,(1- (ash 1 bits
)))))))
204 (define-vop (,(symbolicate "DATA-VECTOR-SET/" type
))
205 (:note
"inline array store")
206 (:translate data-vector-set
)
208 (:args
(object :scs
(descriptor-reg))
209 (index :scs
(unsigned-reg) :target shift
)
210 (value :scs
(unsigned-reg zero immediate
) :target result
))
211 (:arg-types
,type positive-fixnum positive-fixnum
)
212 (:results
(result :scs
(unsigned-reg)))
213 (:result-types positive-fixnum
)
214 (:temporary
(:scs
(non-descriptor-reg)) temp old offset
)
215 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) shift
)
217 (inst srl offset index
,bit-shift
)
218 (inst sll offset n-fixnum-tag-bits
)
219 (inst add offset
(- (* vector-data-offset n-word-bytes
)
220 other-pointer-lowtag
))
221 (inst ld old object offset
)
222 (inst and shift index
,(1- elements-per-word
))
223 (inst xor shift
,(1- elements-per-word
))
225 `((inst sll shift
,(1- (integer-length bits
)))))
226 (unless (and (sc-is value immediate
)
227 (= (tn-value value
) ,(1- (ash 1 bits
))))
228 (inst li temp
,(1- (ash 1 bits
)))
229 (inst sll temp shift
)
232 (unless (sc-is value zero
)
235 (inst li temp
(logand (tn-value value
) ,(1- (ash 1 bits
)))))
237 (inst and temp value
,(1- (ash 1 bits
)))))
238 (inst sll temp shift
)
240 (inst st old object offset
)
243 (inst li result
(tn-value value
)))
245 (move result value
)))))
246 (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" type
))
247 (:translate data-vector-set
)
249 (:args
(object :scs
(descriptor-reg))
250 (value :scs
(unsigned-reg zero immediate
) :target result
))
255 (:results
(result :scs
(unsigned-reg)))
256 (:result-types positive-fixnum
)
257 (:temporary
(:scs
(non-descriptor-reg)) offset-reg temp old
)
259 (multiple-value-bind (word extra
) (floor index
,elements-per-word
)
260 (let ((offset (- (* (+ word vector-data-offset
) n-word-bytes
)
261 other-pointer-lowtag
)))
262 (cond ((typep offset
'(signed-byte 13))
263 (inst ld old object offset
))
265 (inst li offset-reg offset
)
266 (inst ld old object offset-reg
)))
267 (unless (and (sc-is value immediate
)
268 (= (tn-value value
) ,(1- (ash 1 bits
))))
271 (inst srl old
,bits
))
274 (lognot (ash ,(1- (ash 1 bits
))
276 ,(1- elements-per-word
))
278 (inst and old temp
))))
282 (let ((value (ash (logand (tn-value value
)
285 ,(1- elements-per-word
))
287 (cond ((typep value
'(signed-byte 13))
291 (inst or old temp
)))))
294 (* (logxor extra
,(1- elements-per-word
)) ,bits
))
296 (if (typep offset
'(signed-byte 13))
297 (inst st old object offset
)
298 (inst st old object offset-reg
)))
301 (inst li result
(tn-value value
)))
303 (move result value
))))))))))
305 (def-small-data-vector-frobs simple-bit-vector
1)
306 (def-small-data-vector-frobs simple-array-unsigned-byte-2
2)
307 (def-small-data-vector-frobs simple-array-unsigned-byte-4
4))
309 ;;; And the float variants.
310 (define-vop (data-vector-ref/simple-array-single-float
)
311 (:note
"inline array access")
312 (:translate data-vector-ref
)
314 (:args
(object :scs
(descriptor-reg))
315 (index :scs
(any-reg)))
316 (:arg-types simple-array-single-float positive-fixnum
)
317 (:results
(value :scs
(single-reg)))
318 (:temporary
(:scs
(non-descriptor-reg)) offset
)
319 (:result-types single-float
)
321 (inst add offset index
(- (* vector-data-offset n-word-bytes
)
322 other-pointer-lowtag
))
323 (inst ldf value object offset
)))
326 (define-vop (data-vector-set/simple-array-single-float
)
327 (:note
"inline array store")
328 (:translate data-vector-set
)
330 (:args
(object :scs
(descriptor-reg))
331 (index :scs
(any-reg))
332 (value :scs
(single-reg) :target result
))
333 (:arg-types simple-array-single-float positive-fixnum single-float
)
334 (:results
(result :scs
(single-reg)))
335 (:result-types single-float
)
336 (:temporary
(:scs
(non-descriptor-reg)) offset
)
338 (inst add offset index
339 (- (* vector-data-offset n-word-bytes
)
340 other-pointer-lowtag
))
341 (inst stf value object offset
)
342 (unless (location= result value
)
343 (inst fmovs result value
))))
345 (define-vop (data-vector-ref/simple-array-double-float
)
346 (:note
"inline array access")
347 (:translate data-vector-ref
)
349 (:args
(object :scs
(descriptor-reg))
350 (index :scs
(any-reg)))
351 (:arg-types simple-array-double-float positive-fixnum
)
352 (:results
(value :scs
(double-reg)))
353 (:result-types double-float
)
354 (:temporary
(:scs
(non-descriptor-reg)) offset
)
356 (inst sll offset index
1)
357 (inst add offset
(- (* vector-data-offset n-word-bytes
)
358 other-pointer-lowtag
))
359 (inst lddf value object offset
)))
361 (define-vop (data-vector-set/simple-array-double-float
)
362 (:note
"inline array store")
363 (:translate data-vector-set
)
365 (:args
(object :scs
(descriptor-reg))
366 (index :scs
(any-reg))
367 (value :scs
(double-reg) :target result
))
368 (:arg-types simple-array-double-float positive-fixnum double-float
)
369 (:results
(result :scs
(double-reg)))
370 (:result-types double-float
)
371 (:temporary
(:scs
(non-descriptor-reg)) offset
)
373 (inst sll offset index
1)
374 (inst add offset
(- (* vector-data-offset n-word-bytes
)
375 other-pointer-lowtag
))
376 (inst stdf value object offset
)
377 (unless (location= result value
)
378 (move-double-reg result value
))))
381 (define-vop (data-vector-ref/simple-array-long-float
)
382 (:note
"inline array access")
383 (:translate data-vector-ref
)
385 (:args
(object :scs
(descriptor-reg))
386 (index :scs
(any-reg)))
387 (:arg-types simple-array-long-float positive-fixnum
)
388 (:results
(value :scs
(long-reg)))
389 (:result-types long-float
)
390 (:temporary
(:scs
(non-descriptor-reg)) offset
)
392 (inst sll offset index
2)
393 (inst add offset
(- (* vector-data-offset n-word-bytes
)
394 other-pointer-lowtag
))
395 (load-long-reg value object offset nil
)))
398 (define-vop (data-vector-set/simple-array-long-float
)
399 (:note
"inline array store")
400 (:translate data-vector-set
)
402 (:args
(object :scs
(descriptor-reg))
403 (index :scs
(any-reg))
404 (value :scs
(long-reg) :target result
))
405 (:arg-types simple-array-long-float positive-fixnum long-float
)
406 (:results
(result :scs
(long-reg)))
407 (:result-types long-float
)
408 (:temporary
(:scs
(non-descriptor-reg)) offset
)
410 (inst sll offset index
2)
411 (inst add offset
(- (* vector-data-offset n-word-bytes
)
412 other-pointer-lowtag
))
413 (store-long-reg value object offset nil
)
414 (unless (location= result value
)
415 (move-long-reg result value
))))
418 ;;;; Misc. Array VOPs.
422 (define-vop (vector-word-length)
423 (:args
(vec :scs
(descriptor-reg)))
424 (:results
(res :scs
(any-reg descriptor-reg
)))
426 (loadw res vec clc
::g-vector-header-words
)
427 (inst niuo res res clc
::g-vector-words-mask-16
)))
429 (define-vop (get-vector-subtype get-header-data
))
430 (define-vop (set-vector-subtype set-header-data
))
433 ;;; XXX FIXME: Don't we have these above, in DEF-DATA-VECTOR-FROBS?
434 (define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref
)
435 (:note
"inline array access")
436 (:variant vector-data-offset other-pointer-lowtag
)
437 (:translate data-vector-ref
)
438 (:arg-types simple-array-signed-byte-8 positive-fixnum
)
439 (:results
(value :scs
(signed-reg)))
440 (:result-types tagged-num
))
442 (define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set
)
443 (:note
"inline array store")
444 (:variant vector-data-offset other-pointer-lowtag
)
445 (:translate data-vector-set
)
446 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num
)
447 (:args
(object :scs
(descriptor-reg))
448 (index :scs
(any-reg zero immediate
))
449 (value :scs
(signed-reg)))
450 (:results
(result :scs
(signed-reg)))
451 (:result-types tagged-num
))
454 (define-vop (data-vector-ref/simple-array-signed-byte-16
455 signed-halfword-index-ref
)
456 (:note
"inline array access")
457 (:variant vector-data-offset other-pointer-lowtag
)
458 (:translate data-vector-ref
)
459 (:arg-types simple-array-signed-byte-16 positive-fixnum
)
460 (:results
(value :scs
(signed-reg)))
461 (:result-types tagged-num
))
463 (define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set
)
464 (:note
"inline array store")
465 (:variant vector-data-offset other-pointer-lowtag
)
466 (:translate data-vector-set
)
467 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num
)
468 (:args
(object :scs
(descriptor-reg))
469 (index :scs
(any-reg zero immediate
))
470 (value :scs
(signed-reg)))
471 (:results
(result :scs
(signed-reg)))
472 (:result-types tagged-num
))
475 ;;; Complex float arrays.
477 (define-vop (data-vector-ref/simple-array-complex-single-float
)
478 (:note
"inline array access")
479 (:translate data-vector-ref
)
481 (:args
(object :scs
(descriptor-reg) :to
:result
)
482 (index :scs
(any-reg)))
483 (:arg-types simple-array-complex-single-float positive-fixnum
)
484 (:results
(value :scs
(complex-single-reg)))
485 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) offset
)
486 (:result-types complex-single-float
)
488 (let ((real-tn (complex-single-reg-real-tn value
)))
489 (inst sll offset index
1)
490 (inst add offset
(- (* vector-data-offset n-word-bytes
)
491 other-pointer-lowtag
))
492 (inst ldf real-tn object offset
))
493 (let ((imag-tn (complex-single-reg-imag-tn value
)))
494 (inst add offset n-word-bytes
)
495 (inst ldf imag-tn object offset
))))
497 (define-vop (data-vector-set/simple-array-complex-single-float
)
498 (:note
"inline array store")
499 (:translate data-vector-set
)
501 (:args
(object :scs
(descriptor-reg) :to
:result
)
502 (index :scs
(any-reg))
503 (value :scs
(complex-single-reg) :target result
))
504 (:arg-types simple-array-complex-single-float positive-fixnum
505 complex-single-float
)
506 (:results
(result :scs
(complex-single-reg)))
507 (:result-types complex-single-float
)
508 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) offset
)
510 (let ((value-real (complex-single-reg-real-tn value
))
511 (result-real (complex-single-reg-real-tn result
)))
512 (inst sll offset index
1)
513 (inst add offset
(- (* vector-data-offset n-word-bytes
)
514 other-pointer-lowtag
))
515 (inst stf value-real object offset
)
516 (unless (location= result-real value-real
)
517 (inst fmovs result-real value-real
)))
518 (let ((value-imag (complex-single-reg-imag-tn value
))
519 (result-imag (complex-single-reg-imag-tn result
)))
520 (inst add offset n-word-bytes
)
521 (inst stf value-imag object offset
)
522 (unless (location= result-imag value-imag
)
523 (inst fmovs result-imag value-imag
)))))
525 (define-vop (data-vector-ref/simple-array-complex-double-float
)
526 (:note
"inline array access")
527 (:translate data-vector-ref
)
529 (:args
(object :scs
(descriptor-reg) :to
:result
)
530 (index :scs
(any-reg)))
531 (:arg-types simple-array-complex-double-float positive-fixnum
)
532 (:results
(value :scs
(complex-double-reg)))
533 (:result-types complex-double-float
)
534 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) offset
)
536 (let ((real-tn (complex-double-reg-real-tn value
)))
537 (inst sll offset index
2)
538 (inst add offset
(- (* vector-data-offset n-word-bytes
)
539 other-pointer-lowtag
))
540 (inst lddf real-tn object offset
))
541 (let ((imag-tn (complex-double-reg-imag-tn value
)))
542 (inst add offset
(* 2 n-word-bytes
))
543 (inst lddf imag-tn object offset
))))
545 (define-vop (data-vector-set/simple-array-complex-double-float
)
546 (:note
"inline array store")
547 (:translate data-vector-set
)
549 (:args
(object :scs
(descriptor-reg) :to
:result
)
550 (index :scs
(any-reg))
551 (value :scs
(complex-double-reg) :target result
))
552 (:arg-types simple-array-complex-double-float positive-fixnum
553 complex-double-float
)
554 (:results
(result :scs
(complex-double-reg)))
555 (:result-types complex-double-float
)
556 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) offset
)
558 (let ((value-real (complex-double-reg-real-tn value
))
559 (result-real (complex-double-reg-real-tn result
)))
560 (inst sll offset index
2)
561 (inst add offset
(- (* vector-data-offset n-word-bytes
)
562 other-pointer-lowtag
))
563 (inst stdf value-real object offset
)
564 (unless (location= result-real value-real
)
565 (move-double-reg result-real value-real
)))
566 (let ((value-imag (complex-double-reg-imag-tn value
))
567 (result-imag (complex-double-reg-imag-tn result
)))
568 (inst add offset
(* 2 n-word-bytes
))
569 (inst stdf value-imag object offset
)
570 (unless (location= result-imag value-imag
)
571 (move-double-reg result-imag value-imag
)))))
574 (define-vop (data-vector-ref/simple-array-complex-long-float
)
575 (:note
"inline array access")
576 (:translate data-vector-ref
)
578 (:args
(object :scs
(descriptor-reg) :to
:result
)
579 (index :scs
(any-reg)))
580 (:arg-types simple-array-complex-long-float positive-fixnum
)
581 (:results
(value :scs
(complex-long-reg)))
582 (:result-types complex-long-float
)
583 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) offset
)
585 (let ((real-tn (complex-long-reg-real-tn value
)))
586 (inst sll offset index
3)
587 (inst add offset
(- (* vector-data-offset n-word-bytes
)
588 other-pointer-lowtag
))
589 (load-long-reg real-tn object offset nil
))
590 (let ((imag-tn (complex-long-reg-imag-tn value
)))
591 (inst add offset
(* 4 n-word-bytes
))
592 (load-long-reg imag-tn object offset nil
))))
595 (define-vop (data-vector-set/simple-array-complex-long-float
)
596 (:note
"inline array store")
597 (:translate data-vector-set
)
599 (:args
(object :scs
(descriptor-reg) :to
:result
)
600 (index :scs
(any-reg))
601 (value :scs
(complex-long-reg) :target result
))
602 (:arg-types simple-array-complex-long-float positive-fixnum
604 (:results
(result :scs
(complex-long-reg)))
605 (:result-types complex-long-float
)
606 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) offset
)
608 (let ((value-real (complex-long-reg-real-tn value
))
609 (result-real (complex-long-reg-real-tn result
)))
610 (inst sll offset index
3)
611 (inst add offset
(- (* vector-data-offset n-word-bytes
)
612 other-pointer-lowtag
))
613 (store-long-reg value-real object offset nil
)
614 (unless (location= result-real value-real
)
615 (move-long-reg result-real value-real
)))
616 (let ((value-imag (complex-long-reg-imag-tn value
))
617 (result-imag (complex-long-reg-imag-tn result
)))
618 (inst add offset
(* 4 n-word-bytes
))
619 (store-long-reg value-imag object offset nil
)
620 (unless (location= result-imag value-imag
)
621 (move-long-reg result-imag value-imag
)))))
624 ;;; These VOPs are used for implementing float slots in structures (whose raw
625 ;;; data is an unsigned-32 vector.
627 (define-vop (raw-ref-single data-vector-ref
/simple-array-single-float
)
628 (:translate %raw-ref-single
)
629 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
))
631 (define-vop (raw-set-single data-vector-set
/simple-array-single-float
)
632 (:translate %raw-set-single
)
633 (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float
))
635 (define-vop (raw-ref-double data-vector-ref
/simple-array-double-float
)
636 (:translate %raw-ref-double
)
637 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
))
639 (define-vop (raw-set-double data-vector-set
/simple-array-double-float
)
640 (:translate %raw-set-double
)
641 (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float
))
644 (define-vop (raw-ref-long data-vector-ref
/simple-array-long-float
)
645 (:translate %raw-ref-long
)
646 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
))
649 (define-vop (raw-set-double data-vector-set
/simple-array-long-float
)
650 (:translate %raw-set-long
)
651 (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float
))
653 (define-vop (raw-ref-complex-single
654 data-vector-ref
/simple-array-complex-single-float
)
655 (:translate %raw-ref-complex-single
)
656 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
))
658 (define-vop (raw-set-complex-single
659 data-vector-set
/simple-array-complex-single-float
)
660 (:translate %raw-set-complex-single
)
661 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
662 complex-single-float
))
664 (define-vop (raw-ref-complex-double
665 data-vector-ref
/simple-array-complex-double-float
)
666 (:translate %raw-ref-complex-double
)
667 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
))
669 (define-vop (raw-set-complex-double
670 data-vector-set
/simple-array-complex-double-float
)
671 (:translate %raw-set-complex-double
)
672 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
673 complex-double-float
))
676 (define-vop (raw-ref-complex-long
677 data-vector-ref
/simple-array-complex-long-float
)
678 (:translate %raw-ref-complex-long
)
679 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
))
682 (define-vop (raw-set-complex-long
683 data-vector-set
/simple-array-complex-long-float
)
684 (:translate %raw-set-complex-long
)
685 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
689 ;;; These vops are useful for accessing the bits of a vector irrespective of
690 ;;; what type of vector it is.
693 (define-vop (raw-bits word-index-ref
)
694 (:note
"raw-bits VOP")
695 (:translate %raw-bits
)
696 (:results
(value :scs
(unsigned-reg)))
697 (:result-types unsigned-num
)
698 (:variant
0 other-pointer-lowtag
))
700 (define-vop (set-raw-bits word-index-set
)
701 (:note
"setf raw-bits VOP")
702 (:translate %set-raw-bits
)
703 (:args
(object :scs
(descriptor-reg))
704 (index :scs
(any-reg zero immediate
))
705 (value :scs
(unsigned-reg)))
706 (:arg-types
* tagged-num unsigned-num
)
707 (:results
(result :scs
(unsigned-reg)))
708 (:result-types unsigned-num
)
709 (:variant
0 other-pointer-lowtag
))