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
(non-descriptor-reg)) bytes header
)
22 (:temporary
(:sc non-descriptor-reg
:offset nl4-offset
) pa-flag
)
23 (:results
(result :scs
(descriptor-reg)))
25 (inst addu bytes rank
(+ (* (1+ array-dimensions-offset
) n-word-bytes
)
27 (inst srl bytes n-lowtag-bits
)
28 (inst sll bytes n-lowtag-bits
)
29 (inst addu header rank
(fixnumize (1- array-dimensions-offset
)))
30 (inst sll header n-widetag-bits
)
32 ;; Remove the extraneous fixnum tag bits because TYPE and RANK
34 (inst srl header n-fixnum-tag-bits
)
35 (pseudo-atomic (pa-flag)
36 (inst or result alloc-tn other-pointer-lowtag
)
37 (storew header result
0 other-pointer-lowtag
)
38 (inst addu alloc-tn bytes
))))
40 ;;;; Additional accessors and setters for the array header.
41 (define-full-reffer %array-dimension
*
42 array-dimensions-offset other-pointer-lowtag
43 (any-reg) positive-fixnum sb
!kernel
:%array-dimension
)
45 (define-full-setter %set-array-dimension
*
46 array-dimensions-offset other-pointer-lowtag
47 (any-reg) positive-fixnum sb
!kernel
:%set-array-dimension
)
49 (define-vop (array-rank-vop)
50 (:translate sb
!kernel
:%array-rank
)
52 (:args
(x :scs
(descriptor-reg)))
53 (:temporary
(:scs
(non-descriptor-reg)) temp
)
54 (:results
(res :scs
(any-reg descriptor-reg
)))
56 (loadw temp x
0 other-pointer-lowtag
)
57 (inst sra temp n-widetag-bits
)
58 (inst subu temp
(1- array-dimensions-offset
))
59 (inst sll res temp n-fixnum-tag-bits
)))
61 ;;;; Bounds checking routine.
62 (define-vop (check-bound)
63 (:translate %check-bound
)
65 (:args
(array :scs
(descriptor-reg))
66 (bound :scs
(any-reg descriptor-reg
))
67 (index :scs
(any-reg descriptor-reg
) :target result
))
68 (:results
(result :scs
(any-reg descriptor-reg
)))
69 (:temporary
(:scs
(non-descriptor-reg)) temp
)
71 (:save-p
:compute-only
)
73 (let ((error (generate-error-code vop invalid-array-index-error
75 (inst sltu temp index bound
)
78 (move result index
))))
80 ;;;; Accessors/Setters
82 ;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
83 ;;; elements are represented in integer registers and are built out of
84 ;;; 8, 16, or 32 bit elements.
85 (macrolet ((def-full-data-vector-frobs (type element-type
&rest scs
)
87 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type
) ,type
88 vector-data-offset other-pointer-lowtag
89 ,(remove-if #'(lambda (x) (member x
'(null zero
))) scs
)
92 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type
) ,type
93 vector-data-offset other-pointer-lowtag
,scs
,element-type
96 (def-partial-data-vector-frobs (type element-type size signed
&rest scs
)
98 (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type
) ,type
99 ,size
,signed vector-data-offset other-pointer-lowtag
,scs
100 ,element-type data-vector-ref
)
101 (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type
) ,type
102 ,size vector-data-offset other-pointer-lowtag
,scs
103 ,element-type data-vector-set
))))
105 (def-full-data-vector-frobs simple-vector
*
106 descriptor-reg any-reg null zero
)
108 (def-partial-data-vector-frobs simple-base-string character
109 :byte nil character-reg
)
111 (def-full-data-vector-frobs simple-character-string character character-reg
)
113 (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
114 :byte nil unsigned-reg signed-reg
)
115 (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
116 :byte nil unsigned-reg signed-reg
)
118 (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
119 :short nil unsigned-reg signed-reg
)
120 (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
121 :short nil unsigned-reg signed-reg
)
123 (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
125 (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
128 (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
131 (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
134 (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum
136 (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num
139 (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
142 ;;; Integer vectors whose elements are smaller than a byte. I.e. bit, 2-bit,
143 ;;; and 4-bit vectors.
144 (macrolet ((def-small-data-vector-frobs (type bits
)
145 (let* ((elements-per-word (floor n-word-bits bits
))
146 (bit-shift (1- (integer-length elements-per-word
))))
148 (define-vop (,(symbolicate "DATA-VECTOR-REF/" type
))
149 (:note
"inline array access")
150 (:translate data-vector-ref
)
152 (:args
(object :scs
(descriptor-reg))
153 (index :scs
(unsigned-reg)))
154 (:arg-types
,type positive-fixnum
)
155 (:results
(value :scs
(any-reg)))
156 (:result-types positive-fixnum
)
157 (:temporary
(:scs
(interior-reg)) lip
)
158 (:temporary
(:scs
(non-descriptor-reg) :to
(:result
0)) temp result
)
160 (inst srl temp index
,bit-shift
)
161 (inst sll temp n-fixnum-tag-bits
)
162 (inst addu lip object temp
)
164 (- (* vector-data-offset n-word-bytes
)
165 other-pointer-lowtag
))
166 (inst and temp index
,(1- elements-per-word
))
167 ,@(when (eq *backend-byte-order
* :big-endian
)
168 `((inst xor temp
,(1- elements-per-word
))))
170 `((inst sll temp
,(1- (integer-length bits
)))))
171 (inst srl result temp
)
172 (inst and result
,(1- (ash 1 bits
)))
173 (inst sll value result n-fixnum-tag-bits
)))
174 (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" type
))
175 (:translate data-vector-ref
)
177 (:args
(object :scs
(descriptor-reg)))
181 ,(1- (* (1+ (- (floor (+ #x7fff
182 other-pointer-lowtag
)
185 elements-per-word
)))))
187 (:results
(result :scs
(unsigned-reg)))
188 (:result-types positive-fixnum
)
190 (multiple-value-bind (word extra
) (floor index
,elements-per-word
)
191 ,@(when (eq *backend-byte-order
* :big-endian
)
192 `((setf extra
(logxor extra
(1- ,elements-per-word
)))))
193 (loadw result object
(+ word vector-data-offset
)
194 other-pointer-lowtag
)
195 (unless (zerop extra
)
196 (inst srl result
(* extra
,bits
)))
197 (unless (= extra
,(1- elements-per-word
))
198 (inst and result
,(1- (ash 1 bits
)))))))
199 (define-vop (,(symbolicate "DATA-VECTOR-SET/" type
))
200 (:note
"inline array store")
201 (:translate data-vector-set
)
203 (:args
(object :scs
(descriptor-reg))
204 (index :scs
(unsigned-reg) :target shift
)
205 (value :scs
(unsigned-reg zero immediate
) :target result
))
206 (:arg-types
,type positive-fixnum positive-fixnum
)
207 (:results
(result :scs
(unsigned-reg)))
208 (:result-types positive-fixnum
)
209 (:temporary
(:scs
(interior-reg)) lip
)
210 (:temporary
(:scs
(non-descriptor-reg)) temp old
)
211 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) shift
)
213 (inst srl temp index
,bit-shift
)
214 (inst sll temp n-fixnum-tag-bits
)
215 (inst addu lip object temp
)
217 (- (* vector-data-offset n-word-bytes
)
218 other-pointer-lowtag
))
219 (inst and shift index
,(1- elements-per-word
))
220 ,@(when (eq *backend-byte-order
* :big-endian
)
221 `((inst xor shift
,(1- elements-per-word
))))
223 `((inst sll shift
,(1- (integer-length bits
)))))
224 (unless (and (sc-is value immediate
)
225 (= (tn-value value
) ,(1- (ash 1 bits
))))
226 (inst li temp
,(1- (ash 1 bits
)))
227 (inst sll temp shift
)
228 (inst nor temp temp zero-tn
)
230 (unless (sc-is value zero
)
233 (inst li temp
(logand (tn-value value
) ,(1- (ash 1 bits
)))))
235 (inst and temp value
,(1- (ash 1 bits
)))))
236 (inst sll temp shift
)
239 (- (* vector-data-offset n-word-bytes
)
240 other-pointer-lowtag
))
243 (inst li result
(tn-value value
)))
245 (move result zero-tn
))
247 (move result value
)))))
248 (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" type
))
249 (:translate data-vector-set
)
251 (:args
(object :scs
(descriptor-reg))
252 (value :scs
(unsigned-reg zero immediate
) :target result
))
256 ,(1- (* (1+ (- (floor (+ #x7fff
257 other-pointer-lowtag
)
260 elements-per-word
))))
263 (:results
(result :scs
(unsigned-reg)))
264 (:result-types positive-fixnum
)
265 (:temporary
(:scs
(non-descriptor-reg)) temp old
)
267 (multiple-value-bind (word extra
) (floor index
,elements-per-word
)
268 ,@(when (eq *backend-byte-order
* :big-endian
)
269 `((setf extra
(logxor extra
(1- ,elements-per-word
)))))
271 (- (* (+ word vector-data-offset
) n-word-bytes
)
272 other-pointer-lowtag
))
273 (unless (and (sc-is value immediate
)
274 (= (tn-value value
) ,(1- (ash 1 bits
))))
275 (cond ((= extra
,(1- elements-per-word
))
277 (inst srl old
,bits
))
280 (lognot (ash ,(1- (ash 1 bits
)) (* extra
,bits
))))
281 (inst and old temp
))))
285 (let ((value (ash (logand (tn-value value
) ,(1- (ash 1 bits
)))
287 (cond ((< value
#x10000
)
291 (inst or old temp
)))))
293 (inst sll temp value
(* extra
,bits
))
296 (- (* (+ word vector-data-offset
) n-word-bytes
)
297 other-pointer-lowtag
))
300 (inst li result
(tn-value value
)))
302 (move result zero-tn
))
304 (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 (:result-types single-float
)
319 (:temporary
(:scs
(interior-reg)) lip
)
321 (inst addu lip object index
)
323 (- (* vector-data-offset n-word-bytes
)
324 other-pointer-lowtag
))
327 (define-vop (data-vector-set/simple-array-single-float
)
328 (:note
"inline array store")
329 (:translate data-vector-set
)
331 (:args
(object :scs
(descriptor-reg))
332 (index :scs
(any-reg))
333 (value :scs
(single-reg) :target result
))
334 (:arg-types simple-array-single-float positive-fixnum single-float
)
335 (:results
(result :scs
(single-reg)))
336 (:result-types single-float
)
337 (:temporary
(:scs
(interior-reg)) lip
)
339 (inst addu lip object index
)
341 (- (* vector-data-offset n-word-bytes
)
342 other-pointer-lowtag
))
343 (unless (location= result value
)
344 (inst fmove
:single result value
))))
346 (define-vop (data-vector-ref/simple-array-double-float
)
347 (:note
"inline array access")
348 (:translate data-vector-ref
)
350 (:args
(object :scs
(descriptor-reg))
351 (index :scs
(any-reg)))
352 (:arg-types simple-array-double-float positive-fixnum
)
353 (:results
(value :scs
(double-reg)))
354 (:result-types double-float
)
355 (:temporary
(:scs
(interior-reg)) lip
)
357 (inst addu lip object index
)
358 (inst addu lip index
)
359 (ecase *backend-byte-order
*
362 (+ (- (* vector-data-offset n-word-bytes
)
363 other-pointer-lowtag
)
365 (inst lwc1-odd value lip
366 (- (* vector-data-offset n-word-bytes
)
367 other-pointer-lowtag
)))
370 (- (* vector-data-offset n-word-bytes
)
371 other-pointer-lowtag
))
372 (inst lwc1-odd value lip
373 (+ (- (* vector-data-offset n-word-bytes
)
374 other-pointer-lowtag
)
378 (define-vop (data-vector-set/simple-array-double-float
)
379 (:note
"inline array store")
380 (:translate data-vector-set
)
382 (:args
(object :scs
(descriptor-reg))
383 (index :scs
(any-reg))
384 (value :scs
(double-reg) :target result
))
385 (:arg-types simple-array-double-float positive-fixnum double-float
)
386 (:results
(result :scs
(double-reg)))
387 (:result-types double-float
)
388 (:temporary
(:scs
(interior-reg)) lip
)
390 (inst addu lip object index
)
391 (inst addu lip index
)
392 (ecase *backend-byte-order
*
395 (+ (- (* vector-data-offset n-word-bytes
)
396 other-pointer-lowtag
)
398 (inst swc1-odd value lip
399 (- (* vector-data-offset n-word-bytes
)
400 other-pointer-lowtag
)))
403 (- (* vector-data-offset n-word-bytes
)
404 other-pointer-lowtag
))
405 (inst swc1-odd value lip
406 (+ (- (* vector-data-offset n-word-bytes
)
407 other-pointer-lowtag
)
409 (unless (location= result value
)
410 (inst fmove
:double result value
))))
412 ;;; Complex float arrays.
413 (define-vop (data-vector-ref/simple-array-complex-single-float
)
414 (:note
"inline array access")
415 (:translate data-vector-ref
)
417 (:args
(object :scs
(descriptor-reg))
418 (index :scs
(any-reg)))
419 (:arg-types simple-array-complex-single-float positive-fixnum
)
420 (:results
(value :scs
(complex-single-reg)))
421 (:temporary
(:scs
(interior-reg)) lip
)
422 (:result-types complex-single-float
)
424 (inst addu lip object index
)
425 (inst addu lip index
)
426 (let ((real-tn (complex-single-reg-real-tn value
)))
427 (inst lwc1 real-tn lip
(- (* vector-data-offset n-word-bytes
)
428 other-pointer-lowtag
)))
429 (let ((imag-tn (complex-single-reg-imag-tn value
)))
430 (inst lwc1 imag-tn lip
(- (* (1+ vector-data-offset
) n-word-bytes
)
431 other-pointer-lowtag
)))
434 (define-vop (data-vector-set/simple-array-complex-single-float
)
435 (:note
"inline array store")
436 (:translate data-vector-set
)
438 (:args
(object :scs
(descriptor-reg))
439 (index :scs
(any-reg))
440 (value :scs
(complex-single-reg) :target result
))
441 (:arg-types simple-array-complex-single-float positive-fixnum
442 complex-single-float
)
443 (:results
(result :scs
(complex-single-reg)))
444 (:result-types complex-single-float
)
445 (:temporary
(:scs
(interior-reg)) lip
)
447 (inst addu lip object index
)
448 (inst addu lip index
)
449 (let ((value-real (complex-single-reg-real-tn value
))
450 (result-real (complex-single-reg-real-tn result
)))
451 (inst swc1 value-real lip
(- (* vector-data-offset n-word-bytes
)
452 other-pointer-lowtag
))
453 (unless (location= result-real value-real
)
454 (inst fmove
:single result-real value-real
)))
455 (let ((value-imag (complex-single-reg-imag-tn value
))
456 (result-imag (complex-single-reg-imag-tn result
)))
457 (inst swc1 value-imag lip
(- (* (1+ vector-data-offset
) n-word-bytes
)
458 other-pointer-lowtag
))
459 (unless (location= result-imag value-imag
)
460 (inst fmove
:single result-imag value-imag
)))))
462 (define-vop (data-vector-ref/simple-array-complex-double-float
)
463 (:note
"inline array access")
464 (:translate data-vector-ref
)
466 (:args
(object :scs
(descriptor-reg))
467 (index :scs
(any-reg) :target shift
))
468 (:arg-types simple-array-complex-double-float positive-fixnum
)
469 (:results
(value :scs
(complex-double-reg)))
470 (:result-types complex-double-float
)
471 (:temporary
(:scs
(interior-reg)) lip
)
472 (:temporary
(:scs
(any-reg) :from
(:argument
1)) shift
)
474 (inst sll shift index n-fixnum-tag-bits
)
475 (inst addu lip object shift
)
476 (let ((real-tn (complex-double-reg-real-tn value
)))
477 (ld-double real-tn lip
(- (* vector-data-offset n-word-bytes
)
478 other-pointer-lowtag
)))
479 (let ((imag-tn (complex-double-reg-imag-tn value
)))
480 (ld-double imag-tn lip
(- (* (+ vector-data-offset
2) n-word-bytes
)
481 other-pointer-lowtag
)))
484 (define-vop (data-vector-set/simple-array-complex-double-float
)
485 (:note
"inline array store")
486 (:translate data-vector-set
)
488 (:args
(object :scs
(descriptor-reg))
489 (index :scs
(any-reg) :target shift
)
490 (value :scs
(complex-double-reg) :target result
))
491 (:arg-types simple-array-complex-double-float positive-fixnum
492 complex-double-float
)
493 (:results
(result :scs
(complex-double-reg)))
494 (:result-types complex-double-float
)
495 (:temporary
(:scs
(interior-reg)) lip
)
496 (:temporary
(:scs
(any-reg) :from
(:argument
1)) shift
)
498 (inst sll shift index n-fixnum-tag-bits
)
499 (inst addu lip object shift
)
500 (let ((value-real (complex-double-reg-real-tn value
))
501 (result-real (complex-double-reg-real-tn result
)))
502 (str-double value-real lip
(- (* vector-data-offset n-word-bytes
)
503 other-pointer-lowtag
))
504 (unless (location= result-real value-real
)
505 (inst fmove
:double result-real value-real
)))
506 (let ((value-imag (complex-double-reg-imag-tn value
))
507 (result-imag (complex-double-reg-imag-tn result
)))
508 (str-double value-imag lip
(- (* (+ vector-data-offset
2) n-word-bytes
)
509 other-pointer-lowtag
))
510 (unless (location= result-imag value-imag
)
511 (inst fmove
:double result-imag value-imag
)))))
514 ;;; These vops are useful for accessing the bits of a vector irrespective of
515 ;;; what type of vector it is.
516 (define-full-reffer raw-bits
* 0 other-pointer-lowtag
(unsigned-reg) unsigned-num
518 (define-full-setter set-raw-bits
* 0 other-pointer-lowtag
(unsigned-reg)
519 unsigned-num %set-raw-bits
)
520 (define-full-reffer vector-raw-bits
* vector-data-offset other-pointer-lowtag
521 (unsigned-reg) unsigned-num %vector-raw-bits
)
522 (define-full-setter set-vector-raw-bits
* vector-data-offset other-pointer-lowtag
523 (unsigned-reg) unsigned-num %set-vector-raw-bits
)
525 ;;;; Misc. Array VOPs.
526 (define-vop (get-vector-subtype get-header-data
))
527 (define-vop (set-vector-subtype set-header-data
))