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
(+ (* array-dimensions-offset n-word-bytes
)
33 (inst clrrwi ndescr ndescr n-lowtag-bits
)
34 (allocation header ndescr other-pointer-lowtag
37 (inst addi ndescr rank
(fixnumize (1- array-dimensions-offset
)))
38 (inst slwi ndescr ndescr n-widetag-bits
)
39 (inst or ndescr ndescr type
)
40 (inst srwi ndescr ndescr n-fixnum-tag-bits
)
41 (storew ndescr header
0 other-pointer-lowtag
))
42 (move result header
)))
45 ;;;; Additional accessors and setters for the array header.
46 (define-vop (%array-dimension word-index-ref
)
47 (:translate %array-dimension
)
49 (:variant array-dimensions-offset other-pointer-lowtag
))
51 (define-vop (%set-array-dimension word-index-set
)
52 (:translate %set-array-dimension
)
54 (:variant array-dimensions-offset other-pointer-lowtag
))
56 (define-vop (array-rank-vop)
57 (:translate %array-rank
)
59 (:args
(x :scs
(descriptor-reg)))
60 (:temporary
(:scs
(non-descriptor-reg)) temp
)
61 (:results
(res :scs
(any-reg descriptor-reg
)))
63 (loadw temp x
0 other-pointer-lowtag
)
64 (inst srawi temp temp n-widetag-bits
)
65 (inst subi temp temp
(1- array-dimensions-offset
))
66 (inst slwi res temp n-fixnum-tag-bits
)))
68 ;;;; Bounds checking routine.
71 (define-vop (check-bound)
72 (:translate %check-bound
)
74 (:args
(array :scs
(descriptor-reg))
75 (bound :scs
(any-reg descriptor-reg
))
76 (index :scs
(any-reg descriptor-reg
)))
77 (:temporary
(:scs
(non-descriptor-reg)) temp
)
79 (:save-p
:compute-only
)
81 (let ((error (generate-error-code vop
'invalid-array-index-error
83 (%test-fixnum index error t
:temp temp
)
84 (inst cmplw index bound
)
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-fixnum word-index
136 positive-fixnum any-reg
)
137 (def-data-vector-frobs simple-array-fixnum word-index
139 (def-data-vector-frobs simple-array-signed-byte-32 word-index
140 signed-num signed-reg
))
142 #!+compare-and-swap-vops
143 (define-vop (%compare-and-swap-svref word-index-cas
)
144 (:note
"inline array compare-and-swap")
146 (:variant vector-data-offset other-pointer-lowtag
)
147 (:translate %compare-and-swap-svref
)
148 (:arg-types simple-vector positive-fixnum
* *))
150 ;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit,
151 ;;; and 4-bit vectors.
154 (macrolet ((def-small-data-vector-frobs (type bits
)
155 (let* ((elements-per-word (floor n-word-bits bits
))
156 (bit-shift (1- (integer-length elements-per-word
))))
158 (define-vop (,(symbolicate 'data-vector-ref
/ type
))
159 (:note
"inline array access")
160 (:translate data-vector-ref
)
162 (:args
(object :scs
(descriptor-reg))
163 (index :scs
(unsigned-reg)))
164 (:arg-types
,type positive-fixnum
)
165 (:results
(value :scs
(any-reg)))
166 (:result-types positive-fixnum
)
167 (:temporary
(:scs
(non-descriptor-reg) :to
(:result
0)) temp result
)
169 ;; temp = (index >> bit-shift) << 2)
170 (inst rlwinm temp index
,(- 32 (- bit-shift
2)) ,(- bit-shift
2) 29)
171 (inst addi temp temp
(- (* vector-data-offset n-word-bytes
)
172 other-pointer-lowtag
))
173 (inst lwzx result object temp
)
174 (inst andi. temp index
,(1- elements-per-word
))
175 (inst xori temp temp
,(1- elements-per-word
))
177 `((inst slwi temp temp
,(1- (integer-length bits
)))))
178 (inst srw result result temp
)
179 (inst andi. result result
,(1- (ash 1 bits
)))
180 (inst slwi value result n-fixnum-tag-bits
)))
181 (define-vop (,(symbolicate 'data-vector-ref-c
/ type
))
182 (:translate data-vector-ref
)
184 (:args
(object :scs
(descriptor-reg)))
185 (:arg-types
,type
(:constant index
))
187 (:results
(result :scs
(unsigned-reg)))
188 (:result-types positive-fixnum
)
189 (:temporary
(:scs
(non-descriptor-reg)) temp
)
191 (multiple-value-bind (word extra
)
192 (floor index
,elements-per-word
)
193 (setf extra
(logxor extra
(1- ,elements-per-word
)))
194 (let ((offset (- (* (+ word vector-data-offset
)
196 other-pointer-lowtag
)))
197 (cond ((typep offset
'(signed-byte 16))
198 (inst lwz result object offset
))
200 (inst lr temp offset
)
201 (inst lwzx result object temp
))))
202 (unless (zerop extra
)
203 (inst srwi result result
(* ,bits extra
)))
204 (unless (= extra
,(1- elements-per-word
))
205 (inst andi. result result
,(1- (ash 1 bits
)))))))
206 (define-vop (,(symbolicate 'data-vector-set
/ type
))
207 (:note
"inline array store")
208 (:translate data-vector-set
)
210 (:args
(object :scs
(descriptor-reg))
211 (index :scs
(unsigned-reg) :target shift
)
212 (value :scs
(unsigned-reg zero immediate
) :target result
))
213 (:arg-types
,type positive-fixnum positive-fixnum
)
214 (:results
(result :scs
(unsigned-reg)))
215 (:result-types positive-fixnum
)
216 (:temporary
(:scs
(non-descriptor-reg)) temp old offset
)
217 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) shift
)
219 ;; offset = (index >> bit-shift) << 2)
220 (inst rlwinm offset index
,(- 32 (- bit-shift
2)) ,(- bit-shift
2) 29)
221 (inst addi offset offset
(- (* vector-data-offset n-word-bytes
)
222 other-pointer-lowtag
))
223 (inst lwzx old object offset
)
224 (inst andi. shift index
,(1- elements-per-word
))
225 (inst xori shift shift
,(1- elements-per-word
))
227 `((inst slwi shift shift
,(1- (integer-length bits
)))))
228 (unless (and (sc-is value immediate
)
229 (= (tn-value value
) ,(1- (ash 1 bits
))))
230 (inst lr temp
,(1- (ash 1 bits
)))
231 (inst slw temp temp shift
)
232 (inst andc old old temp
))
233 (unless (sc-is value zero
)
236 (inst lr temp
(logand (tn-value value
) ,(1- (ash 1 bits
)))))
238 (inst andi. temp value
,(1- (ash 1 bits
)))))
239 (inst slw temp temp shift
)
240 (inst or old old temp
))
241 (inst stwx old object offset
)
244 (inst lr result
(tn-value value
)))
246 (move result value
)))))
247 (define-vop (,(symbolicate 'data-vector-set-c
/ type
))
248 (:translate data-vector-set
)
250 (:args
(object :scs
(descriptor-reg))
251 (value :scs
(unsigned-reg zero immediate
) :target result
))
256 (:results
(result :scs
(unsigned-reg)))
257 (:result-types positive-fixnum
)
258 (:temporary
(:scs
(non-descriptor-reg)) offset-reg temp old
)
260 (multiple-value-bind (word extra
) (floor index
,elements-per-word
)
261 (let ((offset (- (* (+ word vector-data-offset
) n-word-bytes
)
262 other-pointer-lowtag
)))
263 (cond ((typep offset
'(signed-byte 16))
264 (inst lwz old object offset
))
266 (inst lr offset-reg offset
)
267 (inst lwzx old object offset-reg
)))
268 (unless (and (sc-is value immediate
)
269 (= (tn-value value
) ,(1- (ash 1 bits
))))
271 (inst clrlwi old old
,bits
))
274 (lognot (ash ,(1- (ash 1 bits
))
276 ,(1- elements-per-word
))
278 (inst and old old temp
))))
282 (let ((value (ash (logand (tn-value value
)
285 ,(1- elements-per-word
))
287 (cond ((typep value
'(unsigned-byte 16))
288 (inst ori old old value
))
291 (inst or old old temp
)))))
293 (inst slwi temp value
294 (* (logxor extra
,(1- elements-per-word
)) ,bits
))
295 (inst or old old temp
)))
296 (if (typep offset
'(signed-byte 16))
297 (inst stw old object offset
)
298 (inst stwx old object offset-reg
)))
301 (inst lr result
(tn-value value
)))
303 (move result value
))))))))))
304 (def-small-data-vector-frobs simple-bit-vector
1)
305 (def-small-data-vector-frobs simple-array-unsigned-byte-2
2)
306 (def-small-data-vector-frobs simple-array-unsigned-byte-4
4))
309 ;;; And the float variants.
312 (define-vop (data-vector-ref/simple-array-single-float
)
313 (:note
"inline array access")
314 (:translate data-vector-ref
)
316 (:args
(object :scs
(descriptor-reg))
317 (index :scs
(any-reg)))
318 (:arg-types simple-array-single-float positive-fixnum
)
319 (:results
(value :scs
(single-reg)))
320 (:temporary
(:scs
(non-descriptor-reg)) offset
)
321 (:result-types single-float
)
323 (inst addi offset index
(- (* vector-data-offset n-word-bytes
)
324 other-pointer-lowtag
))
325 (inst lfsx value object offset
)))
328 (define-vop (data-vector-set/simple-array-single-float
)
329 (:note
"inline array store")
330 (:translate data-vector-set
)
332 (:args
(object :scs
(descriptor-reg))
333 (index :scs
(any-reg))
334 (value :scs
(single-reg) :target result
))
335 (:arg-types simple-array-single-float positive-fixnum single-float
)
336 (:results
(result :scs
(single-reg)))
337 (:result-types single-float
)
338 (:temporary
(:scs
(non-descriptor-reg)) offset
)
340 (inst addi offset index
341 (- (* vector-data-offset n-word-bytes
)
342 other-pointer-lowtag
))
343 (inst stfsx value object offset
)
344 (unless (location= result value
)
345 (inst frsp result value
))))
347 (define-vop (data-vector-ref/simple-array-double-float
)
348 (:note
"inline array access")
349 (:translate data-vector-ref
)
351 (:args
(object :scs
(descriptor-reg))
352 (index :scs
(any-reg)))
353 (:arg-types simple-array-double-float positive-fixnum
)
354 (:results
(value :scs
(double-reg)))
355 (:result-types double-float
)
356 (:temporary
(:scs
(non-descriptor-reg)) offset
)
358 (inst slwi offset index
1)
359 (inst addi offset offset
(- (* vector-data-offset n-word-bytes
)
360 other-pointer-lowtag
))
361 (inst lfdx value object offset
)))
363 (define-vop (data-vector-set/simple-array-double-float
)
364 (:note
"inline array store")
365 (:translate data-vector-set
)
367 (:args
(object :scs
(descriptor-reg))
368 (index :scs
(any-reg))
369 (value :scs
(double-reg) :target result
))
370 (:arg-types simple-array-double-float positive-fixnum double-float
)
371 (:results
(result :scs
(double-reg)))
372 (:result-types double-float
)
373 (:temporary
(:scs
(non-descriptor-reg)) offset
)
375 (inst slwi offset index
1)
376 (inst addi offset offset
(- (* vector-data-offset n-word-bytes
)
377 other-pointer-lowtag
))
378 (inst stfdx value object offset
)
379 (unless (location= result value
)
380 (inst fmr result value
))))
383 ;;; Complex float arrays.
385 (define-vop (data-vector-ref/simple-array-complex-single-float
)
386 (:note
"inline array access")
387 (:translate data-vector-ref
)
389 (:args
(object :scs
(descriptor-reg))
390 (index :scs
(any-reg)))
391 (:arg-types simple-array-complex-single-float positive-fixnum
)
392 (:results
(value :scs
(complex-single-reg)))
393 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) offset
)
394 (:result-types complex-single-float
)
396 (let ((real-tn (complex-single-reg-real-tn value
)))
397 (inst slwi offset index
1)
398 (inst addi offset offset
(- (* vector-data-offset n-word-bytes
)
399 other-pointer-lowtag
))
400 (inst lfsx real-tn object offset
))
401 (let ((imag-tn (complex-single-reg-imag-tn value
)))
402 (inst addi offset offset n-word-bytes
)
403 (inst lfsx imag-tn object offset
))))
405 (define-vop (data-vector-set/simple-array-complex-single-float
)
406 (:note
"inline array store")
407 (:translate data-vector-set
)
409 (:args
(object :scs
(descriptor-reg))
410 (index :scs
(any-reg))
411 (value :scs
(complex-single-reg) :target result
))
412 (:arg-types simple-array-complex-single-float positive-fixnum
413 complex-single-float
)
414 (:results
(result :scs
(complex-single-reg)))
415 (:result-types complex-single-float
)
416 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) offset
)
418 (let ((value-real (complex-single-reg-real-tn value
))
419 (result-real (complex-single-reg-real-tn result
)))
420 (inst slwi offset index
1)
421 (inst addi offset offset
(- (* vector-data-offset n-word-bytes
)
422 other-pointer-lowtag
))
423 (inst stfsx value-real object offset
)
424 (unless (location= result-real value-real
)
425 (inst frsp result-real value-real
)))
426 (let ((value-imag (complex-single-reg-imag-tn value
))
427 (result-imag (complex-single-reg-imag-tn result
)))
428 (inst addi offset offset n-word-bytes
)
429 (inst stfsx value-imag object offset
)
430 (unless (location= result-imag value-imag
)
431 (inst frsp result-imag value-imag
)))))
434 (define-vop (data-vector-ref/simple-array-complex-double-float
)
435 (:note
"inline array access")
436 (:translate data-vector-ref
)
438 (:args
(object :scs
(descriptor-reg) :to
:result
)
439 (index :scs
(any-reg)))
440 (:arg-types simple-array-complex-double-float positive-fixnum
)
441 (:results
(value :scs
(complex-double-reg)))
442 (:result-types complex-double-float
)
443 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) offset
)
445 (let ((real-tn (complex-double-reg-real-tn value
)))
446 (inst slwi offset index
2)
447 (inst addi offset offset
(- (* vector-data-offset n-word-bytes
)
448 other-pointer-lowtag
))
449 (inst lfdx real-tn object offset
))
450 (let ((imag-tn (complex-double-reg-imag-tn value
)))
451 (inst addi offset offset
(* 2 n-word-bytes
))
452 (inst lfdx imag-tn object offset
))))
454 (define-vop (data-vector-set/simple-array-complex-double-float
)
455 (:note
"inline array store")
456 (:translate data-vector-set
)
458 (:args
(object :scs
(descriptor-reg) :to
:result
)
459 (index :scs
(any-reg))
460 (value :scs
(complex-double-reg) :target result
))
461 (:arg-types simple-array-complex-double-float positive-fixnum
462 complex-double-float
)
463 (:results
(result :scs
(complex-double-reg)))
464 (:result-types complex-double-float
)
465 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
1)) offset
)
467 (let ((value-real (complex-double-reg-real-tn value
))
468 (result-real (complex-double-reg-real-tn result
)))
469 (inst slwi offset index
2)
470 (inst addi offset offset
(- (* vector-data-offset n-word-bytes
)
471 other-pointer-lowtag
))
472 (inst stfdx value-real object offset
)
473 (unless (location= result-real value-real
)
474 (inst fmr result-real value-real
)))
475 (let ((value-imag (complex-double-reg-imag-tn value
))
476 (result-imag (complex-double-reg-imag-tn result
)))
477 (inst addi offset offset
(* 2 n-word-bytes
))
478 (inst stfdx value-imag object offset
)
479 (unless (location= result-imag value-imag
)
480 (inst fmr result-imag value-imag
)))))
483 ;;; These vops are useful for accessing the bits of a vector irrespective of
484 ;;; what type of vector it is.
487 (define-vop (vector-raw-bits word-index-ref
)
488 (:note
"vector-raw-bits VOP")
489 (:translate %vector-raw-bits
)
490 (:results
(value :scs
(unsigned-reg)))
491 (:result-types unsigned-num
)
492 (:variant vector-data-offset other-pointer-lowtag
))
494 (define-vop (set-vector-raw-bits word-index-set
)
495 (:note
"setf vector-raw-bits VOP")
496 (:translate %set-vector-raw-bits
)
497 (:args
(object :scs
(descriptor-reg))
498 (index :scs
(any-reg zero immediate
))
499 (value :scs
(unsigned-reg)))
500 (:arg-types
* positive-fixnum unsigned-num
)
501 (:results
(result :scs
(unsigned-reg)))
502 (:result-types unsigned-num
)
503 (:variant vector-data-offset other-pointer-lowtag
))
507 (define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref
)
508 (:note
"inline array access")
509 (:variant vector-data-offset other-pointer-lowtag
)
510 (:translate data-vector-ref
)
511 (:arg-types simple-array-signed-byte-8 positive-fixnum
)
512 (:results
(value :scs
(signed-reg)))
513 (:result-types tagged-num
))
515 (define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set
)
516 (:note
"inline array store")
517 (:variant vector-data-offset other-pointer-lowtag
)
518 (:translate data-vector-set
)
519 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num
)
520 (:args
(object :scs
(descriptor-reg))
521 (index :scs
(any-reg zero immediate
))
522 (value :scs
(signed-reg)))
523 (:results
(result :scs
(signed-reg)))
524 (:result-types tagged-num
))
526 (define-vop (data-vector-ref/simple-array-signed-byte-16
527 signed-halfword-index-ref
)
528 (:note
"inline array access")
529 (:variant vector-data-offset other-pointer-lowtag
)
530 (:translate data-vector-ref
)
531 (:arg-types simple-array-signed-byte-16 positive-fixnum
)
532 (:results
(value :scs
(signed-reg)))
533 (:result-types tagged-num
))
535 (define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set
)
536 (:note
"inline array store")
537 (:variant vector-data-offset other-pointer-lowtag
)
538 (:translate data-vector-set
)
539 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num
)
540 (:args
(object :scs
(descriptor-reg))
541 (index :scs
(any-reg zero immediate
))
542 (value :scs
(signed-reg)))
543 (:results
(result :scs
(signed-reg)))
544 (:result-types tagged-num
))
546 ;;;; ATOMIC-INCF for arrays
548 (define-vop (array-atomic-incf/word
)
549 (:translate %array-atomic-incf
/word
)
551 (:args
(object :scs
(descriptor-reg))
552 (index :scs
(any-reg) :target offset
)
553 (diff :scs
(unsigned-reg)))
554 (:arg-types
* positive-fixnum unsigned-num
)
555 (:results
(result :scs
(unsigned-reg) :from
:load
))
556 (:result-types unsigned-num
)
557 (:temporary
(:sc unsigned-reg
:from
(:argument
1)) offset
)
558 (:temporary
(:sc non-descriptor-reg
) sum
)
560 (inst addi offset index
561 (- (* vector-data-offset n-word-bytes
)
562 other-pointer-lowtag
))
563 ;; load the slot value, add DIFF, write the sum back, and return
564 ;; the original slot value, atomically, and include a memory
568 (inst lwarx result offset object
)
569 (inst add sum result diff
)
570 (inst stwcx. sum offset object
)