1 ;;;; the MIPS 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.
15 (define-vop (make-array-header)
17 (:translate make-array-header
)
18 (:args
(type :scs
(any-reg))
19 (rank :scs
(any-reg)))
20 (:arg-types positive-fixnum positive-fixnum
)
21 (:temporary
(:scs
(any-reg)) bytes
)
22 (:temporary
(:scs
(non-descriptor-reg)) header
)
23 (:temporary
(:sc non-descriptor-reg
:offset nl4-offset
) pa-flag
)
24 (:results
(result :scs
(descriptor-reg)))
26 (inst addu bytes rank
(+ (* array-dimensions-offset n-word-bytes
)
28 (inst li header
(lognot lowtag-mask
))
29 (inst and bytes header
)
30 (inst addu header rank
(fixnumize (1- array-dimensions-offset
)))
31 (inst sll header n-widetag-bits
)
32 (inst or header header type
)
34 (pseudo-atomic (pa-flag)
35 (inst or result alloc-tn other-pointer-lowtag
)
36 (storew header result
0 other-pointer-lowtag
)
37 (inst addu alloc-tn bytes
))))
39 ;;;; Additional accessors and setters for the array header.
40 (define-full-reffer %array-dimension
*
41 array-dimensions-offset other-pointer-lowtag
42 (any-reg) positive-fixnum sb
!kernel
:%array-dimension
)
44 (define-full-setter %set-array-dimension
*
45 array-dimensions-offset other-pointer-lowtag
46 (any-reg) positive-fixnum sb
!kernel
:%set-array-dimension
)
48 (define-vop (array-rank-vop)
49 (:translate sb
!kernel
:%array-rank
)
51 (:args
(x :scs
(descriptor-reg)))
52 (:temporary
(:scs
(non-descriptor-reg)) temp
)
53 (:results
(res :scs
(any-reg descriptor-reg
)))
55 (loadw temp x
0 other-pointer-lowtag
)
56 (inst sra temp n-widetag-bits
)
57 (inst subu temp
(1- array-dimensions-offset
))
58 (inst sll res temp
2)))
60 ;;;; Bounds checking routine.
61 (define-vop (check-bound)
62 (:translate %check-bound
)
64 (:args
(array :scs
(descriptor-reg))
65 (bound :scs
(any-reg descriptor-reg
))
66 (index :scs
(any-reg descriptor-reg
) :target result
))
67 (:results
(result :scs
(any-reg descriptor-reg
)))
68 (:temporary
(:scs
(non-descriptor-reg)) temp
)
70 (:save-p
:compute-only
)
72 (let ((error (generate-error-code vop invalid-array-index-error
74 (inst sltu temp index bound
)
75 (inst beq temp zero-tn error
)
77 (move result index
))))
79 ;;;; Accessors/Setters
81 ;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
82 ;;; elements are represented in integer registers and are built out of
83 ;;; 8, 16, or 32 bit elements.
84 (macrolet ((def-full-data-vector-frobs (type element-type
&rest scs
)
86 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type
) ,type
87 vector-data-offset other-pointer-lowtag
88 ,(remove-if #'(lambda (x) (member x
'(null zero
))) scs
)
91 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type
) ,type
92 vector-data-offset other-pointer-lowtag
,scs
,element-type
95 (def-partial-data-vector-frobs (type element-type size signed
&rest scs
)
97 (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type
) ,type
98 ,size
,signed vector-data-offset other-pointer-lowtag
,scs
99 ,element-type data-vector-ref
)
100 (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type
) ,type
101 ,size vector-data-offset other-pointer-lowtag
,scs
102 ,element-type data-vector-set
))))
104 (def-full-data-vector-frobs simple-vector
*
105 descriptor-reg any-reg null zero
)
107 (def-partial-data-vector-frobs simple-base-string character
108 :byte nil character-reg
)
110 (def-full-data-vector-frobs simple-character-string character character-reg
)
112 (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
113 :byte nil unsigned-reg signed-reg
)
114 (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
115 :byte nil unsigned-reg signed-reg
)
117 (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
118 :short nil unsigned-reg signed-reg
)
119 (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
120 :short nil unsigned-reg signed-reg
)
122 (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
124 (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
127 (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
130 (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
133 (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum
135 (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num
138 (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
141 ;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit,
142 ;;; and 4-bit vectors.
143 (macrolet ((def-small-data-vector-frobs (type bits
)
144 (let* ((elements-per-word (floor n-word-bits bits
))
145 (bit-shift (1- (integer-length elements-per-word
))))
147 (define-vop (,(symbolicate 'data-vector-ref
/ type
))
148 (:note
"inline array access")
149 (:translate data-vector-ref
)
151 (:args
(object :scs
(descriptor-reg))
152 (index :scs
(unsigned-reg)))
153 (:arg-types
,type positive-fixnum
)
154 (:results
(value :scs
(any-reg)))
155 (:result-types positive-fixnum
)
156 (:temporary
(:scs
(interior-reg)) lip
)
157 (:temporary
(:scs
(non-descriptor-reg) :to
(:result
0)) temp result
)
159 (inst srl temp index
,bit-shift
)
161 (inst addu lip object temp
)
163 (- (* vector-data-offset n-word-bytes
)
164 other-pointer-lowtag
))
165 (inst and temp index
,(1- elements-per-word
))
166 ,@(when (eq *backend-byte-order
* :big-endian
)
167 `((inst xor temp
,(1- elements-per-word
))))
169 `((inst sll temp
,(1- (integer-length bits
)))))
170 (inst srl result temp
)
171 (inst and result
,(1- (ash 1 bits
)))
172 (inst sll value result
2)))
173 (define-vop (,(symbolicate 'data-vector-ref-c
/ type
))
174 (:translate data-vector-ref
)
176 (:args
(object :scs
(descriptor-reg)))
180 ,(1- (* (1+ (- (floor (+ #x7fff
181 other-pointer-lowtag
)
184 elements-per-word
)))))
186 (:results
(result :scs
(unsigned-reg)))
187 (:result-types positive-fixnum
)
189 (multiple-value-bind (word extra
) (floor index
,elements-per-word
)
190 ,@(when (eq *backend-byte-order
* :big-endian
)
191 `((setf extra
(logxor extra
(1- ,elements-per-word
)))))
192 (loadw result object
(+ word vector-data-offset
)
193 other-pointer-lowtag
)
194 (unless (zerop extra
)
195 (inst srl result
(* extra
,bits
)))
196 (unless (= extra
,(1- elements-per-word
))
197 (inst and result
,(1- (ash 1 bits
)))))))
198 (define-vop (,(symbolicate 'data-vector-set
/ type
))
199 (:note
"inline array store")
200 (:translate data-vector-set
)
202 (:args
(object :scs
(descriptor-reg))
203 (index :scs
(unsigned-reg) :target shift
)
204 (value :scs
(unsigned-reg zero immediate
) :target result
))
205 (:arg-types
,type positive-fixnum positive-fixnum
)
206 (:results
(result :scs
(unsigned-reg)))
207 (:result-types positive-fixnum
)
208 (:temporary
(:scs
(interior-reg)) lip
)
209 (:temporary
(:scs
(non-descriptor-reg)) temp old
)
210 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) shift
)
212 (inst srl temp index
,bit-shift
)
214 (inst addu lip object temp
)
216 (- (* vector-data-offset n-word-bytes
)
217 other-pointer-lowtag
))
218 (inst and shift index
,(1- elements-per-word
))
219 ,@(when (eq *backend-byte-order
* :big-endian
)
220 `((inst xor shift
,(1- elements-per-word
))))
222 `((inst sll shift
,(1- (integer-length bits
)))))
223 (unless (and (sc-is value immediate
)
224 (= (tn-value value
) ,(1- (ash 1 bits
))))
225 (inst li temp
,(1- (ash 1 bits
)))
226 (inst sll temp shift
)
227 (inst nor temp temp zero-tn
)
229 (unless (sc-is value zero
)
232 (inst li temp
(logand (tn-value value
) ,(1- (ash 1 bits
)))))
234 (inst and temp value
,(1- (ash 1 bits
)))))
235 (inst sll temp shift
)
238 (- (* vector-data-offset n-word-bytes
)
239 other-pointer-lowtag
))
242 (inst li result
(tn-value value
)))
244 (move result zero-tn
))
246 (move result value
)))))
247 (define-vop (,(symbolicate 'data-vector-set-c
/ type
))
248 (:translate data-vector-set
)
250 (:args
(object :scs
(descriptor-reg))
251 (value :scs
(unsigned-reg zero immediate
) :target result
))
255 ,(1- (* (1+ (- (floor (+ #x7fff
256 other-pointer-lowtag
)
259 elements-per-word
))))
262 (:results
(result :scs
(unsigned-reg)))
263 (:result-types positive-fixnum
)
264 (:temporary
(:scs
(non-descriptor-reg)) temp old
)
266 (multiple-value-bind (word extra
) (floor index
,elements-per-word
)
267 ,@(when (eq *backend-byte-order
* :big-endian
)
268 `((setf extra
(logxor extra
(1- ,elements-per-word
)))))
270 (- (* (+ word vector-data-offset
) n-word-bytes
)
271 other-pointer-lowtag
))
272 (unless (and (sc-is value immediate
)
273 (= (tn-value value
) ,(1- (ash 1 bits
))))
274 (cond ((= extra
,(1- elements-per-word
))
276 (inst srl old
,bits
))
279 (lognot (ash ,(1- (ash 1 bits
)) (* extra
,bits
))))
280 (inst and old temp
))))
284 (let ((value (ash (logand (tn-value value
) ,(1- (ash 1 bits
)))
286 (cond ((< value
#x10000
)
290 (inst or old temp
)))))
292 (inst sll temp value
(* extra
,bits
))
295 (- (* (+ word vector-data-offset
) n-word-bytes
)
296 other-pointer-lowtag
))
299 (inst li result
(tn-value value
)))
301 (move result zero-tn
))
303 (move result value
))))))))))
304 (def-small-data-vector-frobs simple-bit-vector
1)
305 (def-small-data-vector-frobs simple-array-unsigned-byte-2
2)
306 (def-small-data-vector-frobs simple-array-unsigned-byte-4
4))
308 ;;; And the float variants.
309 (define-vop (data-vector-ref/simple-array-single-float
)
310 (:note
"inline array access")
311 (:translate data-vector-ref
)
313 (:args
(object :scs
(descriptor-reg))
314 (index :scs
(any-reg)))
315 (:arg-types simple-array-single-float positive-fixnum
)
316 (:results
(value :scs
(single-reg)))
317 (:result-types single-float
)
318 (:temporary
(:scs
(interior-reg)) lip
)
320 (inst addu lip object index
)
322 (- (* vector-data-offset n-word-bytes
)
323 other-pointer-lowtag
))
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
(interior-reg)) lip
)
338 (inst addu lip object index
)
340 (- (* vector-data-offset n-word-bytes
)
341 other-pointer-lowtag
))
342 (unless (location= result value
)
343 (inst fmove
:single 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
(interior-reg)) lip
)
356 (inst addu lip object index
)
357 (inst addu lip index
)
358 (ecase *backend-byte-order
*
361 (+ (- (* vector-data-offset n-word-bytes
)
362 other-pointer-lowtag
)
364 (inst lwc1-odd value lip
365 (- (* vector-data-offset n-word-bytes
)
366 other-pointer-lowtag
)))
369 (- (* vector-data-offset n-word-bytes
)
370 other-pointer-lowtag
))
371 (inst lwc1-odd value lip
372 (+ (- (* vector-data-offset n-word-bytes
)
373 other-pointer-lowtag
)
377 (define-vop (data-vector-set/simple-array-double-float
)
378 (:note
"inline array store")
379 (:translate data-vector-set
)
381 (:args
(object :scs
(descriptor-reg))
382 (index :scs
(any-reg))
383 (value :scs
(double-reg) :target result
))
384 (:arg-types simple-array-double-float positive-fixnum double-float
)
385 (:results
(result :scs
(double-reg)))
386 (:result-types double-float
)
387 (:temporary
(:scs
(interior-reg)) lip
)
389 (inst addu lip object index
)
390 (inst addu lip index
)
391 (ecase *backend-byte-order
*
394 (+ (- (* vector-data-offset n-word-bytes
)
395 other-pointer-lowtag
)
397 (inst swc1-odd value lip
398 (- (* vector-data-offset n-word-bytes
)
399 other-pointer-lowtag
)))
402 (- (* vector-data-offset n-word-bytes
)
403 other-pointer-lowtag
))
404 (inst swc1-odd value lip
405 (+ (- (* vector-data-offset n-word-bytes
)
406 other-pointer-lowtag
)
408 (unless (location= result value
)
409 (inst fmove
:double result value
))))
411 ;;; Complex float arrays.
412 (define-vop (data-vector-ref/simple-array-complex-single-float
)
413 (:note
"inline array access")
414 (:translate data-vector-ref
)
416 (:args
(object :scs
(descriptor-reg))
417 (index :scs
(any-reg)))
418 (:arg-types simple-array-complex-single-float positive-fixnum
)
419 (:results
(value :scs
(complex-single-reg)))
420 (:temporary
(:scs
(interior-reg)) lip
)
421 (:result-types complex-single-float
)
423 (inst addu lip object index
)
424 (inst addu lip index
)
425 (let ((real-tn (complex-single-reg-real-tn value
)))
426 (inst lwc1 real-tn lip
(- (* vector-data-offset n-word-bytes
)
427 other-pointer-lowtag
)))
428 (let ((imag-tn (complex-single-reg-imag-tn value
)))
429 (inst lwc1 imag-tn lip
(- (* (1+ vector-data-offset
) n-word-bytes
)
430 other-pointer-lowtag
)))
433 (define-vop (data-vector-set/simple-array-complex-single-float
)
434 (:note
"inline array store")
435 (:translate data-vector-set
)
437 (:args
(object :scs
(descriptor-reg))
438 (index :scs
(any-reg))
439 (value :scs
(complex-single-reg) :target result
))
440 (:arg-types simple-array-complex-single-float positive-fixnum
441 complex-single-float
)
442 (:results
(result :scs
(complex-single-reg)))
443 (:result-types complex-single-float
)
444 (:temporary
(:scs
(interior-reg)) lip
)
446 (inst addu lip object index
)
447 (inst addu lip index
)
448 (let ((value-real (complex-single-reg-real-tn value
))
449 (result-real (complex-single-reg-real-tn result
)))
450 (inst swc1 value-real lip
(- (* vector-data-offset n-word-bytes
)
451 other-pointer-lowtag
))
452 (unless (location= result-real value-real
)
453 (inst fmove
:single result-real value-real
)))
454 (let ((value-imag (complex-single-reg-imag-tn value
))
455 (result-imag (complex-single-reg-imag-tn result
)))
456 (inst swc1 value-imag lip
(- (* (1+ vector-data-offset
) n-word-bytes
)
457 other-pointer-lowtag
))
458 (unless (location= result-imag value-imag
)
459 (inst fmove
:single result-imag value-imag
)))))
461 (define-vop (data-vector-ref/simple-array-complex-double-float
)
462 (:note
"inline array access")
463 (:translate data-vector-ref
)
465 (:args
(object :scs
(descriptor-reg))
466 (index :scs
(any-reg) :target shift
))
467 (:arg-types simple-array-complex-double-float positive-fixnum
)
468 (:results
(value :scs
(complex-double-reg)))
469 (:result-types complex-double-float
)
470 (:temporary
(:scs
(interior-reg)) lip
)
471 (:temporary
(:scs
(any-reg) :from
(:argument
1)) shift
)
473 (inst sll shift index
2)
474 (inst addu lip object shift
)
475 (let ((real-tn (complex-double-reg-real-tn value
)))
476 (ld-double real-tn lip
(- (* vector-data-offset n-word-bytes
)
477 other-pointer-lowtag
)))
478 (let ((imag-tn (complex-double-reg-imag-tn value
)))
479 (ld-double imag-tn lip
(- (* (+ vector-data-offset
2) n-word-bytes
)
480 other-pointer-lowtag
)))
483 (define-vop (data-vector-set/simple-array-complex-double-float
)
484 (:note
"inline array store")
485 (:translate data-vector-set
)
487 (:args
(object :scs
(descriptor-reg))
488 (index :scs
(any-reg) :target shift
)
489 (value :scs
(complex-double-reg) :target result
))
490 (:arg-types simple-array-complex-double-float positive-fixnum
491 complex-double-float
)
492 (:results
(result :scs
(complex-double-reg)))
493 (:result-types complex-double-float
)
494 (:temporary
(:scs
(interior-reg)) lip
)
495 (:temporary
(:scs
(any-reg) :from
(:argument
1)) shift
)
497 (inst sll shift index
2)
498 (inst addu lip object shift
)
499 (let ((value-real (complex-double-reg-real-tn value
))
500 (result-real (complex-double-reg-real-tn result
)))
501 (str-double value-real lip
(- (* vector-data-offset n-word-bytes
)
502 other-pointer-lowtag
))
503 (unless (location= result-real value-real
)
504 (inst fmove
:double result-real value-real
)))
505 (let ((value-imag (complex-double-reg-imag-tn value
))
506 (result-imag (complex-double-reg-imag-tn result
)))
507 (str-double value-imag lip
(- (* (+ vector-data-offset
2) n-word-bytes
)
508 other-pointer-lowtag
))
509 (unless (location= result-imag value-imag
)
510 (inst fmove
:double result-imag value-imag
)))))
513 ;;; These VOPs are used for implementing float slots in structures (whose raw
514 ;;; data is an unsigned-32 vector.
515 (define-vop (raw-ref-single data-vector-ref
/simple-array-single-float
)
516 (:translate %raw-ref-single
)
517 (:arg-types sb
!c
::raw-vector positive-fixnum
))
518 (define-vop (raw-set-single data-vector-set
/simple-array-single-float
)
519 (:translate %raw-set-single
)
520 (:arg-types sb
!c
::raw-vector positive-fixnum single-float
))
521 (define-vop (raw-ref-double data-vector-ref
/simple-array-double-float
)
522 (:translate %raw-ref-double
)
523 (:arg-types sb
!c
::raw-vector positive-fixnum
))
524 (define-vop (raw-set-double data-vector-set
/simple-array-double-float
)
525 (:translate %raw-set-double
)
526 (:arg-types sb
!c
::raw-vector positive-fixnum double-float
))
527 (define-vop (raw-ref-complex-single
528 data-vector-ref
/simple-array-complex-single-float
)
529 (:translate %raw-ref-complex-single
)
530 (:arg-types sb
!c
::raw-vector positive-fixnum
))
531 (define-vop (raw-set-complex-single
532 data-vector-set
/simple-array-complex-single-float
)
533 (:translate %raw-set-complex-single
)
534 (:arg-types sb
!c
::raw-vector positive-fixnum complex-single-float
))
535 (define-vop (raw-ref-complex-double
536 data-vector-ref
/simple-array-complex-double-float
)
537 (:translate %raw-ref-complex-double
)
538 (:arg-types sb
!c
::raw-vector positive-fixnum
))
539 (define-vop (raw-set-complex-double
540 data-vector-set
/simple-array-complex-double-float
)
541 (:translate %raw-set-complex-double
)
542 (:arg-types sb
!c
::raw-vector positive-fixnum complex-double-float
))
544 ;;; These vops are useful for accessing the bits of a vector irrespective of
545 ;;; what type of vector it is.
546 (define-full-reffer raw-bits
* 0 other-pointer-lowtag
(unsigned-reg) unsigned-num
548 (define-full-setter set-raw-bits
* 0 other-pointer-lowtag
(unsigned-reg)
549 unsigned-num %set-raw-bits
)
550 (define-full-reffer vector-raw-bits
* vector-data-offset other-pointer-lowtag
551 (unsigned-reg) unsigned-num %vector-raw-bits
)
552 (define-full-setter set-vector-raw-bits
* vector-data-offset other-pointer-lowtag
553 (unsigned-reg) unsigned-num %set-vector-raw-bits
)
555 ;;;; Misc. Array VOPs.
556 (define-vop (get-vector-subtype get-header-data
))
557 (define-vop (set-vector-subtype set-header-data
))