1 ;;;; array operations for the PPC VM
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)
18 (:translate make-array-header)
20 (:args (type :scs (any-reg))
21 (rank :scs (any-reg)))
22 (:arg-types tagged-num tagged-num)
23 (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
24 (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
25 (:temporary (:scs (non-descriptor-reg)) ndescr)
26 (:temporary (:scs (non-descriptor-reg)) gc-temp)
27 #!-gencgc (:ignore gc-temp)
28 (:results (result :scs (descriptor-reg)))
30 (pseudo-atomic (pa-flag)
31 (inst addi ndescr rank (* (1+ array-dimensions-offset) n-word-bytes))
32 (inst clrrwi ndescr ndescr n-lowtag-bits)
33 (allocation header ndescr other-pointer-lowtag
36 (inst addi ndescr rank (fixnumize (1- array-dimensions-offset)))
37 (inst slwi ndescr ndescr n-widetag-bits)
38 (inst or ndescr ndescr type)
39 (inst srwi ndescr ndescr n-fixnum-tag-bits)
40 (storew ndescr header 0 other-pointer-lowtag))
41 (move result header)))
44 ;;;; Additional accessors and setters for the array header.
45 (define-vop (%array-dimension word-index-ref)
46 (:translate sb!kernel:%array-dimension)
48 (:variant array-dimensions-offset other-pointer-lowtag))
50 (define-vop (%set-array-dimension word-index-set)
51 (:translate sb!kernel:%set-array-dimension)
53 (:variant array-dimensions-offset other-pointer-lowtag))
55 (define-vop (array-rank-vop)
56 (:translate sb!kernel:%array-rank)
58 (:args (x :scs (descriptor-reg)))
59 (:temporary (:scs (non-descriptor-reg)) temp)
60 (:results (res :scs (any-reg descriptor-reg)))
62 (loadw temp x 0 other-pointer-lowtag)
63 (inst srawi temp temp n-widetag-bits)
64 (inst subi temp temp (1- array-dimensions-offset))
65 (inst slwi res temp n-fixnum-tag-bits)))
67 ;;;; Bounds checking routine.
70 (define-vop (check-bound)
71 (:translate %check-bound)
73 (:args (array :scs (descriptor-reg))
74 (bound :scs (any-reg descriptor-reg))
75 (index :scs (any-reg descriptor-reg) :target result))
76 (:results (result :scs (any-reg descriptor-reg)))
78 (:save-p :compute-only)
80 (let ((error (generate-error-code vop invalid-array-index-error
82 (inst cmplw index bound)
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-data-vector-frobs (type variant element-type &rest scs)
96 (define-vop (,(symbolicate "DATA-VECTOR-REF/" (string type))
97 ,(symbolicate (string variant) "-REF"))
98 (:note "inline array access")
99 (:variant vector-data-offset other-pointer-lowtag)
100 (:translate data-vector-ref)
101 (:arg-types ,type positive-fixnum)
102 (:results (value :scs ,scs))
103 (:result-types ,element-type))
104 (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type))
105 ,(symbolicate (string variant) "-SET"))
106 (:note "inline array store")
107 (:variant vector-data-offset other-pointer-lowtag)
108 (:translate data-vector-set)
109 (:arg-types ,type positive-fixnum ,element-type)
110 (:args (object :scs (descriptor-reg))
111 (index :scs (any-reg zero immediate))
113 (:results (result :scs ,scs))
114 (:result-types ,element-type)))))
115 (def-data-vector-frobs simple-base-string byte-index
116 character character-reg)
118 (def-data-vector-frobs simple-character-string word-index
119 character character-reg)
120 (def-data-vector-frobs simple-vector word-index
121 * descriptor-reg any-reg)
122 (def-data-vector-frobs simple-array-unsigned-byte-7 byte-index
123 positive-fixnum unsigned-reg)
124 (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
125 positive-fixnum unsigned-reg)
126 (def-data-vector-frobs simple-array-unsigned-byte-15 halfword-index
127 positive-fixnum unsigned-reg)
128 (def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
129 positive-fixnum unsigned-reg)
130 (def-data-vector-frobs simple-array-unsigned-byte-31 word-index
131 unsigned-num unsigned-reg)
132 (def-data-vector-frobs simple-array-unsigned-byte-32 word-index
133 unsigned-num unsigned-reg)
135 (def-data-vector-frobs simple-array-unsigned-byte-29 word-index
136 positive-fixnum any-reg)
137 (def-data-vector-frobs simple-array-signed-byte-30 word-index
139 (def-data-vector-frobs simple-array-signed-byte-32 word-index
140 signed-num signed-reg))
143 ;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit,
144 ;;; and 4-bit vectors.
147 (macrolet ((def-small-data-vector-frobs (type bits)
148 (let* ((elements-per-word (floor n-word-bits bits))
149 (bit-shift (1- (integer-length elements-per-word))))
151 (define-vop (,(symbolicate 'data-vector-ref/ type))
152 (:note "inline array access")
153 (:translate data-vector-ref)
155 (:args (object :scs (descriptor-reg))
156 (index :scs (unsigned-reg)))
157 (:arg-types ,type positive-fixnum)
158 (:results (value :scs (any-reg)))
159 (:result-types positive-fixnum)
160 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
162 ;; temp = (index >> bit-shift) << 2)
163 (inst rlwinm temp index ,(- 32 (- bit-shift 2)) ,(- bit-shift 2) 29)
164 (inst addi temp temp (- (* vector-data-offset n-word-bytes)
165 other-pointer-lowtag))
166 (inst lwzx result object temp)
167 (inst andi. temp index ,(1- elements-per-word))
168 (inst xori temp temp ,(1- elements-per-word))
170 `((inst slwi temp temp ,(1- (integer-length bits)))))
171 (inst srw result result temp)
172 (inst andi. result result ,(1- (ash 1 bits)))
173 (inst slwi 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)))
178 (:arg-types ,type (:constant index))
180 (:results (result :scs (unsigned-reg)))
181 (:result-types positive-fixnum)
182 (:temporary (:scs (non-descriptor-reg)) temp)
184 (multiple-value-bind (word extra)
185 (floor index ,elements-per-word)
186 (setf extra (logxor extra (1- ,elements-per-word)))
187 (let ((offset (- (* (+ word vector-data-offset)
189 other-pointer-lowtag)))
190 (cond ((typep offset '(signed-byte 16))
191 (inst lwz result object offset))
193 (inst lr temp offset)
194 (inst lwzx result object temp))))
195 (unless (zerop extra)
196 (inst srwi result result (* ,bits extra)))
197 (unless (= extra ,(1- elements-per-word))
198 (inst andi. result 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 (non-descriptor-reg)) temp old offset)
210 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
212 ;; offset = (index >> bit-shift) << 2)
213 (inst rlwinm offset index ,(- 32 (- bit-shift 2)) ,(- bit-shift 2) 29)
214 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
215 other-pointer-lowtag))
216 (inst lwzx old object offset)
217 (inst andi. shift index ,(1- elements-per-word))
218 (inst xori shift shift ,(1- elements-per-word))
220 `((inst slwi shift shift ,(1- (integer-length bits)))))
221 (unless (and (sc-is value immediate)
222 (= (tn-value value) ,(1- (ash 1 bits))))
223 (inst lr temp ,(1- (ash 1 bits)))
224 (inst slw temp temp shift)
225 (inst andc old old temp))
226 (unless (sc-is value zero)
229 (inst lr temp (logand (tn-value value) ,(1- (ash 1 bits)))))
231 (inst andi. temp value ,(1- (ash 1 bits)))))
232 (inst slw temp temp shift)
233 (inst or old old temp))
234 (inst stwx old object offset)
237 (inst lr result (tn-value value)))
239 (move result value)))))
240 (define-vop (,(symbolicate 'data-vector-set-c/ type))
241 (:translate data-vector-set)
243 (:args (object :scs (descriptor-reg))
244 (value :scs (unsigned-reg zero immediate) :target result))
249 (:results (result :scs (unsigned-reg)))
250 (:result-types positive-fixnum)
251 (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
253 (multiple-value-bind (word extra) (floor index ,elements-per-word)
254 (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
255 other-pointer-lowtag)))
256 (cond ((typep offset '(signed-byte 16))
257 (inst lwz old object offset))
259 (inst lr offset-reg offset)
260 (inst lwzx old object offset-reg)))
261 (unless (and (sc-is value immediate)
262 (= (tn-value value) ,(1- (ash 1 bits))))
264 (inst clrlwi old old ,bits))
267 (lognot (ash ,(1- (ash 1 bits))
269 ,(1- elements-per-word))
271 (inst and old old temp))))
275 (let ((value (ash (logand (tn-value value)
278 ,(1- elements-per-word))
280 (cond ((typep value '(unsigned-byte 16))
281 (inst ori old old value))
284 (inst or old old temp)))))
286 (inst slwi temp value
287 (* (logxor extra ,(1- elements-per-word)) ,bits))
288 (inst or old old temp)))
289 (if (typep offset '(signed-byte 16))
290 (inst stw old object offset)
291 (inst stwx old object offset-reg)))
294 (inst lr result (tn-value value)))
296 (move result value))))))))))
297 (def-small-data-vector-frobs simple-bit-vector 1)
298 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
299 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
302 ;;; And the float variants.
305 (define-vop (data-vector-ref/simple-array-single-float)
306 (:note "inline array access")
307 (:translate data-vector-ref)
309 (:args (object :scs (descriptor-reg))
310 (index :scs (any-reg)))
311 (:arg-types simple-array-single-float positive-fixnum)
312 (:results (value :scs (single-reg)))
313 (:temporary (:scs (non-descriptor-reg)) offset)
314 (:result-types single-float)
316 (inst addi offset index (- (* vector-data-offset n-word-bytes)
317 other-pointer-lowtag))
318 (inst lfsx value object offset)))
321 (define-vop (data-vector-set/simple-array-single-float)
322 (:note "inline array store")
323 (:translate data-vector-set)
325 (:args (object :scs (descriptor-reg))
326 (index :scs (any-reg))
327 (value :scs (single-reg) :target result))
328 (:arg-types simple-array-single-float positive-fixnum single-float)
329 (:results (result :scs (single-reg)))
330 (:result-types single-float)
331 (:temporary (:scs (non-descriptor-reg)) offset)
333 (inst addi offset index
334 (- (* vector-data-offset n-word-bytes)
335 other-pointer-lowtag))
336 (inst stfsx value object offset)
337 (unless (location= result value)
338 (inst frsp result value))))
340 (define-vop (data-vector-ref/simple-array-double-float)
341 (:note "inline array access")
342 (:translate data-vector-ref)
344 (:args (object :scs (descriptor-reg))
345 (index :scs (any-reg)))
346 (:arg-types simple-array-double-float positive-fixnum)
347 (:results (value :scs (double-reg)))
348 (:result-types double-float)
349 (:temporary (:scs (non-descriptor-reg)) offset)
351 (inst slwi offset index 1)
352 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
353 other-pointer-lowtag))
354 (inst lfdx value object offset)))
356 (define-vop (data-vector-set/simple-array-double-float)
357 (:note "inline array store")
358 (:translate data-vector-set)
360 (:args (object :scs (descriptor-reg))
361 (index :scs (any-reg))
362 (value :scs (double-reg) :target result))
363 (:arg-types simple-array-double-float positive-fixnum double-float)
364 (:results (result :scs (double-reg)))
365 (:result-types double-float)
366 (:temporary (:scs (non-descriptor-reg)) offset)
368 (inst slwi offset index 1)
369 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
370 other-pointer-lowtag))
371 (inst stfdx value object offset)
372 (unless (location= result value)
373 (inst fmr result value))))
376 ;;; Complex float arrays.
378 (define-vop (data-vector-ref/simple-array-complex-single-float)
379 (:note "inline array access")
380 (:translate data-vector-ref)
382 (:args (object :scs (descriptor-reg))
383 (index :scs (any-reg)))
384 (:arg-types simple-array-complex-single-float positive-fixnum)
385 (:results (value :scs (complex-single-reg)))
386 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
387 (:result-types complex-single-float)
389 (let ((real-tn (complex-single-reg-real-tn value)))
390 (inst slwi offset index 1)
391 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
392 other-pointer-lowtag))
393 (inst lfsx real-tn object offset))
394 (let ((imag-tn (complex-single-reg-imag-tn value)))
395 (inst addi offset offset n-word-bytes)
396 (inst lfsx imag-tn object offset))))
398 (define-vop (data-vector-set/simple-array-complex-single-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 (complex-single-reg) :target result))
405 (:arg-types simple-array-complex-single-float positive-fixnum
406 complex-single-float)
407 (:results (result :scs (complex-single-reg)))
408 (:result-types complex-single-float)
409 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
411 (let ((value-real (complex-single-reg-real-tn value))
412 (result-real (complex-single-reg-real-tn result)))
413 (inst slwi offset index 1)
414 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
415 other-pointer-lowtag))
416 (inst stfsx value-real object offset)
417 (unless (location= result-real value-real)
418 (inst frsp result-real value-real)))
419 (let ((value-imag (complex-single-reg-imag-tn value))
420 (result-imag (complex-single-reg-imag-tn result)))
421 (inst addi offset offset n-word-bytes)
422 (inst stfsx value-imag object offset)
423 (unless (location= result-imag value-imag)
424 (inst frsp result-imag value-imag)))))
427 (define-vop (data-vector-ref/simple-array-complex-double-float)
428 (:note "inline array access")
429 (:translate data-vector-ref)
431 (:args (object :scs (descriptor-reg) :to :result)
432 (index :scs (any-reg)))
433 (:arg-types simple-array-complex-double-float positive-fixnum)
434 (:results (value :scs (complex-double-reg)))
435 (:result-types complex-double-float)
436 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
438 (let ((real-tn (complex-double-reg-real-tn value)))
439 (inst slwi offset index 2)
440 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
441 other-pointer-lowtag))
442 (inst lfdx real-tn object offset))
443 (let ((imag-tn (complex-double-reg-imag-tn value)))
444 (inst addi offset offset (* 2 n-word-bytes))
445 (inst lfdx imag-tn object offset))))
447 (define-vop (data-vector-set/simple-array-complex-double-float)
448 (:note "inline array store")
449 (:translate data-vector-set)
451 (:args (object :scs (descriptor-reg) :to :result)
452 (index :scs (any-reg))
453 (value :scs (complex-double-reg) :target result))
454 (:arg-types simple-array-complex-double-float positive-fixnum
455 complex-double-float)
456 (:results (result :scs (complex-double-reg)))
457 (:result-types complex-double-float)
458 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
460 (let ((value-real (complex-double-reg-real-tn value))
461 (result-real (complex-double-reg-real-tn result)))
462 (inst slwi offset index 2)
463 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
464 other-pointer-lowtag))
465 (inst stfdx value-real object offset)
466 (unless (location= result-real value-real)
467 (inst fmr result-real value-real)))
468 (let ((value-imag (complex-double-reg-imag-tn value))
469 (result-imag (complex-double-reg-imag-tn result)))
470 (inst addi offset offset (* 2 n-word-bytes))
471 (inst stfdx value-imag object offset)
472 (unless (location= result-imag value-imag)
473 (inst fmr result-imag value-imag)))))
476 ;;; These VOPs are used for implementing float slots in structures (whose raw
477 ;;; data is an unsigned-32 vector.
479 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
480 (:translate %raw-ref-single)
481 (:arg-types sb!c::raw-vector positive-fixnum))
483 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
484 (:translate %raw-set-single)
485 (:arg-types sb!c::raw-vector positive-fixnum single-float))
487 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
488 (:translate %raw-ref-double)
489 (:arg-types sb!c::raw-vector positive-fixnum))
491 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
492 (:translate %raw-set-double)
493 (:arg-types sb!c::raw-vector positive-fixnum double-float))
495 (define-vop (raw-ref-complex-single
496 data-vector-ref/simple-array-complex-single-float)
497 (:translate %raw-ref-complex-single)
498 (:arg-types sb!c::raw-vector positive-fixnum))
500 (define-vop (raw-set-complex-single
501 data-vector-set/simple-array-complex-single-float)
502 (:translate %raw-set-complex-single)
503 (:arg-types sb!c::raw-vector positive-fixnum complex-single-float))
505 (define-vop (raw-ref-complex-double
506 data-vector-ref/simple-array-complex-double-float)
507 (:translate %raw-ref-complex-double)
508 (:arg-types sb!c::raw-vector positive-fixnum))
510 (define-vop (raw-set-complex-double
511 data-vector-set/simple-array-complex-double-float)
512 (:translate %raw-set-complex-double)
513 (:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
516 ;;; These vops are useful for accessing the bits of a vector irrespective of
517 ;;; what type of vector it is.
520 (define-vop (raw-bits word-index-ref)
521 (:note "raw-bits VOP")
522 (:translate %raw-bits)
523 (:results (value :scs (unsigned-reg)))
524 (:result-types unsigned-num)
525 (:variant 0 other-pointer-lowtag))
527 (define-vop (set-raw-bits word-index-set)
528 (:note "setf raw-bits VOP")
529 (:translate %set-raw-bits)
530 (:args (object :scs (descriptor-reg))
531 (index :scs (any-reg zero immediate))
532 (value :scs (unsigned-reg)))
533 (:arg-types * positive-fixnum unsigned-num)
534 (:results (result :scs (unsigned-reg)))
535 (:result-types unsigned-num)
536 (:variant 0 other-pointer-lowtag))
538 (define-vop (vector-raw-bits word-index-ref)
539 (:note "vector-raw-bits VOP")
540 (:translate %vector-raw-bits)
541 (:results (value :scs (unsigned-reg)))
542 (:result-types unsigned-num)
543 (:variant vector-data-offset other-pointer-lowtag))
545 (define-vop (set-vector-raw-bits word-index-set)
546 (:note "setf vector-raw-bits VOP")
547 (:translate %set-vector-raw-bits)
548 (:args (object :scs (descriptor-reg))
549 (index :scs (any-reg zero immediate))
550 (value :scs (unsigned-reg)))
551 (:arg-types * positive-fixnum unsigned-num)
552 (:results (result :scs (unsigned-reg)))
553 (:result-types unsigned-num)
554 (:variant vector-data-offset other-pointer-lowtag))
556 ;;;; Misc. Array VOPs.
560 (define-vop (vector-word-length)
561 (:args (vec :scs (descriptor-reg)))
562 (:results (res :scs (any-reg descriptor-reg)))
564 (loadw res vec clc::g-vector-header-words)
565 (inst niuo res res clc::g-vector-words-mask-16)))
567 (define-vop (get-vector-subtype get-header-data))
568 (define-vop (set-vector-subtype set-header-data))
573 (define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref)
574 (:note "inline array access")
575 (:variant vector-data-offset other-pointer-lowtag)
576 (:translate data-vector-ref)
577 (:arg-types simple-array-signed-byte-8 positive-fixnum)
578 (:results (value :scs (signed-reg)))
579 (:result-types tagged-num))
581 (define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set)
582 (:note "inline array store")
583 (:variant vector-data-offset other-pointer-lowtag)
584 (:translate data-vector-set)
585 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
586 (:args (object :scs (descriptor-reg))
587 (index :scs (any-reg zero immediate))
588 (value :scs (signed-reg)))
589 (:results (result :scs (signed-reg)))
590 (:result-types tagged-num))
592 (define-vop (data-vector-ref/simple-array-signed-byte-16
593 signed-halfword-index-ref)
594 (:note "inline array access")
595 (:variant vector-data-offset other-pointer-lowtag)
596 (:translate data-vector-ref)
597 (:arg-types simple-array-signed-byte-16 positive-fixnum)
598 (:results (value :scs (signed-reg)))
599 (:result-types tagged-num))
601 (define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set)
602 (:note "inline array store")
603 (:variant vector-data-offset other-pointer-lowtag)
604 (:translate data-vector-set)
605 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
606 (:args (object :scs (descriptor-reg))
607 (index :scs (any-reg zero immediate))
608 (value :scs (signed-reg)))
609 (:results (result :scs (signed-reg)))
610 (:result-types tagged-num))