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)
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 sb!kernel:%array-dimension)
49 (:variant array-dimensions-offset other-pointer-lowtag))
51 (define-vop (%set-array-dimension word-index-set)
52 (:translate sb!kernel:%set-array-dimension)
54 (:variant array-dimensions-offset other-pointer-lowtag))
56 (define-vop (array-rank-vop)
57 (:translate sb!kernel:%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) :target result))
77 (:results (result :scs (any-reg descriptor-reg)))
79 (:save-p :compute-only)
81 (let ((error (generate-error-code vop 'invalid-array-index-error
83 (inst cmplw index bound)
85 (move result index))))
89 ;;;; Accessors/Setters
91 ;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
92 ;;; elements are represented in integer registers and are built out of
93 ;;; 8, 16, or 32 bit elements.
95 (macrolet ((def-data-vector-frobs (type variant element-type &rest scs)
97 (define-vop (,(symbolicate "DATA-VECTOR-REF/" (string type))
98 ,(symbolicate (string variant) "-REF"))
99 (:note "inline array access")
100 (:variant vector-data-offset other-pointer-lowtag)
101 (:translate data-vector-ref)
102 (:arg-types ,type positive-fixnum)
103 (:results (value :scs ,scs))
104 (:result-types ,element-type))
105 (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type))
106 ,(symbolicate (string variant) "-SET"))
107 (:note "inline array store")
108 (:variant vector-data-offset other-pointer-lowtag)
109 (:translate data-vector-set)
110 (:arg-types ,type positive-fixnum ,element-type)
111 (:args (object :scs (descriptor-reg))
112 (index :scs (any-reg zero immediate))
114 (:results (result :scs ,scs))
115 (:result-types ,element-type)))))
116 (def-data-vector-frobs simple-base-string byte-index
117 character character-reg)
119 (def-data-vector-frobs simple-character-string word-index
120 character character-reg)
121 (def-data-vector-frobs simple-vector word-index
122 * descriptor-reg any-reg)
123 (def-data-vector-frobs simple-array-unsigned-byte-7 byte-index
124 positive-fixnum unsigned-reg)
125 (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
126 positive-fixnum unsigned-reg)
127 (def-data-vector-frobs simple-array-unsigned-byte-15 halfword-index
128 positive-fixnum unsigned-reg)
129 (def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
130 positive-fixnum unsigned-reg)
131 (def-data-vector-frobs simple-array-unsigned-byte-31 word-index
132 unsigned-num unsigned-reg)
133 (def-data-vector-frobs simple-array-unsigned-byte-32 word-index
134 unsigned-num unsigned-reg)
136 (def-data-vector-frobs simple-array-unsigned-byte-29 word-index
137 positive-fixnum any-reg)
138 (def-data-vector-frobs simple-array-signed-byte-30 word-index
140 (def-data-vector-frobs simple-array-signed-byte-32 word-index
141 signed-num signed-reg))
144 ;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit,
145 ;;; and 4-bit vectors.
148 (macrolet ((def-small-data-vector-frobs (type bits)
149 (let* ((elements-per-word (floor n-word-bits bits))
150 (bit-shift (1- (integer-length elements-per-word))))
152 (define-vop (,(symbolicate 'data-vector-ref/ type))
153 (:note "inline array access")
154 (:translate data-vector-ref)
156 (:args (object :scs (descriptor-reg))
157 (index :scs (unsigned-reg)))
158 (:arg-types ,type positive-fixnum)
159 (:results (value :scs (any-reg)))
160 (:result-types positive-fixnum)
161 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
163 ;; temp = (index >> bit-shift) << 2)
164 (inst rlwinm temp index ,(- 32 (- bit-shift 2)) ,(- bit-shift 2) 29)
165 (inst addi temp temp (- (* vector-data-offset n-word-bytes)
166 other-pointer-lowtag))
167 (inst lwzx result object temp)
168 (inst andi. temp index ,(1- elements-per-word))
169 (inst xori temp temp ,(1- elements-per-word))
171 `((inst slwi temp temp ,(1- (integer-length bits)))))
172 (inst srw result result temp)
173 (inst andi. result result ,(1- (ash 1 bits)))
174 (inst slwi value result n-fixnum-tag-bits)))
175 (define-vop (,(symbolicate 'data-vector-ref-c/ type))
176 (:translate data-vector-ref)
178 (:args (object :scs (descriptor-reg)))
179 (:arg-types ,type (:constant index))
181 (:results (result :scs (unsigned-reg)))
182 (:result-types positive-fixnum)
183 (:temporary (:scs (non-descriptor-reg)) temp)
185 (multiple-value-bind (word extra)
186 (floor index ,elements-per-word)
187 (setf extra (logxor extra (1- ,elements-per-word)))
188 (let ((offset (- (* (+ word vector-data-offset)
190 other-pointer-lowtag)))
191 (cond ((typep offset '(signed-byte 16))
192 (inst lwz result object offset))
194 (inst lr temp offset)
195 (inst lwzx result object temp))))
196 (unless (zerop extra)
197 (inst srwi result result (* ,bits extra)))
198 (unless (= extra ,(1- elements-per-word))
199 (inst andi. result 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 (non-descriptor-reg)) temp old offset)
211 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
213 ;; offset = (index >> bit-shift) << 2)
214 (inst rlwinm offset index ,(- 32 (- bit-shift 2)) ,(- bit-shift 2) 29)
215 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
216 other-pointer-lowtag))
217 (inst lwzx old object offset)
218 (inst andi. shift index ,(1- elements-per-word))
219 (inst xori shift shift ,(1- elements-per-word))
221 `((inst slwi shift shift ,(1- (integer-length bits)))))
222 (unless (and (sc-is value immediate)
223 (= (tn-value value) ,(1- (ash 1 bits))))
224 (inst lr temp ,(1- (ash 1 bits)))
225 (inst slw temp temp shift)
226 (inst andc old old temp))
227 (unless (sc-is value zero)
230 (inst lr temp (logand (tn-value value) ,(1- (ash 1 bits)))))
232 (inst andi. temp value ,(1- (ash 1 bits)))))
233 (inst slw temp temp shift)
234 (inst or old old temp))
235 (inst stwx old object offset)
238 (inst lr result (tn-value value)))
240 (move result value)))))
241 (define-vop (,(symbolicate 'data-vector-set-c/ type))
242 (:translate data-vector-set)
244 (:args (object :scs (descriptor-reg))
245 (value :scs (unsigned-reg zero immediate) :target result))
250 (:results (result :scs (unsigned-reg)))
251 (:result-types positive-fixnum)
252 (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
254 (multiple-value-bind (word extra) (floor index ,elements-per-word)
255 (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
256 other-pointer-lowtag)))
257 (cond ((typep offset '(signed-byte 16))
258 (inst lwz old object offset))
260 (inst lr offset-reg offset)
261 (inst lwzx old object offset-reg)))
262 (unless (and (sc-is value immediate)
263 (= (tn-value value) ,(1- (ash 1 bits))))
265 (inst clrlwi old old ,bits))
268 (lognot (ash ,(1- (ash 1 bits))
270 ,(1- elements-per-word))
272 (inst and old old temp))))
276 (let ((value (ash (logand (tn-value value)
279 ,(1- elements-per-word))
281 (cond ((typep value '(unsigned-byte 16))
282 (inst ori old old value))
285 (inst or old old temp)))))
287 (inst slwi temp value
288 (* (logxor extra ,(1- elements-per-word)) ,bits))
289 (inst or old old temp)))
290 (if (typep offset '(signed-byte 16))
291 (inst stw old object offset)
292 (inst stwx old object offset-reg)))
295 (inst lr result (tn-value value)))
297 (move result value))))))))))
298 (def-small-data-vector-frobs simple-bit-vector 1)
299 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
300 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
303 ;;; And the float variants.
306 (define-vop (data-vector-ref/simple-array-single-float)
307 (:note "inline array access")
308 (:translate data-vector-ref)
310 (:args (object :scs (descriptor-reg))
311 (index :scs (any-reg)))
312 (:arg-types simple-array-single-float positive-fixnum)
313 (:results (value :scs (single-reg)))
314 (:temporary (:scs (non-descriptor-reg)) offset)
315 (:result-types single-float)
317 (inst addi offset index (- (* vector-data-offset n-word-bytes)
318 other-pointer-lowtag))
319 (inst lfsx value object offset)))
322 (define-vop (data-vector-set/simple-array-single-float)
323 (:note "inline array store")
324 (:translate data-vector-set)
326 (:args (object :scs (descriptor-reg))
327 (index :scs (any-reg))
328 (value :scs (single-reg) :target result))
329 (:arg-types simple-array-single-float positive-fixnum single-float)
330 (:results (result :scs (single-reg)))
331 (:result-types single-float)
332 (:temporary (:scs (non-descriptor-reg)) offset)
334 (inst addi offset index
335 (- (* vector-data-offset n-word-bytes)
336 other-pointer-lowtag))
337 (inst stfsx value object offset)
338 (unless (location= result value)
339 (inst frsp result value))))
341 (define-vop (data-vector-ref/simple-array-double-float)
342 (:note "inline array access")
343 (:translate data-vector-ref)
345 (:args (object :scs (descriptor-reg))
346 (index :scs (any-reg)))
347 (:arg-types simple-array-double-float positive-fixnum)
348 (:results (value :scs (double-reg)))
349 (:result-types double-float)
350 (:temporary (:scs (non-descriptor-reg)) offset)
352 (inst slwi offset index 1)
353 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
354 other-pointer-lowtag))
355 (inst lfdx value object offset)))
357 (define-vop (data-vector-set/simple-array-double-float)
358 (:note "inline array store")
359 (:translate data-vector-set)
361 (:args (object :scs (descriptor-reg))
362 (index :scs (any-reg))
363 (value :scs (double-reg) :target result))
364 (:arg-types simple-array-double-float positive-fixnum double-float)
365 (:results (result :scs (double-reg)))
366 (:result-types double-float)
367 (:temporary (:scs (non-descriptor-reg)) offset)
369 (inst slwi offset index 1)
370 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
371 other-pointer-lowtag))
372 (inst stfdx value object offset)
373 (unless (location= result value)
374 (inst fmr result value))))
377 ;;; Complex float arrays.
379 (define-vop (data-vector-ref/simple-array-complex-single-float)
380 (:note "inline array access")
381 (:translate data-vector-ref)
383 (:args (object :scs (descriptor-reg))
384 (index :scs (any-reg)))
385 (:arg-types simple-array-complex-single-float positive-fixnum)
386 (:results (value :scs (complex-single-reg)))
387 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
388 (:result-types complex-single-float)
390 (let ((real-tn (complex-single-reg-real-tn value)))
391 (inst slwi offset index 1)
392 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
393 other-pointer-lowtag))
394 (inst lfsx real-tn object offset))
395 (let ((imag-tn (complex-single-reg-imag-tn value)))
396 (inst addi offset offset n-word-bytes)
397 (inst lfsx imag-tn object offset))))
399 (define-vop (data-vector-set/simple-array-complex-single-float)
400 (:note "inline array store")
401 (:translate data-vector-set)
403 (:args (object :scs (descriptor-reg))
404 (index :scs (any-reg))
405 (value :scs (complex-single-reg) :target result))
406 (:arg-types simple-array-complex-single-float positive-fixnum
407 complex-single-float)
408 (:results (result :scs (complex-single-reg)))
409 (:result-types complex-single-float)
410 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
412 (let ((value-real (complex-single-reg-real-tn value))
413 (result-real (complex-single-reg-real-tn result)))
414 (inst slwi offset index 1)
415 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
416 other-pointer-lowtag))
417 (inst stfsx value-real object offset)
418 (unless (location= result-real value-real)
419 (inst frsp result-real value-real)))
420 (let ((value-imag (complex-single-reg-imag-tn value))
421 (result-imag (complex-single-reg-imag-tn result)))
422 (inst addi offset offset n-word-bytes)
423 (inst stfsx value-imag object offset)
424 (unless (location= result-imag value-imag)
425 (inst frsp result-imag value-imag)))))
428 (define-vop (data-vector-ref/simple-array-complex-double-float)
429 (:note "inline array access")
430 (:translate data-vector-ref)
432 (:args (object :scs (descriptor-reg) :to :result)
433 (index :scs (any-reg)))
434 (:arg-types simple-array-complex-double-float positive-fixnum)
435 (:results (value :scs (complex-double-reg)))
436 (:result-types complex-double-float)
437 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
439 (let ((real-tn (complex-double-reg-real-tn value)))
440 (inst slwi offset index 2)
441 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
442 other-pointer-lowtag))
443 (inst lfdx real-tn object offset))
444 (let ((imag-tn (complex-double-reg-imag-tn value)))
445 (inst addi offset offset (* 2 n-word-bytes))
446 (inst lfdx imag-tn object offset))))
448 (define-vop (data-vector-set/simple-array-complex-double-float)
449 (:note "inline array store")
450 (:translate data-vector-set)
452 (:args (object :scs (descriptor-reg) :to :result)
453 (index :scs (any-reg))
454 (value :scs (complex-double-reg) :target result))
455 (:arg-types simple-array-complex-double-float positive-fixnum
456 complex-double-float)
457 (:results (result :scs (complex-double-reg)))
458 (:result-types complex-double-float)
459 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
461 (let ((value-real (complex-double-reg-real-tn value))
462 (result-real (complex-double-reg-real-tn result)))
463 (inst slwi offset index 2)
464 (inst addi offset offset (- (* vector-data-offset n-word-bytes)
465 other-pointer-lowtag))
466 (inst stfdx value-real object offset)
467 (unless (location= result-real value-real)
468 (inst fmr result-real value-real)))
469 (let ((value-imag (complex-double-reg-imag-tn value))
470 (result-imag (complex-double-reg-imag-tn result)))
471 (inst addi offset offset (* 2 n-word-bytes))
472 (inst stfdx value-imag object offset)
473 (unless (location= result-imag value-imag)
474 (inst fmr result-imag value-imag)))))
477 ;;; These vops are useful for accessing the bits of a vector irrespective of
478 ;;; what type of vector it is.
481 (define-vop (vector-raw-bits word-index-ref)
482 (:note "vector-raw-bits VOP")
483 (:translate %vector-raw-bits)
484 (:results (value :scs (unsigned-reg)))
485 (:result-types unsigned-num)
486 (:variant vector-data-offset other-pointer-lowtag))
488 (define-vop (set-vector-raw-bits word-index-set)
489 (:note "setf vector-raw-bits VOP")
490 (:translate %set-vector-raw-bits)
491 (:args (object :scs (descriptor-reg))
492 (index :scs (any-reg zero immediate))
493 (value :scs (unsigned-reg)))
494 (:arg-types * positive-fixnum unsigned-num)
495 (:results (result :scs (unsigned-reg)))
496 (:result-types unsigned-num)
497 (:variant vector-data-offset other-pointer-lowtag))
499 ;;;; Misc. Array VOPs.
503 (define-vop (vector-word-length)
504 (:args (vec :scs (descriptor-reg)))
505 (:results (res :scs (any-reg descriptor-reg)))
507 (loadw res vec clc::g-vector-header-words)
508 (inst niuo res res clc::g-vector-words-mask-16)))
510 (define-vop (get-vector-subtype get-header-data))
511 (define-vop (set-vector-subtype set-header-data))
516 (define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref)
517 (:note "inline array access")
518 (:variant vector-data-offset other-pointer-lowtag)
519 (:translate data-vector-ref)
520 (:arg-types simple-array-signed-byte-8 positive-fixnum)
521 (:results (value :scs (signed-reg)))
522 (:result-types tagged-num))
524 (define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set)
525 (:note "inline array store")
526 (:variant vector-data-offset other-pointer-lowtag)
527 (:translate data-vector-set)
528 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
529 (:args (object :scs (descriptor-reg))
530 (index :scs (any-reg zero immediate))
531 (value :scs (signed-reg)))
532 (:results (result :scs (signed-reg)))
533 (:result-types tagged-num))
535 (define-vop (data-vector-ref/simple-array-signed-byte-16
536 signed-halfword-index-ref)
537 (:note "inline array access")
538 (:variant vector-data-offset other-pointer-lowtag)
539 (:translate data-vector-ref)
540 (:arg-types simple-array-signed-byte-16 positive-fixnum)
541 (:results (value :scs (signed-reg)))
542 (:result-types tagged-num))
544 (define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set)
545 (:note "inline array store")
546 (:variant vector-data-offset other-pointer-lowtag)
547 (:translate data-vector-set)
548 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
549 (:args (object :scs (descriptor-reg))
550 (index :scs (any-reg zero immediate))
551 (value :scs (signed-reg)))
552 (:results (result :scs (signed-reg)))
553 (:result-types tagged-num))