4 ;;;; Allocator for the array header.
6 (define-vop (make-array-header)
8 (:translate make-array-header)
9 (:args (type :scs (any-reg))
10 (rank :scs (any-reg)))
11 (:arg-types positive-fixnum positive-fixnum)
12 (:temporary (:scs (any-reg)) bytes)
13 (:temporary (:scs (non-descriptor-reg)) header)
14 (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
15 (:results (result :scs (descriptor-reg)))
17 (inst addu bytes rank (+ (* array-dimensions-offset n-word-bytes)
19 (inst li header (lognot lowtag-mask))
20 (inst and bytes header)
21 (inst addu header rank (fixnumize (1- array-dimensions-offset)))
22 (inst sll header n-widetag-bits)
23 (inst or header header type)
25 (pseudo-atomic (pa-flag)
26 (inst or result alloc-tn other-pointer-lowtag)
27 (storew header result 0 other-pointer-lowtag)
28 (inst addu alloc-tn bytes))))
31 ;;;; Additional accessors and setters for the array header.
33 (defknown sb!impl::%array-dimension (t index) index
35 (defknown sb!impl::%set-array-dimension (t index index) index
38 (define-full-reffer %array-dimension *
39 array-dimensions-offset other-pointer-lowtag
40 (any-reg) positive-fixnum sb!impl::%array-dimension)
42 (define-full-setter %set-array-dimension *
43 array-dimensions-offset other-pointer-lowtag
44 (any-reg) positive-fixnum sb!impl::%set-array-dimension)
47 (defknown sb!impl::%array-rank (t) index (flushable))
49 (define-vop (array-rank-vop)
50 (:translate sb!impl::%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 2)))
63 ;;;; Bounds checking routine.
66 (define-vop (check-bound)
67 (:translate %check-bound)
69 (:args (array :scs (descriptor-reg))
70 (bound :scs (any-reg descriptor-reg))
71 (index :scs (any-reg descriptor-reg) :target result))
72 (:results (result :scs (any-reg descriptor-reg)))
73 (:temporary (:scs (non-descriptor-reg)) temp)
75 (:save-p :compute-only)
77 (let ((error (generate-error-code vop invalid-array-index-error
79 (inst sltu temp index bound)
80 (inst beq temp zero-tn error)
82 (move result index))))
86 ;;;; Accessors/Setters
88 ;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
89 ;;; elements are represented in integer registers and are built out of
90 ;;; 8, 16, or 32 bit elements.
92 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
94 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
95 vector-data-offset other-pointer-lowtag
96 ,(remove-if #'(lambda (x) (member x '(null zero))) scs)
99 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
100 vector-data-offset other-pointer-lowtag ,scs ,element-type
103 (def-partial-data-vector-frobs (type element-type size signed &rest scs)
105 (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
106 ,size ,signed vector-data-offset other-pointer-lowtag ,scs
107 ,element-type data-vector-ref)
108 (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
109 ,size vector-data-offset other-pointer-lowtag ,scs
110 ,element-type data-vector-set))))
112 (def-full-data-vector-frobs simple-vector *
113 descriptor-reg any-reg null zero)
115 (def-partial-data-vector-frobs simple-string base-char
116 :byte nil base-char-reg)
118 (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
119 :byte nil unsigned-reg signed-reg)
121 (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
122 :short nil unsigned-reg signed-reg)
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-signed-byte-30 tagged-num
136 (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.
145 (macrolet ((def-small-data-vector-frobs (type bits)
146 (let* ((elements-per-word (floor n-word-bits bits))
147 (bit-shift (1- (integer-length elements-per-word))))
149 (define-vop (,(symbolicate 'data-vector-ref/ type))
150 (:note "inline array access")
151 (:translate data-vector-ref)
153 (:args (object :scs (descriptor-reg))
154 (index :scs (unsigned-reg)))
155 (:arg-types ,type positive-fixnum)
156 (:results (value :scs (any-reg)))
157 (:result-types positive-fixnum)
158 (:temporary (:scs (interior-reg)) lip)
159 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
161 (inst srl temp index ,bit-shift)
163 (inst addu lip object temp)
165 (- (* vector-data-offset n-word-bytes)
166 other-pointer-lowtag))
167 (inst and temp index ,(1- elements-per-word))
168 ,@(when (eq *backend-byte-order* :big-endian)
169 `((inst xor temp ,(1- elements-per-word))))
171 `((inst sll temp ,(1- (integer-length bits)))))
172 (inst srl result temp)
173 (inst and result ,(1- (ash 1 bits)))
174 (inst sll value result 2)))
175 (define-vop (,(symbolicate 'data-vector-ref-c/ type))
176 (:translate data-vector-ref)
178 (:args (object :scs (descriptor-reg)))
182 ,(1- (* (1+ (- (floor (+ #x7fff
183 other-pointer-lowtag)
186 elements-per-word)))))
188 (:results (result :scs (unsigned-reg)))
189 (:result-types positive-fixnum)
191 (multiple-value-bind (word extra) (floor index ,elements-per-word)
192 ,@(when (eq *backend-byte-order* :big-endian)
193 `((setf extra (logxor extra (1- ,elements-per-word)))))
194 (loadw result object (+ word vector-data-offset)
195 other-pointer-lowtag)
196 (unless (zerop extra)
197 (inst srl result (* extra ,bits)))
198 (unless (= extra ,(1- elements-per-word))
199 (inst and result ,(1- (ash 1 bits)))))))
200 (define-vop (,(symbolicate 'data-vector-set/ type))
201 (:note "inline array store")
202 (:translate data-vector-set)
204 (:args (object :scs (descriptor-reg))
205 (index :scs (unsigned-reg) :target shift)
206 (value :scs (unsigned-reg zero immediate) :target result))
207 (:arg-types ,type positive-fixnum positive-fixnum)
208 (:results (result :scs (unsigned-reg)))
209 (:result-types positive-fixnum)
210 (:temporary (:scs (interior-reg)) lip)
211 (:temporary (:scs (non-descriptor-reg)) temp old)
212 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
214 (inst srl temp index ,bit-shift)
216 (inst addu lip object temp)
218 (- (* vector-data-offset n-word-bytes)
219 other-pointer-lowtag))
220 (inst and shift index ,(1- elements-per-word))
221 ,@(when (eq *backend-byte-order* :big-endian)
222 `((inst xor shift ,(1- elements-per-word))))
224 `((inst sll shift ,(1- (integer-length bits)))))
225 (unless (and (sc-is value immediate)
226 (= (tn-value value) ,(1- (ash 1 bits))))
227 (inst li temp ,(1- (ash 1 bits)))
228 (inst sll temp shift)
229 (inst nor temp temp zero-tn)
231 (unless (sc-is value zero)
234 (inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
236 (inst and temp value ,(1- (ash 1 bits)))))
237 (inst sll temp shift)
240 (- (* vector-data-offset n-word-bytes)
241 other-pointer-lowtag))
244 (inst li result (tn-value value)))
246 (move result zero-tn))
248 (move result value)))))
249 (define-vop (,(symbolicate 'data-vector-set-c/ type))
250 (:translate data-vector-set)
252 (:args (object :scs (descriptor-reg))
253 (value :scs (unsigned-reg zero immediate) :target result))
257 ,(1- (* (1+ (- (floor (+ #x7fff
258 other-pointer-lowtag)
261 elements-per-word))))
264 (:results (result :scs (unsigned-reg)))
265 (:result-types positive-fixnum)
266 (:temporary (:scs (non-descriptor-reg)) temp old)
268 (multiple-value-bind (word extra) (floor index ,elements-per-word)
269 ,@(when (eq *backend-byte-order* :big-endian)
270 `((setf extra (logxor extra (1- ,elements-per-word)))))
272 (- (* (+ word vector-data-offset) n-word-bytes)
273 other-pointer-lowtag))
274 (unless (and (sc-is value immediate)
275 (= (tn-value value) ,(1- (ash 1 bits))))
276 (cond ((= extra ,(1- elements-per-word))
278 (inst srl old ,bits))
281 (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))))
282 (inst and old temp))))
286 (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
288 (cond ((< value #x10000)
292 (inst or old temp)))))
294 (inst sll temp value (* extra ,bits))
297 (- (* (+ word vector-data-offset) n-word-bytes)
298 other-pointer-lowtag))
301 (inst li result (tn-value value)))
303 (move result zero-tn))
305 (move result value))))))))))
306 (def-small-data-vector-frobs simple-bit-vector 1)
307 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
308 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
311 ;;; And the float variants.
314 (define-vop (data-vector-ref/simple-array-single-float)
315 (:note "inline array access")
316 (:translate data-vector-ref)
318 (:args (object :scs (descriptor-reg))
319 (index :scs (any-reg)))
320 (:arg-types simple-array-single-float positive-fixnum)
321 (:results (value :scs (single-reg)))
322 (:result-types single-float)
323 (:temporary (:scs (interior-reg)) lip)
325 (inst addu lip object index)
327 (- (* vector-data-offset n-word-bytes)
328 other-pointer-lowtag))
331 (define-vop (data-vector-set/simple-array-single-float)
332 (:note "inline array store")
333 (:translate data-vector-set)
335 (:args (object :scs (descriptor-reg))
336 (index :scs (any-reg))
337 (value :scs (single-reg) :target result))
338 (:arg-types simple-array-single-float positive-fixnum single-float)
339 (:results (result :scs (single-reg)))
340 (:result-types single-float)
341 (:temporary (:scs (interior-reg)) lip)
343 (inst addu lip object index)
345 (- (* vector-data-offset n-word-bytes)
346 other-pointer-lowtag))
347 (unless (location= result value)
348 (inst fmove :single result value))))
350 (define-vop (data-vector-ref/simple-array-double-float)
351 (:note "inline array access")
352 (:translate data-vector-ref)
354 (:args (object :scs (descriptor-reg))
355 (index :scs (any-reg)))
356 (:arg-types simple-array-double-float positive-fixnum)
357 (:results (value :scs (double-reg)))
358 (:result-types double-float)
359 (:temporary (:scs (interior-reg)) lip)
361 (inst addu lip object index)
362 (inst addu lip index)
363 (ecase *backend-byte-order*
366 (+ (- (* vector-data-offset n-word-bytes)
367 other-pointer-lowtag)
369 (inst lwc1-odd value lip
370 (- (* vector-data-offset n-word-bytes)
371 other-pointer-lowtag)))
374 (- (* vector-data-offset n-word-bytes)
375 other-pointer-lowtag))
376 (inst lwc1-odd value lip
377 (+ (- (* vector-data-offset n-word-bytes)
378 other-pointer-lowtag)
382 (define-vop (data-vector-set/simple-array-double-float)
383 (:note "inline array store")
384 (:translate data-vector-set)
386 (:args (object :scs (descriptor-reg))
387 (index :scs (any-reg))
388 (value :scs (double-reg) :target result))
389 (:arg-types simple-array-double-float positive-fixnum double-float)
390 (:results (result :scs (double-reg)))
391 (:result-types double-float)
392 (:temporary (:scs (interior-reg)) lip)
394 (inst addu lip object index)
395 (inst addu lip index)
396 (ecase *backend-byte-order*
399 (+ (- (* vector-data-offset n-word-bytes)
400 other-pointer-lowtag)
402 (inst swc1-odd value lip
403 (- (* vector-data-offset n-word-bytes)
404 other-pointer-lowtag)))
407 (- (* vector-data-offset n-word-bytes)
408 other-pointer-lowtag))
409 (inst swc1-odd value lip
410 (+ (- (* vector-data-offset n-word-bytes)
411 other-pointer-lowtag)
413 (unless (location= result value)
414 (inst fmove :double result value))))
417 ;;; Complex float arrays.
419 (define-vop (data-vector-ref/simple-array-complex-single-float)
420 (:note "inline array access")
421 (:translate data-vector-ref)
423 (:args (object :scs (descriptor-reg))
424 (index :scs (any-reg)))
425 (:arg-types simple-array-complex-single-float positive-fixnum)
426 (:results (value :scs (complex-single-reg)))
427 (:temporary (:scs (interior-reg)) lip)
428 (:result-types complex-single-float)
430 (inst addu lip object index)
431 (inst addu lip index)
432 (let ((real-tn (complex-single-reg-real-tn value)))
433 (inst lwc1 real-tn lip (- (* vector-data-offset n-word-bytes)
434 other-pointer-lowtag)))
435 (let ((imag-tn (complex-single-reg-imag-tn value)))
436 (inst lwc1 imag-tn lip (- (* (1+ vector-data-offset) n-word-bytes)
437 other-pointer-lowtag)))
441 (define-vop (data-vector-set/simple-array-complex-single-float)
442 (:note "inline array store")
443 (:translate data-vector-set)
445 (:args (object :scs (descriptor-reg))
446 (index :scs (any-reg))
447 (value :scs (complex-single-reg) :target result))
448 (:arg-types simple-array-complex-single-float positive-fixnum
449 complex-single-float)
450 (:results (result :scs (complex-single-reg)))
451 (:result-types complex-single-float)
452 (:temporary (:scs (interior-reg)) lip)
454 (inst addu lip object index)
455 (inst addu lip index)
456 (let ((value-real (complex-single-reg-real-tn value))
457 (result-real (complex-single-reg-real-tn result)))
458 (inst swc1 value-real lip (- (* vector-data-offset n-word-bytes)
459 other-pointer-lowtag))
460 (unless (location= result-real value-real)
461 (inst fmove :single result-real value-real)))
462 (let ((value-imag (complex-single-reg-imag-tn value))
463 (result-imag (complex-single-reg-imag-tn result)))
464 (inst swc1 value-imag lip (- (* (1+ vector-data-offset) n-word-bytes)
465 other-pointer-lowtag))
466 (unless (location= result-imag value-imag)
467 (inst fmove :single result-imag value-imag)))))
469 (define-vop (data-vector-ref/simple-array-complex-double-float)
470 (:note "inline array access")
471 (:translate data-vector-ref)
473 (:args (object :scs (descriptor-reg))
474 (index :scs (any-reg) :target shift))
475 (:arg-types simple-array-complex-double-float positive-fixnum)
476 (:results (value :scs (complex-double-reg)))
477 (:result-types complex-double-float)
478 (:temporary (:scs (interior-reg)) lip)
479 (:temporary (:scs (any-reg) :from (:argument 1)) shift)
481 (inst sll shift index 2)
482 (inst addu lip object shift)
483 (let ((real-tn (complex-double-reg-real-tn value)))
484 (ld-double real-tn lip (- (* vector-data-offset n-word-bytes)
485 other-pointer-lowtag)))
486 (let ((imag-tn (complex-double-reg-imag-tn value)))
487 (ld-double imag-tn lip (- (* (+ vector-data-offset 2) n-word-bytes)
488 other-pointer-lowtag)))
491 (define-vop (data-vector-set/simple-array-complex-double-float)
492 (:note "inline array store")
493 (:translate data-vector-set)
495 (:args (object :scs (descriptor-reg))
496 (index :scs (any-reg) :target shift)
497 (value :scs (complex-double-reg) :target result))
498 (:arg-types simple-array-complex-double-float positive-fixnum
499 complex-double-float)
500 (:results (result :scs (complex-double-reg)))
501 (:result-types complex-double-float)
502 (:temporary (:scs (interior-reg)) lip)
503 (:temporary (:scs (any-reg) :from (:argument 1)) shift)
505 (inst sll shift index 2)
506 (inst addu lip object shift)
507 (let ((value-real (complex-double-reg-real-tn value))
508 (result-real (complex-double-reg-real-tn result)))
509 (str-double value-real lip (- (* vector-data-offset n-word-bytes)
510 other-pointer-lowtag))
511 (unless (location= result-real value-real)
512 (inst fmove :double result-real value-real)))
513 (let ((value-imag (complex-double-reg-imag-tn value))
514 (result-imag (complex-double-reg-imag-tn result)))
515 (str-double value-imag lip (- (* (+ vector-data-offset 2) n-word-bytes)
516 other-pointer-lowtag))
517 (unless (location= result-imag value-imag)
518 (inst fmove :double result-imag value-imag)))))
521 ;;; These VOPs are used for implementing float slots in structures (whose raw
522 ;;; data is an unsigned-32 vector.
524 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
525 (:translate %raw-ref-single)
526 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
528 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
529 (:translate %raw-set-single)
530 (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
532 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
533 (:translate %raw-ref-double)
534 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
536 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
537 (:translate %raw-set-double)
538 (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
540 (define-vop (raw-ref-complex-single
541 data-vector-ref/simple-array-complex-single-float)
542 (:translate %raw-ref-complex-single)
543 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
545 (define-vop (raw-set-complex-single
546 data-vector-set/simple-array-complex-single-float)
547 (:translate %raw-set-complex-single)
548 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
549 complex-single-float))
551 (define-vop (raw-ref-complex-double
552 data-vector-ref/simple-array-complex-double-float)
553 (:translate %raw-ref-complex-double)
554 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
556 (define-vop (raw-set-complex-double
557 data-vector-set/simple-array-complex-double-float)
558 (:translate %raw-set-complex-double)
559 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
560 complex-double-float))
562 ;;; These vops are useful for accessing the bits of a vector irrespective of
563 ;;; what type of vector it is.
566 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num
568 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
569 unsigned-num %set-raw-bits)
573 ;;;; Misc. Array VOPs.
575 (define-vop (get-vector-subtype get-header-data))
576 (define-vop (set-vector-subtype set-header-data))