1 ;;;; the Alpha definitions for array operations
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.
14 ;;;; allocator for the array header
16 (define-vop (make-array-header)
18 (:translate make-array-header)
19 (:args (type :scs (any-reg))
20 (rank :scs (any-reg)))
21 (:arg-types positive-fixnum positive-fixnum)
22 (:temporary (:scs (any-reg)) bytes)
23 (:temporary (:scs (non-descriptor-reg)) header)
24 (:results (result :scs (descriptor-reg)))
26 (inst addq rank (+ (* array-dimensions-offset n-word-bytes)
29 (inst li (lognot lowtag-mask) header)
30 (inst and bytes header bytes)
31 (inst addq rank (fixnumize (1- array-dimensions-offset)) header)
32 (inst sll header n-widetag-bits header)
33 (inst bis header type header)
34 (inst srl header 2 header)
36 (inst bis alloc-tn other-pointer-lowtag result)
37 (storew header result 0 other-pointer-lowtag)
38 (inst addq alloc-tn bytes alloc-tn))))
42 ;;;; additional accessors and setters for the array header
43 (define-full-reffer %array-dimension *
44 array-dimensions-offset other-pointer-lowtag
45 (any-reg) positive-fixnum sb!kernel:%array-dimension)
47 (define-full-setter %set-array-dimension *
48 array-dimensions-offset other-pointer-lowtag
49 (any-reg) positive-fixnum sb!kernel:%set-array-dimension #!+gengc nil)
51 (define-vop (array-rank-vop)
52 (:translate sb!kernel:%array-rank)
54 (:args (x :scs (descriptor-reg)))
55 (:temporary (:scs (non-descriptor-reg)) temp)
56 (:results (res :scs (any-reg descriptor-reg)))
58 (loadw temp x 0 other-pointer-lowtag)
59 (inst sra temp n-widetag-bits temp)
60 (inst subq temp (1- array-dimensions-offset) temp)
61 (inst sll temp 2 res)))
63 ;;;; bounds checking routine
65 (define-vop (check-bound)
66 (:translate %check-bound)
68 (:args (array :scs (descriptor-reg))
69 (bound :scs (any-reg descriptor-reg))
70 (index :scs (any-reg descriptor-reg) :target result))
71 (:results (result :scs (any-reg descriptor-reg)))
72 (:temporary (:scs (non-descriptor-reg)) temp)
74 (:save-p :compute-only)
76 (let ((error (generate-error-code vop invalid-array-index-error
78 (inst cmpult index bound temp)
80 (move index result))))
82 ;;;; accessors/setters
84 ;;; Variants built on top of word-index-ref, etc. I.e. those vectors
85 ;;; whose elements are represented in integer registers and are built
86 ;;; out of 8, 16, or 32 bit elements.
87 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
89 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
91 vector-data-offset other-pointer-lowtag
92 ,(remove-if (lambda (x) (member x '(null zero))) scs)
95 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
97 vector-data-offset other-pointer-lowtag ,scs ,element-type
98 data-vector-set #+gengc ,(if (member 'descriptor-reg scs)
102 (def-partial-data-vector-frobs
103 (type element-type size signed &rest scs)
105 (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
107 ,size ,signed vector-data-offset other-pointer-lowtag ,scs
108 ,element-type data-vector-ref)
109 (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type)
111 ,size vector-data-offset other-pointer-lowtag ,scs
112 ,element-type data-vector-set)))
113 (def-small-data-vector-frobs (type bits)
114 (let* ((elements-per-word (floor n-word-bits bits))
115 (bit-shift (1- (integer-length elements-per-word))))
117 (define-vop (,(symbolicate 'data-vector-ref/ type))
118 (:note "inline array access")
119 (:translate data-vector-ref)
121 (:args (object :scs (descriptor-reg))
122 (index :scs (unsigned-reg)))
123 (:arg-types ,type positive-fixnum)
124 (:results (value :scs (any-reg)))
125 (:result-types positive-fixnum)
126 (:temporary (:scs (interior-reg)) lip)
127 (:temporary (:scs (non-descriptor-reg) :to (:result 0))
130 (inst srl index ,bit-shift temp)
131 (inst sll temp 2 temp)
132 (inst addq object temp lip)
134 (- (* vector-data-offset n-word-bytes)
135 other-pointer-lowtag)
137 (inst and index ,(1- elements-per-word) temp)
140 ,(1- (integer-length bits)) temp)))
141 (inst srl result temp result)
142 (inst and result ,(1- (ash 1 bits)) result)
143 (inst sll result 2 value)))
144 (define-vop (,(symbolicate 'data-vector-ref-c/ type))
145 (:translate data-vector-ref)
147 (:args (object :scs (descriptor-reg)))
151 ,(1- (* (1+ (- (floor (+ #x7fff
152 other-pointer-lowtag)
155 elements-per-word)))))
157 (:results (result :scs (unsigned-reg)))
158 (:result-types positive-fixnum)
160 (multiple-value-bind (word extra)
161 (floor index ,elements-per-word)
162 (loadw result object (+ word
164 other-pointer-lowtag)
165 (unless (zerop extra)
166 (inst srl result (* extra ,bits) result))
167 (unless (= extra ,(1- elements-per-word))
168 (inst and result ,(1- (ash 1 bits))
170 (define-vop (,(symbolicate 'data-vector-set/ type))
171 (:note "inline array store")
172 (:translate data-vector-set)
174 (:args (object :scs (descriptor-reg))
175 (index :scs (unsigned-reg) :target shift)
176 (value :scs (unsigned-reg zero immediate)
178 (:arg-types ,type positive-fixnum positive-fixnum)
179 (:results (result :scs (unsigned-reg)))
180 (:result-types positive-fixnum)
181 (:temporary (:scs (interior-reg)) lip)
182 (:temporary (:scs (non-descriptor-reg)) temp old)
183 (:temporary (:scs (non-descriptor-reg)
184 :from (:argument 1)) shift)
186 (inst srl index ,bit-shift temp)
187 (inst sll temp 2 temp)
188 (inst addq object temp lip)
190 (- (* vector-data-offset n-word-bytes)
191 other-pointer-lowtag)
193 (inst and index ,(1- elements-per-word) shift)
195 `((inst sll shift ,(1- (integer-length
198 (unless (and (sc-is value immediate)
201 (inst li ,(1- (ash 1 bits)) temp)
202 (inst sll temp shift temp)
204 (inst and old temp old))
205 (unless (sc-is value zero)
209 (logand (tn-value value)
216 (inst sll temp shift temp)
217 (inst bis old temp old))
219 (- (* vector-data-offset n-word-bytes)
220 other-pointer-lowtag)
224 (inst li (tn-value value) result))
226 (move zero-tn result))
228 (move value result)))))
229 (define-vop (,(symbolicate 'data-vector-set-c/ type))
230 (:translate data-vector-set)
232 (:args (object :scs (descriptor-reg))
233 (value :scs (unsigned-reg zero immediate)
238 ,(1- (* (1+ (- (floor (+ #x7fff
239 other-pointer-lowtag)
242 elements-per-word))))
245 (:results (result :scs (unsigned-reg)))
246 (:result-types positive-fixnum)
247 (:temporary (:scs (non-descriptor-reg)) temp old)
249 (multiple-value-bind (word extra)
250 (floor index ,elements-per-word)
252 (- (* (+ word vector-data-offset)
254 other-pointer-lowtag)
256 (unless (and (sc-is value immediate)
259 (cond ((= extra ,(1- elements-per-word))
260 (inst sll old ,bits old)
261 (inst srl old ,bits old))
264 (lognot (ash ,(1- (ash 1
268 (inst and old temp old))))
273 (ash (logand (tn-value
279 (cond ((< value #x10000)
280 (inst bis old value old))
283 (inst bis old temp old)))))
285 (inst sll value (* extra ,bits)
287 (inst bis old temp old)))
289 (- (* (+ word vector-data-offset)
291 other-pointer-lowtag)
295 (inst li (tn-value value) result))
297 (move zero-tn result))
299 (move value result))))))))))
300 (def-full-data-vector-frobs simple-vector *
301 descriptor-reg any-reg null zero)
303 (def-partial-data-vector-frobs simple-base-string base-char :byte nil
306 (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
307 :byte nil unsigned-reg signed-reg)
308 (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
309 :byte nil unsigned-reg signed-reg)
311 (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
312 :short nil unsigned-reg signed-reg)
313 (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
314 :short nil unsigned-reg signed-reg)
316 (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
318 (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
321 (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
324 (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
327 (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg)
328 (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
330 (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
333 ;; Integer vectors whos elements are smaller than a byte. I.e. bit,
334 ;; 2-bit, and 4-bit vectors.
335 (def-small-data-vector-frobs simple-bit-vector 1)
336 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
337 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
339 ;;; and the float variants..
341 (define-vop (data-vector-ref/simple-array-single-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-single-float positive-fixnum)
348 (:results (value :scs (single-reg)))
349 (:result-types single-float)
350 (:temporary (:scs (interior-reg)) lip)
352 (inst addq object index lip)
354 (- (* vector-data-offset n-word-bytes)
355 other-pointer-lowtag)
358 (define-vop (data-vector-set/simple-array-single-float)
359 (:note "inline array store")
360 (:translate data-vector-set)
362 (:args (object :scs (descriptor-reg))
363 (index :scs (any-reg))
364 (value :scs (single-reg) :target result))
365 (:arg-types simple-array-single-float positive-fixnum single-float)
366 (:results (result :scs (single-reg)))
367 (:result-types single-float)
368 (:temporary (:scs (interior-reg)) lip)
370 (inst addq object index lip)
372 (- (* vector-data-offset n-word-bytes)
373 other-pointer-lowtag)
375 (unless (location= result value)
376 (inst fmove value result))))
378 (define-vop (data-vector-ref/simple-array-double-float)
379 (:note "inline array access")
380 (:translate data-vector-ref)
382 (:args (object :scs (descriptor-reg))
383 (index :scs (any-reg)))
384 (:arg-types simple-array-double-float positive-fixnum)
385 (:results (value :scs (double-reg)))
386 (:result-types double-float)
387 (:temporary (:scs (interior-reg)) lip)
389 (inst addq object index lip)
390 (inst addq lip index lip)
392 (- (* vector-data-offset n-word-bytes)
393 other-pointer-lowtag)
396 (define-vop (data-vector-set/simple-array-double-float)
397 (:note "inline array store")
398 (:translate data-vector-set)
400 (:args (object :scs (descriptor-reg))
401 (index :scs (any-reg))
402 (value :scs (double-reg) :target result))
403 (:arg-types simple-array-double-float positive-fixnum double-float)
404 (:results (result :scs (double-reg)))
405 (:result-types double-float)
406 (:temporary (:scs (interior-reg)) lip)
408 (inst addq object index lip)
409 (inst addq lip index lip)
411 (- (* vector-data-offset n-word-bytes)
412 other-pointer-lowtag) lip)
413 (unless (location= result value)
414 (inst fmove value result))))
416 ;;; complex float arrays
418 (define-vop (data-vector-ref/simple-array-complex-single-float)
419 (:note "inline array access")
420 (:translate data-vector-ref)
422 (:args (object :scs (descriptor-reg))
423 (index :scs (any-reg)))
424 (:arg-types simple-array-complex-single-float positive-fixnum)
425 (:results (value :scs (complex-single-reg)))
426 (:temporary (:scs (interior-reg)) lip)
427 (:result-types complex-single-float)
429 (let ((real-tn (complex-single-reg-real-tn value)))
430 (inst addq object index lip)
431 (inst addq lip index lip)
433 (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
435 (let ((imag-tn (complex-single-reg-imag-tn value)))
437 (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag)
440 (define-vop (data-vector-set/simple-array-complex-single-float)
441 (:note "inline array store")
442 (:translate data-vector-set)
444 (:args (object :scs (descriptor-reg))
445 (index :scs (any-reg))
446 (value :scs (complex-single-reg) :target result))
447 (:arg-types simple-array-complex-single-float positive-fixnum
448 complex-single-float)
449 (:results (result :scs (complex-single-reg)))
450 (:result-types complex-single-float)
451 (:temporary (:scs (interior-reg)) lip)
453 (let ((value-real (complex-single-reg-real-tn value))
454 (result-real (complex-single-reg-real-tn result)))
455 (inst addq object index lip)
456 (inst addq lip index lip)
458 (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
460 (unless (location= result-real value-real)
461 (inst fmove value-real result-real)))
462 (let ((value-imag (complex-single-reg-imag-tn value))
463 (result-imag (complex-single-reg-imag-tn result)))
465 (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag)
467 (unless (location= result-imag value-imag)
468 (inst fmove value-imag result-imag)))))
470 (define-vop (data-vector-ref/simple-array-complex-double-float)
471 (:note "inline array access")
472 (:translate data-vector-ref)
474 (:args (object :scs (descriptor-reg))
475 (index :scs (any-reg)))
476 (:arg-types simple-array-complex-double-float positive-fixnum)
477 (:results (value :scs (complex-double-reg)))
478 (:result-types complex-double-float)
479 (:temporary (:scs (interior-reg)) lip)
481 (let ((real-tn (complex-double-reg-real-tn value)))
482 (inst addq object index lip)
483 (inst addq lip index lip)
484 (inst addq lip index lip)
485 (inst addq lip index lip)
487 (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
489 (let ((imag-tn (complex-double-reg-imag-tn value)))
491 (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag)
494 (define-vop (data-vector-set/simple-array-complex-double-float)
495 (:note "inline array store")
496 (:translate data-vector-set)
498 (:args (object :scs (descriptor-reg))
499 (index :scs (any-reg))
500 (value :scs (complex-double-reg) :target result))
501 (:arg-types simple-array-complex-double-float positive-fixnum
502 complex-double-float)
503 (:results (result :scs (complex-double-reg)))
504 (:result-types complex-double-float)
505 (:temporary (:scs (interior-reg)) lip)
507 (let ((value-real (complex-double-reg-real-tn value))
508 (result-real (complex-double-reg-real-tn result)))
509 (inst addq object index lip)
510 (inst addq lip index lip)
511 (inst addq lip index lip)
512 (inst addq lip index lip)
514 (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
516 (unless (location= result-real value-real)
517 (inst fmove value-real result-real)))
518 (let ((value-imag (complex-double-reg-imag-tn value))
519 (result-imag (complex-double-reg-imag-tn result)))
521 (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag)
523 (unless (location= result-imag value-imag)
524 (inst fmove value-imag result-imag)))))
527 ;;; These VOPs are used for implementing float slots in structures
528 ;;; (whose raw data is an unsigned-32 vector).
530 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
531 (:translate %raw-ref-single)
532 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
534 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
535 (:translate %raw-set-single)
536 (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
538 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
539 (:translate %raw-ref-double)
540 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
542 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
543 (:translate %raw-set-double)
544 (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
546 (define-vop (raw-ref-complex-single
547 data-vector-ref/simple-array-complex-single-float)
548 (:translate %raw-ref-complex-single)
549 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
551 (define-vop (raw-set-complex-single
552 data-vector-set/simple-array-complex-single-float)
553 (:translate %raw-set-complex-single)
554 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
555 complex-single-float))
557 (define-vop (raw-ref-complex-double
558 data-vector-ref/simple-array-complex-double-float)
559 (:translate %raw-ref-complex-double)
560 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
562 (define-vop (raw-set-complex-double
563 data-vector-set/simple-array-complex-double-float)
564 (:translate %raw-set-complex-double)
565 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
566 complex-double-float))
568 ;;; These vops are useful for accessing the bits of a vector irrespective of
569 ;;; what type of vector it is.
571 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num
573 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
574 unsigned-num %set-raw-bits #+gengc nil)
577 ;;;; misc. array VOPs
579 (define-vop (get-vector-subtype get-header-data))
580 (define-vop (set-vector-subtype set-header-data))