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.
15 ;;;; Allocator for the array header.
17 (define-vop (make-array-header)
19 (:translate make-array-header)
20 (:args (type :scs (any-reg))
21 (rank :scs (any-reg)))
22 (:arg-types positive-fixnum positive-fixnum)
23 (:temporary (:scs (any-reg)) bytes)
24 (:temporary (:scs (non-descriptor-reg)) header)
25 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
26 (:results (result :scs (descriptor-reg)))
28 (inst addu bytes rank (+ (* array-dimensions-offset n-word-bytes)
30 (inst li header (lognot lowtag-mask))
31 (inst and bytes header)
32 (inst addu header rank (fixnumize (1- array-dimensions-offset)))
33 (inst sll header n-widetag-bits)
34 (inst or header header type)
36 (pseudo-atomic (pa-flag)
37 (inst or result alloc-tn other-pointer-lowtag)
38 (storew header result 0 other-pointer-lowtag)
39 (inst addu alloc-tn bytes))))
42 ;;;; Additional accessors and setters for the array header.
43 (define-full-reffer %array-dimension *
44 array-dimensions-offset other-pointer-lowtag
45 (any-reg) positive-fixnum sb!kernel:%array-dimension)
47 (define-full-setter %set-array-dimension *
48 array-dimensions-offset other-pointer-lowtag
49 (any-reg) positive-fixnum sb!kernel:%set-array-dimension)
51 (define-vop (array-rank-vop)
52 (:translate sb!kernel:%array-rank)
54 (:args (x :scs (descriptor-reg)))
55 (:temporary (:scs (non-descriptor-reg)) temp)
56 (:results (res :scs (any-reg descriptor-reg)))
58 (loadw temp x 0 other-pointer-lowtag)
59 (inst sra temp n-widetag-bits)
60 (inst subu temp (1- array-dimensions-offset))
61 (inst sll res temp 2)))
65 ;;;; Bounds checking routine.
68 (define-vop (check-bound)
69 (:translate %check-bound)
71 (:args (array :scs (descriptor-reg))
72 (bound :scs (any-reg descriptor-reg))
73 (index :scs (any-reg descriptor-reg) :target result))
74 (:results (result :scs (any-reg descriptor-reg)))
75 (:temporary (:scs (non-descriptor-reg)) temp)
77 (:save-p :compute-only)
79 (let ((error (generate-error-code vop invalid-array-index-error
81 (inst sltu temp index bound)
82 (inst beq temp zero-tn error)
84 (move result index))))
88 ;;;; Accessors/Setters
90 ;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
91 ;;; elements are represented in integer registers and are built out of
92 ;;; 8, 16, or 32 bit elements.
94 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
96 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
97 vector-data-offset other-pointer-lowtag
98 ,(remove-if #'(lambda (x) (member x '(null zero))) scs)
101 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
102 vector-data-offset other-pointer-lowtag ,scs ,element-type
105 (def-partial-data-vector-frobs (type element-type size signed &rest scs)
107 (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
108 ,size ,signed vector-data-offset other-pointer-lowtag ,scs
109 ,element-type data-vector-ref)
110 (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
111 ,size vector-data-offset other-pointer-lowtag ,scs
112 ,element-type data-vector-set))))
114 (def-full-data-vector-frobs simple-vector *
115 descriptor-reg any-reg null zero)
117 (def-partial-data-vector-frobs simple-base-string base-char
118 :byte nil base-char-reg)
120 (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
121 :byte nil unsigned-reg signed-reg)
122 (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
123 :byte nil unsigned-reg signed-reg)
125 (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
126 :short nil unsigned-reg signed-reg)
127 (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
128 :short nil unsigned-reg signed-reg)
130 (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
132 (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
135 (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
138 (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
141 (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum
143 (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num
146 (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
151 ;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit,
152 ;;; and 4-bit vectors.
155 (macrolet ((def-small-data-vector-frobs (type bits)
156 (let* ((elements-per-word (floor n-word-bits bits))
157 (bit-shift (1- (integer-length elements-per-word))))
159 (define-vop (,(symbolicate 'data-vector-ref/ type))
160 (:note "inline array access")
161 (:translate data-vector-ref)
163 (:args (object :scs (descriptor-reg))
164 (index :scs (unsigned-reg)))
165 (:arg-types ,type positive-fixnum)
166 (:results (value :scs (any-reg)))
167 (:result-types positive-fixnum)
168 (:temporary (:scs (interior-reg)) lip)
169 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
171 (inst srl temp index ,bit-shift)
173 (inst addu lip object temp)
175 (- (* vector-data-offset n-word-bytes)
176 other-pointer-lowtag))
177 (inst and temp index ,(1- elements-per-word))
178 ,@(when (eq *backend-byte-order* :big-endian)
179 `((inst xor temp ,(1- elements-per-word))))
181 `((inst sll temp ,(1- (integer-length bits)))))
182 (inst srl result temp)
183 (inst and result ,(1- (ash 1 bits)))
184 (inst sll value result 2)))
185 (define-vop (,(symbolicate 'data-vector-ref-c/ type))
186 (:translate data-vector-ref)
188 (:args (object :scs (descriptor-reg)))
192 ,(1- (* (1+ (- (floor (+ #x7fff
193 other-pointer-lowtag)
196 elements-per-word)))))
198 (:results (result :scs (unsigned-reg)))
199 (:result-types positive-fixnum)
201 (multiple-value-bind (word extra) (floor index ,elements-per-word)
202 ,@(when (eq *backend-byte-order* :big-endian)
203 `((setf extra (logxor extra (1- ,elements-per-word)))))
204 (loadw result object (+ word vector-data-offset)
205 other-pointer-lowtag)
206 (unless (zerop extra)
207 (inst srl result (* extra ,bits)))
208 (unless (= extra ,(1- elements-per-word))
209 (inst and result ,(1- (ash 1 bits)))))))
210 (define-vop (,(symbolicate 'data-vector-set/ type))
211 (:note "inline array store")
212 (:translate data-vector-set)
214 (:args (object :scs (descriptor-reg))
215 (index :scs (unsigned-reg) :target shift)
216 (value :scs (unsigned-reg zero immediate) :target result))
217 (:arg-types ,type positive-fixnum positive-fixnum)
218 (:results (result :scs (unsigned-reg)))
219 (:result-types positive-fixnum)
220 (:temporary (:scs (interior-reg)) lip)
221 (:temporary (:scs (non-descriptor-reg)) temp old)
222 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
224 (inst srl temp index ,bit-shift)
226 (inst addu lip object temp)
228 (- (* vector-data-offset n-word-bytes)
229 other-pointer-lowtag))
230 (inst and shift index ,(1- elements-per-word))
231 ,@(when (eq *backend-byte-order* :big-endian)
232 `((inst xor shift ,(1- elements-per-word))))
234 `((inst sll shift ,(1- (integer-length bits)))))
235 (unless (and (sc-is value immediate)
236 (= (tn-value value) ,(1- (ash 1 bits))))
237 (inst li temp ,(1- (ash 1 bits)))
238 (inst sll temp shift)
239 (inst nor temp temp zero-tn)
241 (unless (sc-is value zero)
244 (inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
246 (inst and temp value ,(1- (ash 1 bits)))))
247 (inst sll temp shift)
250 (- (* vector-data-offset n-word-bytes)
251 other-pointer-lowtag))
254 (inst li result (tn-value value)))
256 (move result zero-tn))
258 (move result value)))))
259 (define-vop (,(symbolicate 'data-vector-set-c/ type))
260 (:translate data-vector-set)
262 (:args (object :scs (descriptor-reg))
263 (value :scs (unsigned-reg zero immediate) :target result))
267 ,(1- (* (1+ (- (floor (+ #x7fff
268 other-pointer-lowtag)
271 elements-per-word))))
274 (:results (result :scs (unsigned-reg)))
275 (:result-types positive-fixnum)
276 (:temporary (:scs (non-descriptor-reg)) temp old)
278 (multiple-value-bind (word extra) (floor index ,elements-per-word)
279 ,@(when (eq *backend-byte-order* :big-endian)
280 `((setf extra (logxor extra (1- ,elements-per-word)))))
282 (- (* (+ word vector-data-offset) n-word-bytes)
283 other-pointer-lowtag))
284 (unless (and (sc-is value immediate)
285 (= (tn-value value) ,(1- (ash 1 bits))))
286 (cond ((= extra ,(1- elements-per-word))
288 (inst srl old ,bits))
291 (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))))
292 (inst and old temp))))
296 (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
298 (cond ((< value #x10000)
302 (inst or old temp)))))
304 (inst sll temp value (* extra ,bits))
307 (- (* (+ word vector-data-offset) n-word-bytes)
308 other-pointer-lowtag))
311 (inst li result (tn-value value)))
313 (move result zero-tn))
315 (move result value))))))))))
316 (def-small-data-vector-frobs simple-bit-vector 1)
317 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
318 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
321 ;;; And the float variants.
324 (define-vop (data-vector-ref/simple-array-single-float)
325 (:note "inline array access")
326 (:translate data-vector-ref)
328 (:args (object :scs (descriptor-reg))
329 (index :scs (any-reg)))
330 (:arg-types simple-array-single-float positive-fixnum)
331 (:results (value :scs (single-reg)))
332 (:result-types single-float)
333 (:temporary (:scs (interior-reg)) lip)
335 (inst addu lip object index)
337 (- (* vector-data-offset n-word-bytes)
338 other-pointer-lowtag))
341 (define-vop (data-vector-set/simple-array-single-float)
342 (:note "inline array store")
343 (:translate data-vector-set)
345 (:args (object :scs (descriptor-reg))
346 (index :scs (any-reg))
347 (value :scs (single-reg) :target result))
348 (:arg-types simple-array-single-float positive-fixnum single-float)
349 (:results (result :scs (single-reg)))
350 (:result-types single-float)
351 (:temporary (:scs (interior-reg)) lip)
353 (inst addu lip object index)
355 (- (* vector-data-offset n-word-bytes)
356 other-pointer-lowtag))
357 (unless (location= result value)
358 (inst fmove :single result value))))
360 (define-vop (data-vector-ref/simple-array-double-float)
361 (:note "inline array access")
362 (:translate data-vector-ref)
364 (:args (object :scs (descriptor-reg))
365 (index :scs (any-reg)))
366 (:arg-types simple-array-double-float positive-fixnum)
367 (:results (value :scs (double-reg)))
368 (:result-types double-float)
369 (:temporary (:scs (interior-reg)) lip)
371 (inst addu lip object index)
372 (inst addu lip index)
373 (ecase *backend-byte-order*
376 (+ (- (* vector-data-offset n-word-bytes)
377 other-pointer-lowtag)
379 (inst lwc1-odd value lip
380 (- (* vector-data-offset n-word-bytes)
381 other-pointer-lowtag)))
384 (- (* vector-data-offset n-word-bytes)
385 other-pointer-lowtag))
386 (inst lwc1-odd value lip
387 (+ (- (* vector-data-offset n-word-bytes)
388 other-pointer-lowtag)
392 (define-vop (data-vector-set/simple-array-double-float)
393 (:note "inline array store")
394 (:translate data-vector-set)
396 (:args (object :scs (descriptor-reg))
397 (index :scs (any-reg))
398 (value :scs (double-reg) :target result))
399 (:arg-types simple-array-double-float positive-fixnum double-float)
400 (:results (result :scs (double-reg)))
401 (:result-types double-float)
402 (:temporary (:scs (interior-reg)) lip)
404 (inst addu lip object index)
405 (inst addu lip index)
406 (ecase *backend-byte-order*
409 (+ (- (* vector-data-offset n-word-bytes)
410 other-pointer-lowtag)
412 (inst swc1-odd value lip
413 (- (* vector-data-offset n-word-bytes)
414 other-pointer-lowtag)))
417 (- (* vector-data-offset n-word-bytes)
418 other-pointer-lowtag))
419 (inst swc1-odd value lip
420 (+ (- (* vector-data-offset n-word-bytes)
421 other-pointer-lowtag)
423 (unless (location= result value)
424 (inst fmove :double result value))))
427 ;;; Complex float arrays.
429 (define-vop (data-vector-ref/simple-array-complex-single-float)
430 (:note "inline array access")
431 (:translate data-vector-ref)
433 (:args (object :scs (descriptor-reg))
434 (index :scs (any-reg)))
435 (:arg-types simple-array-complex-single-float positive-fixnum)
436 (:results (value :scs (complex-single-reg)))
437 (:temporary (:scs (interior-reg)) lip)
438 (:result-types complex-single-float)
440 (inst addu lip object index)
441 (inst addu lip index)
442 (let ((real-tn (complex-single-reg-real-tn value)))
443 (inst lwc1 real-tn lip (- (* vector-data-offset n-word-bytes)
444 other-pointer-lowtag)))
445 (let ((imag-tn (complex-single-reg-imag-tn value)))
446 (inst lwc1 imag-tn lip (- (* (1+ vector-data-offset) n-word-bytes)
447 other-pointer-lowtag)))
451 (define-vop (data-vector-set/simple-array-complex-single-float)
452 (:note "inline array store")
453 (:translate data-vector-set)
455 (:args (object :scs (descriptor-reg))
456 (index :scs (any-reg))
457 (value :scs (complex-single-reg) :target result))
458 (:arg-types simple-array-complex-single-float positive-fixnum
459 complex-single-float)
460 (:results (result :scs (complex-single-reg)))
461 (:result-types complex-single-float)
462 (:temporary (:scs (interior-reg)) lip)
464 (inst addu lip object index)
465 (inst addu lip index)
466 (let ((value-real (complex-single-reg-real-tn value))
467 (result-real (complex-single-reg-real-tn result)))
468 (inst swc1 value-real lip (- (* vector-data-offset n-word-bytes)
469 other-pointer-lowtag))
470 (unless (location= result-real value-real)
471 (inst fmove :single result-real value-real)))
472 (let ((value-imag (complex-single-reg-imag-tn value))
473 (result-imag (complex-single-reg-imag-tn result)))
474 (inst swc1 value-imag lip (- (* (1+ vector-data-offset) n-word-bytes)
475 other-pointer-lowtag))
476 (unless (location= result-imag value-imag)
477 (inst fmove :single result-imag value-imag)))))
479 (define-vop (data-vector-ref/simple-array-complex-double-float)
480 (:note "inline array access")
481 (:translate data-vector-ref)
483 (:args (object :scs (descriptor-reg))
484 (index :scs (any-reg) :target shift))
485 (:arg-types simple-array-complex-double-float positive-fixnum)
486 (:results (value :scs (complex-double-reg)))
487 (:result-types complex-double-float)
488 (:temporary (:scs (interior-reg)) lip)
489 (:temporary (:scs (any-reg) :from (:argument 1)) shift)
491 (inst sll shift index 2)
492 (inst addu lip object shift)
493 (let ((real-tn (complex-double-reg-real-tn value)))
494 (ld-double real-tn lip (- (* vector-data-offset n-word-bytes)
495 other-pointer-lowtag)))
496 (let ((imag-tn (complex-double-reg-imag-tn value)))
497 (ld-double imag-tn lip (- (* (+ vector-data-offset 2) n-word-bytes)
498 other-pointer-lowtag)))
501 (define-vop (data-vector-set/simple-array-complex-double-float)
502 (:note "inline array store")
503 (:translate data-vector-set)
505 (:args (object :scs (descriptor-reg))
506 (index :scs (any-reg) :target shift)
507 (value :scs (complex-double-reg) :target result))
508 (:arg-types simple-array-complex-double-float positive-fixnum
509 complex-double-float)
510 (:results (result :scs (complex-double-reg)))
511 (:result-types complex-double-float)
512 (:temporary (:scs (interior-reg)) lip)
513 (:temporary (:scs (any-reg) :from (:argument 1)) shift)
515 (inst sll shift index 2)
516 (inst addu lip object shift)
517 (let ((value-real (complex-double-reg-real-tn value))
518 (result-real (complex-double-reg-real-tn result)))
519 (str-double value-real lip (- (* vector-data-offset n-word-bytes)
520 other-pointer-lowtag))
521 (unless (location= result-real value-real)
522 (inst fmove :double result-real value-real)))
523 (let ((value-imag (complex-double-reg-imag-tn value))
524 (result-imag (complex-double-reg-imag-tn result)))
525 (str-double value-imag lip (- (* (+ vector-data-offset 2) n-word-bytes)
526 other-pointer-lowtag))
527 (unless (location= result-imag value-imag)
528 (inst fmove :double result-imag value-imag)))))
531 ;;; These VOPs are used for implementing float slots in structures (whose raw
532 ;;; data is an unsigned-32 vector.
534 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
535 (:translate %raw-ref-single)
536 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
538 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
539 (:translate %raw-set-single)
540 (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
542 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
543 (:translate %raw-ref-double)
544 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
546 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
547 (:translate %raw-set-double)
548 (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
550 (define-vop (raw-ref-complex-single
551 data-vector-ref/simple-array-complex-single-float)
552 (:translate %raw-ref-complex-single)
553 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
555 (define-vop (raw-set-complex-single
556 data-vector-set/simple-array-complex-single-float)
557 (:translate %raw-set-complex-single)
558 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
559 complex-single-float))
561 (define-vop (raw-ref-complex-double
562 data-vector-ref/simple-array-complex-double-float)
563 (:translate %raw-ref-complex-double)
564 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
566 (define-vop (raw-set-complex-double
567 data-vector-set/simple-array-complex-double-float)
568 (:translate %raw-set-complex-double)
569 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
570 complex-double-float))
572 ;;; These vops are useful for accessing the bits of a vector irrespective of
573 ;;; what type of vector it is.
576 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num
578 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
579 unsigned-num %set-raw-bits)
583 ;;;; Misc. Array VOPs.
585 (define-vop (get-vector-subtype get-header-data))
586 (define-vop (set-vector-subtype set-header-data))