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 (:results (result :scs (descriptor-reg)))
28 (pseudo-atomic (pa-flag)
29 (inst ori header alloc-tn other-pointer-lowtag)
30 (inst addi ndescr rank (* (1+ array-dimensions-offset) n-word-bytes))
31 (inst clrrwi ndescr ndescr n-lowtag-bits)
32 (inst add alloc-tn alloc-tn ndescr)
33 (inst addi ndescr rank (fixnumize (1- array-dimensions-offset)))
34 (inst slwi ndescr ndescr n-widetag-bits)
35 (inst or ndescr ndescr type)
36 (inst srwi ndescr ndescr n-fixnum-tag-bits)
37 (storew ndescr header 0 other-pointer-lowtag))
38 (move result header)))
41 ;;;; Additional accessors and setters for the array header.
42 (define-vop (%array-dimension word-index-ref)
43 (:translate sb!kernel:%array-dimension)
45 (:variant array-dimensions-offset other-pointer-lowtag))
47 (define-vop (%set-array-dimension word-index-set)
48 (:translate sb!kernel:%set-array-dimension)
50 (:variant array-dimensions-offset other-pointer-lowtag))
52 (define-vop (array-rank-vop)
53 (:translate sb!kernel:%array-rank)
55 (:args (x :scs (descriptor-reg)))
56 (:temporary (:scs (non-descriptor-reg)) temp)
57 (:results (res :scs (any-reg descriptor-reg)))
59 (loadw temp x 0 other-pointer-lowtag)
60 (inst srawi temp temp n-widetag-bits)
61 (inst subi temp temp (1- array-dimensions-offset))
62 (inst slwi res temp n-fixnum-tag-bits)))
64 ;;;; Bounds checking routine.
67 (define-vop (check-bound)
68 (:translate %check-bound)
70 (:args (array :scs (descriptor-reg))
71 (bound :scs (any-reg descriptor-reg))
72 (index :scs (any-reg descriptor-reg) :target result))
73 (:results (result :scs (any-reg descriptor-reg)))
75 (:save-p :compute-only)
77 (let ((error (generate-error-code vop invalid-array-index-error
79 (inst cmplw index bound)
81 (move result index))))
85 ;;;; Accessors/Setters
87 ;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
88 ;;; elements are represented in integer registers and are built out of
89 ;;; 8, 16, or 32 bit elements.
91 (macrolet ((def-data-vector-frobs (type variant element-type &rest scs)
93 (define-vop (,(symbolicate "DATA-VECTOR-REF/" (string type))
94 ,(symbolicate (string variant) "-REF"))
95 (:note "inline array access")
96 (:variant vector-data-offset other-pointer-lowtag)
97 (:translate data-vector-ref)
98 (:arg-types ,type positive-fixnum)
99 (:results (value :scs ,scs))
100 (:result-types ,element-type))
101 (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type))
102 ,(symbolicate (string variant) "-SET"))
103 (:note "inline array store")
104 (:variant vector-data-offset other-pointer-lowtag)
105 (:translate data-vector-set)
106 (:arg-types ,type positive-fixnum ,element-type)
107 (:args (object :scs (descriptor-reg))
108 (index :scs (any-reg zero immediate))
110 (:results (result :scs ,scs))
111 (:result-types ,element-type)))))
112 (def-data-vector-frobs simple-base-string byte-index
113 character character-reg)
115 (def-data-vector-frobs simple-character-string word-index
116 character character-reg)
117 (def-data-vector-frobs simple-vector word-index
118 * descriptor-reg any-reg)
119 (def-data-vector-frobs simple-array-unsigned-byte-7 byte-index
120 positive-fixnum unsigned-reg)
121 (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
122 positive-fixnum unsigned-reg)
123 (def-data-vector-frobs simple-array-unsigned-byte-15 halfword-index
124 positive-fixnum unsigned-reg)
125 (def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
126 positive-fixnum unsigned-reg)
127 (def-data-vector-frobs simple-array-unsigned-byte-31 word-index
128 unsigned-num unsigned-reg)
129 (def-data-vector-frobs simple-array-unsigned-byte-32 word-index
130 unsigned-num unsigned-reg)
132 (def-data-vector-frobs simple-array-unsigned-byte-29 word-index
133 positive-fixnum any-reg)
134 (def-data-vector-frobs simple-array-signed-byte-30 word-index
136 (def-data-vector-frobs simple-array-signed-byte-32 word-index
137 signed-num signed-reg))
140 ;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit,
141 ;;; 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 (non-descriptor-reg) :to (:result 0)) temp result)
159 ;; temp = (index >> bit-shift) << 2)
160 (inst rlwinm temp index ,(- 32 (- bit-shift 2)) ,(- bit-shift 2) 29)
161 (inst addi temp temp (- (* vector-data-offset n-word-bytes)
162 other-pointer-lowtag))
163 (inst lwzx result object temp)
164 (inst andi. temp index ,(1- elements-per-word))
165 (inst xori temp temp ,(1- elements-per-word))
167 `((inst slwi temp temp ,(1- (integer-length bits)))))
168 (inst srw result result temp)
169 (inst andi. result result ,(1- (ash 1 bits)))
170 (inst slwi value result n-fixnum-tag-bits)))
171 (define-vop (,(symbolicate 'data-vector-ref-c/ type))
172 (:translate data-vector-ref)
174 (:args (object :scs (descriptor-reg)))
175 (:arg-types ,type (:constant index))
177 (:results (result :scs (unsigned-reg)))
178 (:result-types positive-fixnum)
179 (:temporary (:scs (non-descriptor-reg)) temp)
181 (multiple-value-bind (word extra)
182 (floor index ,elements-per-word)
183 (setf extra (logxor extra (1- ,elements-per-word)))
184 (let ((offset (- (* (+ word vector-data-offset)
186 other-pointer-lowtag)))
187 (cond ((typep offset '(signed-byte 16))
188 (inst lwz result object offset))
190 (inst lr temp offset)
191 (inst lwzx result object temp))))
192 (unless (zerop extra)
193 (inst srwi result result (* ,bits extra)))
194 (unless (= extra ,(1- elements-per-word))
195 (inst andi. result result ,(1- (ash 1 bits)))))))
196 (define-vop (,(symbolicate 'data-vector-set/ type))
197 (:note "inline array store")
198 (:translate data-vector-set)
200 (:args (object :scs (descriptor-reg))
201 (index :scs (unsigned-reg) :target shift)
202 (value :scs (unsigned-reg zero immediate) :target result))
203 (:arg-types ,type positive-fixnum positive-fixnum)
204 (:results (result :scs (unsigned-reg)))
205 (:result-types positive-fixnum)
206 (:temporary (:scs (non-descriptor-reg)) temp old offset)
207 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
209 ;; offset = (index >> bit-shift) << 2)
210 (inst rlwinm offset index ,(- 32 (- bit-shift 2)) ,(- bit-shift 2) 29)
211 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
212 other-pointer-lowtag))
213 (inst lwzx old object offset)
214 (inst andi. shift index ,(1- elements-per-word))
215 (inst xori shift shift ,(1- elements-per-word))
217 `((inst slwi shift shift ,(1- (integer-length bits)))))
218 (unless (and (sc-is value immediate)
219 (= (tn-value value) ,(1- (ash 1 bits))))
220 (inst lr temp ,(1- (ash 1 bits)))
221 (inst slw temp temp shift)
222 (inst andc old old temp))
223 (unless (sc-is value zero)
226 (inst lr temp (logand (tn-value value) ,(1- (ash 1 bits)))))
228 (inst andi. temp value ,(1- (ash 1 bits)))))
229 (inst slw temp temp shift)
230 (inst or old old temp))
231 (inst stwx old object offset)
234 (inst lr result (tn-value value)))
236 (move result value)))))
237 (define-vop (,(symbolicate 'data-vector-set-c/ type))
238 (:translate data-vector-set)
240 (:args (object :scs (descriptor-reg))
241 (value :scs (unsigned-reg zero immediate) :target result))
246 (:results (result :scs (unsigned-reg)))
247 (:result-types positive-fixnum)
248 (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
250 (multiple-value-bind (word extra) (floor index ,elements-per-word)
251 (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
252 other-pointer-lowtag)))
253 (cond ((typep offset '(signed-byte 16))
254 (inst lwz old object offset))
256 (inst lr offset-reg offset)
257 (inst lwzx old object offset-reg)))
258 (unless (and (sc-is value immediate)
259 (= (tn-value value) ,(1- (ash 1 bits))))
261 (inst clrlwi old old ,bits))
264 (lognot (ash ,(1- (ash 1 bits))
266 ,(1- elements-per-word))
268 (inst and old old temp))))
272 (let ((value (ash (logand (tn-value value)
275 ,(1- elements-per-word))
277 (cond ((typep value '(unsigned-byte 16))
278 (inst ori old old value))
281 (inst or old old temp)))))
283 (inst slwi temp value
284 (* (logxor extra ,(1- elements-per-word)) ,bits))
285 (inst or old old temp)))
286 (if (typep offset '(signed-byte 16))
287 (inst stw old object offset)
288 (inst stwx old object offset-reg)))
291 (inst lr result (tn-value value)))
293 (move result value))))))))))
294 (def-small-data-vector-frobs simple-bit-vector 1)
295 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
296 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
299 ;;; And the float variants.
302 (define-vop (data-vector-ref/simple-array-single-float)
303 (:note "inline array access")
304 (:translate data-vector-ref)
306 (:args (object :scs (descriptor-reg))
307 (index :scs (any-reg)))
308 (:arg-types simple-array-single-float positive-fixnum)
309 (:results (value :scs (single-reg)))
310 (:temporary (:scs (non-descriptor-reg)) offset)
311 (:result-types single-float)
313 (inst addi offset index (- (* vector-data-offset n-word-bytes)
314 other-pointer-lowtag))
315 (inst lfsx value object offset)))
318 (define-vop (data-vector-set/simple-array-single-float)
319 (:note "inline array store")
320 (:translate data-vector-set)
322 (:args (object :scs (descriptor-reg))
323 (index :scs (any-reg))
324 (value :scs (single-reg) :target result))
325 (:arg-types simple-array-single-float positive-fixnum single-float)
326 (:results (result :scs (single-reg)))
327 (:result-types single-float)
328 (:temporary (:scs (non-descriptor-reg)) offset)
330 (inst addi offset index
331 (- (* vector-data-offset n-word-bytes)
332 other-pointer-lowtag))
333 (inst stfsx value object offset)
334 (unless (location= result value)
335 (inst frsp result value))))
337 (define-vop (data-vector-ref/simple-array-double-float)
338 (:note "inline array access")
339 (:translate data-vector-ref)
341 (:args (object :scs (descriptor-reg))
342 (index :scs (any-reg)))
343 (:arg-types simple-array-double-float positive-fixnum)
344 (:results (value :scs (double-reg)))
345 (:result-types double-float)
346 (:temporary (:scs (non-descriptor-reg)) offset)
348 (inst slwi offset index 1)
349 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
350 other-pointer-lowtag))
351 (inst lfdx value object offset)))
353 (define-vop (data-vector-set/simple-array-double-float)
354 (:note "inline array store")
355 (:translate data-vector-set)
357 (:args (object :scs (descriptor-reg))
358 (index :scs (any-reg))
359 (value :scs (double-reg) :target result))
360 (:arg-types simple-array-double-float positive-fixnum double-float)
361 (:results (result :scs (double-reg)))
362 (:result-types double-float)
363 (:temporary (:scs (non-descriptor-reg)) offset)
365 (inst slwi offset index 1)
366 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
367 other-pointer-lowtag))
368 (inst stfdx value object offset)
369 (unless (location= result value)
370 (inst fmr result value))))
373 ;;; Complex float arrays.
375 (define-vop (data-vector-ref/simple-array-complex-single-float)
376 (:note "inline array access")
377 (:translate data-vector-ref)
379 (:args (object :scs (descriptor-reg))
380 (index :scs (any-reg)))
381 (:arg-types simple-array-complex-single-float positive-fixnum)
382 (:results (value :scs (complex-single-reg)))
383 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
384 (:result-types complex-single-float)
386 (let ((real-tn (complex-single-reg-real-tn value)))
387 (inst slwi offset index 1)
388 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
389 other-pointer-lowtag))
390 (inst lfsx real-tn object offset))
391 (let ((imag-tn (complex-single-reg-imag-tn value)))
392 (inst addi offset offset n-word-bytes)
393 (inst lfsx imag-tn object offset))))
395 (define-vop (data-vector-set/simple-array-complex-single-float)
396 (:note "inline array store")
397 (:translate data-vector-set)
399 (:args (object :scs (descriptor-reg))
400 (index :scs (any-reg))
401 (value :scs (complex-single-reg) :target result))
402 (:arg-types simple-array-complex-single-float positive-fixnum
403 complex-single-float)
404 (:results (result :scs (complex-single-reg)))
405 (:result-types complex-single-float)
406 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
408 (let ((value-real (complex-single-reg-real-tn value))
409 (result-real (complex-single-reg-real-tn result)))
410 (inst slwi offset index 1)
411 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
412 other-pointer-lowtag))
413 (inst stfsx value-real object offset)
414 (unless (location= result-real value-real)
415 (inst frsp result-real value-real)))
416 (let ((value-imag (complex-single-reg-imag-tn value))
417 (result-imag (complex-single-reg-imag-tn result)))
418 (inst addi offset offset n-word-bytes)
419 (inst stfsx value-imag object offset)
420 (unless (location= result-imag value-imag)
421 (inst frsp result-imag value-imag)))))
424 (define-vop (data-vector-ref/simple-array-complex-double-float)
425 (:note "inline array access")
426 (:translate data-vector-ref)
428 (:args (object :scs (descriptor-reg) :to :result)
429 (index :scs (any-reg)))
430 (:arg-types simple-array-complex-double-float positive-fixnum)
431 (:results (value :scs (complex-double-reg)))
432 (:result-types complex-double-float)
433 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
435 (let ((real-tn (complex-double-reg-real-tn value)))
436 (inst slwi offset index 2)
437 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
438 other-pointer-lowtag))
439 (inst lfdx real-tn object offset))
440 (let ((imag-tn (complex-double-reg-imag-tn value)))
441 (inst addi offset offset (* 2 n-word-bytes))
442 (inst lfdx imag-tn object offset))))
444 (define-vop (data-vector-set/simple-array-complex-double-float)
445 (:note "inline array store")
446 (:translate data-vector-set)
448 (:args (object :scs (descriptor-reg) :to :result)
449 (index :scs (any-reg))
450 (value :scs (complex-double-reg) :target result))
451 (:arg-types simple-array-complex-double-float positive-fixnum
452 complex-double-float)
453 (:results (result :scs (complex-double-reg)))
454 (:result-types complex-double-float)
455 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
457 (let ((value-real (complex-double-reg-real-tn value))
458 (result-real (complex-double-reg-real-tn result)))
459 (inst slwi offset index 2)
460 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
461 other-pointer-lowtag))
462 (inst stfdx value-real object offset)
463 (unless (location= result-real value-real)
464 (inst fmr result-real value-real)))
465 (let ((value-imag (complex-double-reg-imag-tn value))
466 (result-imag (complex-double-reg-imag-tn result)))
467 (inst addi offset offset (* 2 n-word-bytes))
468 (inst stfdx value-imag object offset)
469 (unless (location= result-imag value-imag)
470 (inst fmr result-imag value-imag)))))
473 ;;; These VOPs are used for implementing float slots in structures (whose raw
474 ;;; data is an unsigned-32 vector.
476 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
477 (:translate %raw-ref-single)
478 (:arg-types sb!c::raw-vector positive-fixnum))
480 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
481 (:translate %raw-set-single)
482 (:arg-types sb!c::raw-vector positive-fixnum single-float))
484 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
485 (:translate %raw-ref-double)
486 (:arg-types sb!c::raw-vector positive-fixnum))
488 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
489 (:translate %raw-set-double)
490 (:arg-types sb!c::raw-vector positive-fixnum double-float))
492 (define-vop (raw-ref-complex-single
493 data-vector-ref/simple-array-complex-single-float)
494 (:translate %raw-ref-complex-single)
495 (:arg-types sb!c::raw-vector positive-fixnum))
497 (define-vop (raw-set-complex-single
498 data-vector-set/simple-array-complex-single-float)
499 (:translate %raw-set-complex-single)
500 (:arg-types sb!c::raw-vector positive-fixnum complex-single-float))
502 (define-vop (raw-ref-complex-double
503 data-vector-ref/simple-array-complex-double-float)
504 (:translate %raw-ref-complex-double)
505 (:arg-types sb!c::raw-vector positive-fixnum))
507 (define-vop (raw-set-complex-double
508 data-vector-set/simple-array-complex-double-float)
509 (:translate %raw-set-complex-double)
510 (:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
513 ;;; These vops are useful for accessing the bits of a vector irrespective of
514 ;;; what type of vector it is.
517 (define-vop (raw-bits word-index-ref)
518 (:note "raw-bits VOP")
519 (:translate %raw-bits)
520 (:results (value :scs (unsigned-reg)))
521 (:result-types unsigned-num)
522 (:variant 0 other-pointer-lowtag))
524 (define-vop (set-raw-bits word-index-set)
525 (:note "setf raw-bits VOP")
526 (:translate %set-raw-bits)
527 (:args (object :scs (descriptor-reg))
528 (index :scs (any-reg zero immediate))
529 (value :scs (unsigned-reg)))
530 (:arg-types * positive-fixnum unsigned-num)
531 (:results (result :scs (unsigned-reg)))
532 (:result-types unsigned-num)
533 (:variant 0 other-pointer-lowtag))
535 (define-vop (vector-raw-bits word-index-ref)
536 (:note "vector-raw-bits VOP")
537 (:translate %vector-raw-bits)
538 (:results (value :scs (unsigned-reg)))
539 (:result-types unsigned-num)
540 (:variant vector-data-offset other-pointer-lowtag))
542 (define-vop (set-vector-raw-bits word-index-set)
543 (:note "setf vector-raw-bits VOP")
544 (:translate %set-vector-raw-bits)
545 (:args (object :scs (descriptor-reg))
546 (index :scs (any-reg zero immediate))
547 (value :scs (unsigned-reg)))
548 (:arg-types * positive-fixnum unsigned-num)
549 (:results (result :scs (unsigned-reg)))
550 (:result-types unsigned-num)
551 (:variant vector-data-offset other-pointer-lowtag))
553 ;;;; Misc. Array VOPs.
557 (define-vop (vector-word-length)
558 (:args (vec :scs (descriptor-reg)))
559 (:results (res :scs (any-reg descriptor-reg)))
561 (loadw res vec clc::g-vector-header-words)
562 (inst niuo res res clc::g-vector-words-mask-16)))
564 (define-vop (get-vector-subtype get-header-data))
565 (define-vop (set-vector-subtype set-header-data))
570 (define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref)
571 (:note "inline array access")
572 (:variant vector-data-offset other-pointer-lowtag)
573 (:translate data-vector-ref)
574 (:arg-types simple-array-signed-byte-8 positive-fixnum)
575 (:results (value :scs (signed-reg)))
576 (:result-types tagged-num))
578 (define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set)
579 (:note "inline array store")
580 (:variant vector-data-offset other-pointer-lowtag)
581 (:translate data-vector-set)
582 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
583 (:args (object :scs (descriptor-reg))
584 (index :scs (any-reg zero immediate))
585 (value :scs (signed-reg)))
586 (:results (result :scs (signed-reg)))
587 (:result-types tagged-num))
589 (define-vop (data-vector-ref/simple-array-signed-byte-16
590 signed-halfword-index-ref)
591 (:note "inline array access")
592 (:variant vector-data-offset other-pointer-lowtag)
593 (:translate data-vector-ref)
594 (:arg-types simple-array-signed-byte-16 positive-fixnum)
595 (:results (value :scs (signed-reg)))
596 (:result-types tagged-num))
598 (define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set)
599 (:note "inline array store")
600 (:variant vector-data-offset other-pointer-lowtag)
601 (:translate data-vector-set)
602 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
603 (:args (object :scs (descriptor-reg))
604 (index :scs (any-reg zero immediate))
605 (value :scs (signed-reg)))
606 (:results (result :scs (signed-reg)))
607 (:result-types tagged-num))