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 (,(intern (concatenate 'simple-string
108 ,(intern (concatenate 'simple-string
111 (:note "inline array access")
112 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
113 (:translate data-vector-ref)
114 (:arg-types ,type positive-fixnum)
115 (:results (value :scs ,scs))
116 (:result-types ,element-type))
117 (define-vop (,(intern (concatenate 'simple-string
120 ,(intern (concatenate 'simple-string
123 (:note "inline array store")
124 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
125 (:translate data-vector-set)
126 (:arg-types ,type positive-fixnum ,element-type)
127 (:args (object :scs (descriptor-reg))
128 (index :scs (any-reg zero immediate))
130 (:results (result :scs ,scs))
131 (:result-types ,element-type)))))
132 (def-data-vector-frobs simple-string byte-index
133 base-char base-char-reg)
134 (def-data-vector-frobs simple-vector word-index
135 * descriptor-reg any-reg)
137 (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
138 positive-fixnum unsigned-reg)
139 (def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
140 positive-fixnum unsigned-reg)
141 (def-data-vector-frobs simple-array-unsigned-byte-32 word-index
142 unsigned-num unsigned-reg)
144 (def-data-vector-frobs simple-array-signed-byte-30 word-index
146 (def-data-vector-frobs simple-array-signed-byte-32 word-index
147 signed-num signed-reg))
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 sb!vm: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 (inst srwi temp index ,bit-shift)
170 (inst slwi temp temp 2)
171 (inst addi temp temp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
172 sb!vm: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 2)))
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 sb!vm:vector-data-offset)
196 sb!vm: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 (inst srwi offset index ,bit-shift)
220 (inst slwi offset offset 2)
221 (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
222 sb!vm: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)
233 (inst and old old temp))
234 (unless (sc-is value zero)
237 (inst lr temp (logand (tn-value value) ,(1- (ash 1 bits)))))
239 (inst andi. temp value ,(1- (ash 1 bits)))))
240 (inst slw temp temp shift)
241 (inst or old old temp))
242 (inst stwx old object offset)
245 (inst lr result (tn-value value)))
247 (move result value)))))
248 (define-vop (,(symbolicate 'data-vector-set-c/ type))
249 (:translate data-vector-set)
251 (:args (object :scs (descriptor-reg))
252 (value :scs (unsigned-reg zero immediate) :target result))
257 (:results (result :scs (unsigned-reg)))
258 (:result-types positive-fixnum)
259 (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
261 (multiple-value-bind (word extra) (floor index ,elements-per-word)
262 (let ((offset (- (* (+ word sb!vm:vector-data-offset) sb!vm:n-word-bytes)
263 sb!vm:other-pointer-lowtag)))
264 (cond ((typep offset '(signed-byte 16))
265 (inst lwz old object offset))
267 (inst lr offset-reg offset)
268 (inst lwzx old object offset-reg)))
269 (unless (and (sc-is value immediate)
270 (= (tn-value value) ,(1- (ash 1 bits))))
272 (inst slwi old old ,bits)
273 (inst srwi old old ,bits))
276 (lognot (ash ,(1- (ash 1 bits))
278 ,(1- elements-per-word))
280 (inst and old old temp))))
284 (let ((value (ash (logand (tn-value value)
287 ,(1- elements-per-word))
289 (cond ((typep value '(unsigned-byte 16))
290 (inst ori old old value))
293 (inst or old old temp)))))
295 (inst slwi temp value
296 (* (logxor extra ,(1- elements-per-word)) ,bits))
297 (inst or old old temp)))
298 (if (typep offset '(signed-byte 16))
299 (inst stw old object offset)
300 (inst stwx old object offset-reg)))
303 (inst lr result (tn-value value)))
305 (move result value))))))))))
306 (def-small-data-vector-frobs simple-bit-vector 1)
307 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
308 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
311 ;;; And the float variants.
314 (define-vop (data-vector-ref/simple-array-single-float)
315 (:note "inline array access")
316 (:translate data-vector-ref)
318 (:args (object :scs (descriptor-reg))
319 (index :scs (any-reg)))
320 (:arg-types simple-array-single-float positive-fixnum)
321 (:results (value :scs (single-reg)))
322 (:temporary (:scs (non-descriptor-reg)) offset)
323 (:result-types single-float)
325 (inst addi offset index (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
326 sb!vm:other-pointer-lowtag))
327 (inst lfsx value object offset)))
330 (define-vop (data-vector-set/simple-array-single-float)
331 (:note "inline array store")
332 (:translate data-vector-set)
334 (:args (object :scs (descriptor-reg))
335 (index :scs (any-reg))
336 (value :scs (single-reg) :target result))
337 (:arg-types simple-array-single-float positive-fixnum single-float)
338 (:results (result :scs (single-reg)))
339 (:result-types single-float)
340 (:temporary (:scs (non-descriptor-reg)) offset)
342 (inst addi offset index
343 (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
344 sb!vm:other-pointer-lowtag))
345 (inst stfsx value object offset)
346 (unless (location= result value)
347 (inst frsp result value))))
349 (define-vop (data-vector-ref/simple-array-double-float)
350 (:note "inline array access")
351 (:translate data-vector-ref)
353 (:args (object :scs (descriptor-reg))
354 (index :scs (any-reg)))
355 (:arg-types simple-array-double-float positive-fixnum)
356 (:results (value :scs (double-reg)))
357 (:result-types double-float)
358 (:temporary (:scs (non-descriptor-reg)) offset)
360 (inst slwi offset index 1)
361 (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
362 sb!vm:other-pointer-lowtag))
363 (inst lfdx value object offset)))
365 (define-vop (data-vector-set/simple-array-double-float)
366 (:note "inline array store")
367 (:translate data-vector-set)
369 (:args (object :scs (descriptor-reg))
370 (index :scs (any-reg))
371 (value :scs (double-reg) :target result))
372 (:arg-types simple-array-double-float positive-fixnum double-float)
373 (:results (result :scs (double-reg)))
374 (:result-types double-float)
375 (:temporary (:scs (non-descriptor-reg)) offset)
377 (inst slwi offset index 1)
378 (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
379 sb!vm:other-pointer-lowtag))
380 (inst stfdx value object offset)
381 (unless (location= result value)
382 (inst fmr result value))))
385 ;;; Complex float arrays.
387 (define-vop (data-vector-ref/simple-array-complex-single-float)
388 (:note "inline array access")
389 (:translate data-vector-ref)
391 (:args (object :scs (descriptor-reg))
392 (index :scs (any-reg)))
393 (:arg-types simple-array-complex-single-float positive-fixnum)
394 (:results (value :scs (complex-single-reg)))
395 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
396 (:result-types complex-single-float)
398 (let ((real-tn (complex-single-reg-real-tn value)))
399 (inst slwi offset index 1)
400 (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
401 sb!vm:other-pointer-lowtag))
402 (inst lfsx real-tn object offset))
403 (let ((imag-tn (complex-single-reg-imag-tn value)))
404 (inst addi offset offset sb!vm:n-word-bytes)
405 (inst lfsx imag-tn object offset))))
407 (define-vop (data-vector-set/simple-array-complex-single-float)
408 (:note "inline array store")
409 (:translate data-vector-set)
411 (:args (object :scs (descriptor-reg))
412 (index :scs (any-reg))
413 (value :scs (complex-single-reg) :target result))
414 (:arg-types simple-array-complex-single-float positive-fixnum
415 complex-single-float)
416 (:results (result :scs (complex-single-reg)))
417 (:result-types complex-single-float)
418 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
420 (let ((value-real (complex-single-reg-real-tn value))
421 (result-real (complex-single-reg-real-tn result)))
422 (inst slwi offset index 1)
423 (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
424 sb!vm:other-pointer-lowtag))
425 (inst stfsx value-real object offset)
426 (unless (location= result-real value-real)
427 (inst frsp result-real value-real)))
428 (let ((value-imag (complex-single-reg-imag-tn value))
429 (result-imag (complex-single-reg-imag-tn result)))
430 (inst addi offset offset sb!vm:n-word-bytes)
431 (inst stfsx value-imag object offset)
432 (unless (location= result-imag value-imag)
433 (inst frsp result-imag value-imag)))))
436 (define-vop (data-vector-ref/simple-array-complex-double-float)
437 (:note "inline array access")
438 (:translate data-vector-ref)
440 (:args (object :scs (descriptor-reg) :to :result)
441 (index :scs (any-reg)))
442 (:arg-types simple-array-complex-double-float positive-fixnum)
443 (:results (value :scs (complex-double-reg)))
444 (:result-types complex-double-float)
445 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
447 (let ((real-tn (complex-double-reg-real-tn value)))
448 (inst slwi offset index 2)
449 (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
450 sb!vm:other-pointer-lowtag))
451 (inst lfdx real-tn object offset))
452 (let ((imag-tn (complex-double-reg-imag-tn value)))
453 (inst addi offset offset (* 2 sb!vm:n-word-bytes))
454 (inst lfdx imag-tn object offset))))
456 (define-vop (data-vector-set/simple-array-complex-double-float)
457 (:note "inline array store")
458 (:translate data-vector-set)
460 (:args (object :scs (descriptor-reg) :to :result)
461 (index :scs (any-reg))
462 (value :scs (complex-double-reg) :target result))
463 (:arg-types simple-array-complex-double-float positive-fixnum
464 complex-double-float)
465 (:results (result :scs (complex-double-reg)))
466 (:result-types complex-double-float)
467 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
469 (let ((value-real (complex-double-reg-real-tn value))
470 (result-real (complex-double-reg-real-tn result)))
471 (inst slwi offset index 2)
472 (inst addi offset offset (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
473 sb!vm:other-pointer-lowtag))
474 (inst stfdx value-real object offset)
475 (unless (location= result-real value-real)
476 (inst fmr result-real value-real)))
477 (let ((value-imag (complex-double-reg-imag-tn value))
478 (result-imag (complex-double-reg-imag-tn result)))
479 (inst addi offset offset (* 2 sb!vm:n-word-bytes))
480 (inst stfdx value-imag object offset)
481 (unless (location= result-imag value-imag)
482 (inst fmr result-imag value-imag)))))
485 ;;; These VOPs are used for implementing float slots in structures (whose raw
486 ;;; data is an unsigned-32 vector.
488 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
489 (:translate %raw-ref-single)
490 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
492 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
493 (:translate %raw-set-single)
494 (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
496 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
497 (:translate %raw-ref-double)
498 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
500 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
501 (:translate %raw-set-double)
502 (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
504 (define-vop (raw-ref-complex-single
505 data-vector-ref/simple-array-complex-single-float)
506 (:translate %raw-ref-complex-single)
507 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
509 (define-vop (raw-set-complex-single
510 data-vector-set/simple-array-complex-single-float)
511 (:translate %raw-set-complex-single)
512 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
513 complex-single-float))
515 (define-vop (raw-ref-complex-double
516 data-vector-ref/simple-array-complex-double-float)
517 (:translate %raw-ref-complex-double)
518 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
520 (define-vop (raw-set-complex-double
521 data-vector-set/simple-array-complex-double-float)
522 (:translate %raw-set-complex-double)
523 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
524 complex-double-float))
527 ;;; These vops are useful for accessing the bits of a vector irrespective of
528 ;;; what type of vector it is.
531 (define-vop (raw-bits word-index-ref)
532 (:note "raw-bits VOP")
533 (:translate %raw-bits)
534 (:results (value :scs (unsigned-reg)))
535 (:result-types unsigned-num)
536 (:variant 0 sb!vm:other-pointer-lowtag))
538 (define-vop (set-raw-bits word-index-set)
539 (:note "setf raw-bits VOP")
540 (:translate %set-raw-bits)
541 (:args (object :scs (descriptor-reg))
542 (index :scs (any-reg zero immediate))
543 (value :scs (unsigned-reg)))
544 (:arg-types * positive-fixnum unsigned-num)
545 (:results (result :scs (unsigned-reg)))
546 (:result-types unsigned-num)
547 (:variant 0 sb!vm:other-pointer-lowtag))
551 ;;;; Misc. Array VOPs.
555 (define-vop (vector-word-length)
556 (:args (vec :scs (descriptor-reg)))
557 (:results (res :scs (any-reg descriptor-reg)))
559 (loadw res vec clc::g-vector-header-words)
560 (inst niuo res res clc::g-vector-words-mask-16)))
562 (define-vop (get-vector-subtype get-header-data))
563 (define-vop (set-vector-subtype set-header-data))
568 (define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref)
569 (:note "inline array access")
570 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
571 (:translate data-vector-ref)
572 (:arg-types simple-array-signed-byte-8 positive-fixnum)
573 (:results (value :scs (signed-reg)))
574 (:result-types tagged-num))
576 (define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set)
577 (:note "inline array store")
578 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
579 (:translate data-vector-set)
580 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
581 (:args (object :scs (descriptor-reg))
582 (index :scs (any-reg zero immediate))
583 (value :scs (signed-reg)))
584 (:results (result :scs (signed-reg)))
585 (:result-types tagged-num))
587 (define-vop (data-vector-ref/simple-array-signed-byte-16
588 signed-halfword-index-ref)
589 (:note "inline array access")
590 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
591 (:translate data-vector-ref)
592 (:arg-types simple-array-signed-byte-16 positive-fixnum)
593 (:results (value :scs (signed-reg)))
594 (:result-types tagged-num))
596 (define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set)
597 (:note "inline array store")
598 (:variant sb!vm:vector-data-offset sb!vm:other-pointer-lowtag)
599 (:translate data-vector-set)
600 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
601 (:args (object :scs (descriptor-reg))
602 (index :scs (any-reg zero immediate))
603 (value :scs (signed-reg)))
604 (:results (result :scs (signed-reg)))
605 (:result-types tagged-num))