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) sb!vm: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- sb!vm:array-dimensions-offset)))
34 (inst slwi ndescr ndescr sb!vm:n-widetag-bits)
35 (inst or ndescr ndescr type)
36 (inst srwi ndescr ndescr 2)
37 (storew ndescr header 0 sb!vm:other-pointer-lowtag))
38 (move result header)))
41 ;;;; Additional accessors and setters for the array header.
43 (defknown sb!impl::%array-dimension (t fixnum) fixnum
45 (defknown sb!impl::%set-array-dimension (t fixnum fixnum) fixnum
48 (define-vop (%array-dimension word-index-ref)
49 (:translate sb!impl::%array-dimension)
51 (:variant sb!vm:array-dimensions-offset sb!vm:other-pointer-lowtag))
53 (define-vop (%set-array-dimension word-index-set)
54 (:translate sb!impl::%set-array-dimension)
56 (:variant sb!vm:array-dimensions-offset sb!vm:other-pointer-lowtag))
60 (defknown sb!impl::%array-rank (t) fixnum (flushable))
62 (define-vop (array-rank-vop)
63 (:translate sb!impl::%array-rank)
65 (:args (x :scs (descriptor-reg)))
66 (:temporary (:scs (non-descriptor-reg)) temp)
67 (:results (res :scs (any-reg descriptor-reg)))
69 (loadw temp x 0 sb!vm:other-pointer-lowtag)
70 (inst srawi temp temp sb!vm:n-widetag-bits)
71 (inst subi temp temp (1- sb!vm:array-dimensions-offset))
72 (inst slwi res temp 2)))
76 ;;;; Bounds checking routine.
79 (define-vop (check-bound)
80 (:translate %check-bound)
82 (:args (array :scs (descriptor-reg))
83 (bound :scs (any-reg descriptor-reg))
84 (index :scs (any-reg descriptor-reg) :target result))
85 (:results (result :scs (any-reg descriptor-reg)))
87 (:save-p :compute-only)
89 (let ((error (generate-error-code vop invalid-array-index-error
91 (inst cmplw index bound)
93 (move result index))))
97 ;;;; Accessors/Setters
99 ;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
100 ;;; elements are represented in integer registers and are built out of
101 ;;; 8, 16, or 32 bit elements.
103 (macrolet ((def-data-vector-frobs (type variant element-type &rest scs)
105 (define-vop (,(symbolicate "DATA-VECTOR-REF/" (string type))
106 ,(symbolicate (string variant) "-REF"))
107 (:note "inline array access")
108 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
109 (:translate data-vector-ref)
110 (:arg-types ,type positive-fixnum)
111 (:results (value :scs ,scs))
112 (:result-types ,element-type))
113 (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type))
114 ,(symbolicate (string variant) "-SET"))
115 (:note "inline array store")
116 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
117 (:translate data-vector-set)
118 (:arg-types ,type positive-fixnum ,element-type)
119 (:args (object :scs (descriptor-reg))
120 (index :scs (any-reg zero immediate))
122 (:results (result :scs ,scs))
123 (:result-types ,element-type)))))
124 (def-data-vector-frobs simple-base-string byte-index
125 base-char base-char-reg)
126 (def-data-vector-frobs simple-vector word-index
127 * descriptor-reg any-reg)
129 (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
130 positive-fixnum unsigned-reg)
131 (def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
132 positive-fixnum 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-signed-byte-30 word-index
138 (def-data-vector-frobs simple-array-signed-byte-32 word-index
139 signed-num signed-reg))
142 ;;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit,
143 ;;; and 4-bit vectors.
146 (macrolet ((def-small-data-vector-frobs (type bits)
147 (let* ((elements-per-word (floor sb!vm:n-word-bits bits))
148 (bit-shift (1- (integer-length elements-per-word))))
150 (define-vop (,(symbolicate 'data-vector-ref/ type))
151 (:note "inline array access")
152 (:translate data-vector-ref)
154 (:args (object :scs (descriptor-reg))
155 (index :scs (unsigned-reg)))
156 (:arg-types ,type positive-fixnum)
157 (:results (value :scs (any-reg)))
158 (:result-types positive-fixnum)
159 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
161 (inst srwi temp index ,bit-shift)
162 (inst slwi temp temp 2)
163 (inst addi temp temp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
164 sb!vm:other-pointer-lowtag))
165 (inst lwzx result object temp)
166 (inst andi. temp index ,(1- elements-per-word))
167 (inst xori temp temp ,(1- elements-per-word))
169 `((inst slwi temp temp ,(1- (integer-length bits)))))
170 (inst srw result result temp)
171 (inst andi. result result ,(1- (ash 1 bits)))
172 (inst slwi value result 2)))
173 (define-vop (,(symbolicate 'data-vector-ref-c/ type))
174 (:translate data-vector-ref)
176 (:args (object :scs (descriptor-reg)))
177 (:arg-types ,type (:constant index))
179 (:results (result :scs (unsigned-reg)))
180 (:result-types positive-fixnum)
181 (:temporary (:scs (non-descriptor-reg)) temp)
183 (multiple-value-bind (word extra)
184 (floor index ,elements-per-word)
185 (setf extra (logxor extra (1- ,elements-per-word)))
186 (let ((offset (- (* (+ word sb!vm:vector-data-offset)
188 sb!vm:other-pointer-lowtag)))
189 (cond ((typep offset '(signed-byte 16))
190 (inst lwz result object offset))
192 (inst lr temp offset)
193 (inst lwzx result object temp))))
194 (unless (zerop extra)
195 (inst srwi result result (* ,bits extra)))
196 (unless (= extra ,(1- elements-per-word))
197 (inst andi. result result ,(1- (ash 1 bits)))))))
198 (define-vop (,(symbolicate 'data-vector-set/ type))
199 (:note "inline array store")
200 (:translate data-vector-set)
202 (:args (object :scs (descriptor-reg))
203 (index :scs (unsigned-reg) :target shift)
204 (value :scs (unsigned-reg zero immediate) :target result))
205 (:arg-types ,type positive-fixnum positive-fixnum)
206 (:results (result :scs (unsigned-reg)))
207 (:result-types positive-fixnum)
208 (:temporary (:scs (non-descriptor-reg)) temp old offset)
209 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
211 (inst srwi offset index ,bit-shift)
212 (inst slwi offset offset 2)
213 (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
214 sb!vm:other-pointer-lowtag))
215 (inst lwzx old object offset)
216 (inst andi. shift index ,(1- elements-per-word))
217 (inst xori shift shift ,(1- elements-per-word))
219 `((inst slwi shift shift ,(1- (integer-length bits)))))
220 (unless (and (sc-is value immediate)
221 (= (tn-value value) ,(1- (ash 1 bits))))
222 (inst lr temp ,(1- (ash 1 bits)))
223 (inst slw temp temp shift)
225 (inst and 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 sb!vm:vector-data-offset) sb!vm:n-word-bytes)
255 sb!vm: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 slwi old old ,bits)
265 (inst srwi 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 (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
318 sb!vm: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 (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
336 sb!vm: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 (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
354 sb!vm: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 (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
371 sb!vm: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 (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
393 sb!vm: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 sb!vm: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 (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
416 sb!vm: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 sb!vm: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 (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
442 sb!vm: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 sb!vm: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 (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
465 sb!vm: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 sb!vm: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 used for implementing float slots in structures (whose raw
478 ;;; data is an unsigned-32 vector.
480 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
481 (:translate %raw-ref-single)
482 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
484 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
485 (:translate %raw-set-single)
486 (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
488 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
489 (:translate %raw-ref-double)
490 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
492 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
493 (:translate %raw-set-double)
494 (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
496 (define-vop (raw-ref-complex-single
497 data-vector-ref/simple-array-complex-single-float)
498 (:translate %raw-ref-complex-single)
499 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
501 (define-vop (raw-set-complex-single
502 data-vector-set/simple-array-complex-single-float)
503 (:translate %raw-set-complex-single)
504 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
505 complex-single-float))
507 (define-vop (raw-ref-complex-double
508 data-vector-ref/simple-array-complex-double-float)
509 (:translate %raw-ref-complex-double)
510 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
512 (define-vop (raw-set-complex-double
513 data-vector-set/simple-array-complex-double-float)
514 (:translate %raw-set-complex-double)
515 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
516 complex-double-float))
519 ;;; These vops are useful for accessing the bits of a vector irrespective of
520 ;;; what type of vector it is.
523 (define-vop (raw-bits word-index-ref)
524 (:note "raw-bits VOP")
525 (:translate %raw-bits)
526 (:results (value :scs (unsigned-reg)))
527 (:result-types unsigned-num)
528 (:variant 0 sb!vm:other-pointer-lowtag))
530 (define-vop (set-raw-bits word-index-set)
531 (:note "setf raw-bits VOP")
532 (:translate %set-raw-bits)
533 (:args (object :scs (descriptor-reg))
534 (index :scs (any-reg zero immediate))
535 (value :scs (unsigned-reg)))
536 (:arg-types * positive-fixnum unsigned-num)
537 (:results (result :scs (unsigned-reg)))
538 (:result-types unsigned-num)
539 (:variant 0 sb!vm:other-pointer-lowtag))
543 ;;;; Misc. Array VOPs.
547 (define-vop (vector-word-length)
548 (:args (vec :scs (descriptor-reg)))
549 (:results (res :scs (any-reg descriptor-reg)))
551 (loadw res vec clc::g-vector-header-words)
552 (inst niuo res res clc::g-vector-words-mask-16)))
554 (define-vop (get-vector-subtype get-header-data))
555 (define-vop (set-vector-subtype set-header-data))
560 (define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref)
561 (:note "inline array access")
562 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
563 (:translate data-vector-ref)
564 (:arg-types simple-array-signed-byte-8 positive-fixnum)
565 (:results (value :scs (signed-reg)))
566 (:result-types tagged-num))
568 (define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set)
569 (:note "inline array store")
570 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
571 (:translate data-vector-set)
572 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
573 (:args (object :scs (descriptor-reg))
574 (index :scs (any-reg zero immediate))
575 (value :scs (signed-reg)))
576 (:results (result :scs (signed-reg)))
577 (:result-types tagged-num))
579 (define-vop (data-vector-ref/simple-array-signed-byte-16
580 signed-halfword-index-ref)
581 (:note "inline array access")
582 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
583 (:translate data-vector-ref)
584 (:arg-types simple-array-signed-byte-16 positive-fixnum)
585 (:results (value :scs (signed-reg)))
586 (:result-types tagged-num))
588 (define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set)
589 (:note "inline array store")
590 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
591 (:translate data-vector-set)
592 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
593 (:args (object :scs (descriptor-reg))
594 (index :scs (any-reg zero immediate))
595 (value :scs (signed-reg)))
596 (:results (result :scs (signed-reg)))
597 (:result-types tagged-num))