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 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 type-bits header)
33 (inst bis header type header)
34 (inst srl header 2 header)
36 (inst bis alloc-tn other-pointer-type result)
37 (storew header result 0 other-pointer-type)
38 (inst addq alloc-tn bytes alloc-tn))))
42 ;;;; additional accessors and setters for the array header
44 (defknown sb!impl::%array-dimension (t index) index
46 (defknown sb!impl::%set-array-dimension (t index index) index
49 (define-full-reffer %array-dimension *
50 array-dimensions-offset other-pointer-type
51 (any-reg) positive-fixnum sb!impl::%array-dimension)
53 (define-full-setter %set-array-dimension *
54 array-dimensions-offset other-pointer-type
55 (any-reg) positive-fixnum sb!impl::%set-array-dimension #+gengc nil)
58 (defknown sb!impl::%array-rank (t) index (flushable))
60 (define-vop (array-rank-vop)
61 (:translate sb!impl::%array-rank)
63 (:args (x :scs (descriptor-reg)))
64 (:temporary (:scs (non-descriptor-reg)) temp)
65 (:results (res :scs (any-reg descriptor-reg)))
67 (loadw temp x 0 other-pointer-type)
68 (inst sra temp type-bits temp)
69 (inst subq temp (1- array-dimensions-offset) temp)
70 (inst sll temp 2 res)))
74 ;;;; bounds checking routine
76 (define-vop (check-bound)
77 (:translate %check-bound)
79 (:args (array :scs (descriptor-reg))
80 (bound :scs (any-reg descriptor-reg))
81 (index :scs (any-reg descriptor-reg) :target result))
82 (:results (result :scs (any-reg descriptor-reg)))
83 (:temporary (:scs (non-descriptor-reg)) temp)
85 (:save-p :compute-only)
87 (let ((error (generate-error-code vop invalid-array-index-error
89 (inst cmpult index bound temp)
91 (move index result))))
93 ;;;; accessors/setters
95 ;;; Variants built on top of word-index-ref, etc. I.e. those vectors
96 ;;; whose elements are represented in integer registers and are built
97 ;;; out of 8, 16, or 32 bit elements.
98 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
100 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
102 vector-data-offset other-pointer-type
103 ,(remove-if #'(lambda (x) (member x '(null zero))) scs)
106 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
108 vector-data-offset other-pointer-type ,scs ,element-type
109 data-vector-set #+gengc ,(if (member 'descriptor-reg scs)
113 (def-partial-data-vector-frobs
114 (type element-type size signed &rest scs)
116 (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
118 ,size ,signed vector-data-offset other-pointer-type ,scs
119 ,element-type data-vector-ref)
120 (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type)
122 ,size vector-data-offset other-pointer-type ,scs
123 ,element-type data-vector-set)))
124 (def-small-data-vector-frobs (type bits)
125 (let* ((elements-per-word (floor word-bits bits))
126 (bit-shift (1- (integer-length elements-per-word))))
128 (define-vop (,(symbolicate 'data-vector-ref/ type))
129 (:note "inline array access")
130 (:translate data-vector-ref)
132 (:args (object :scs (descriptor-reg))
133 (index :scs (unsigned-reg)))
134 (:arg-types ,type positive-fixnum)
135 (:results (value :scs (any-reg)))
136 (:result-types positive-fixnum)
137 (:temporary (:scs (interior-reg)) lip)
138 (:temporary (:scs (non-descriptor-reg) :to (:result 0))
141 (inst srl index ,bit-shift temp)
142 (inst sll temp 2 temp)
143 (inst addq object temp lip)
145 (- (* vector-data-offset word-bytes)
148 (inst and index ,(1- elements-per-word) temp)
151 ,(1- (integer-length bits)) temp)))
152 (inst srl result temp result)
153 (inst and result ,(1- (ash 1 bits)) result)
154 (inst sll result 2 value)))
155 (define-vop (,(symbolicate 'data-vector-ref-c/ type))
156 (:translate data-vector-ref)
158 (:args (object :scs (descriptor-reg)))
162 ,(1- (* (1+ (- (floor (+ #x7fff
166 elements-per-word)))))
168 (:results (result :scs (unsigned-reg)))
169 (:result-types positive-fixnum)
171 (multiple-value-bind (word extra)
172 (floor index ,elements-per-word)
173 (loadw result object (+ word
176 (unless (zerop extra)
177 (inst srl result (* extra ,bits) result))
178 (unless (= extra ,(1- elements-per-word))
179 (inst and result ,(1- (ash 1 bits))
181 (define-vop (,(symbolicate 'data-vector-set/ type))
182 (:note "inline array store")
183 (:translate data-vector-set)
185 (:args (object :scs (descriptor-reg))
186 (index :scs (unsigned-reg) :target shift)
187 (value :scs (unsigned-reg zero immediate)
189 (:arg-types ,type positive-fixnum positive-fixnum)
190 (:results (result :scs (unsigned-reg)))
191 (:result-types positive-fixnum)
192 (:temporary (:scs (interior-reg)) lip)
193 (:temporary (:scs (non-descriptor-reg)) temp old)
194 (:temporary (:scs (non-descriptor-reg)
195 :from (:argument 1)) shift)
197 (inst srl index ,bit-shift temp)
198 (inst sll temp 2 temp)
199 (inst addq object temp lip)
201 (- (* vector-data-offset word-bytes)
204 (inst and index ,(1- elements-per-word) shift)
206 `((inst sll shift ,(1- (integer-length
209 (unless (and (sc-is value immediate)
212 (inst li ,(1- (ash 1 bits)) temp)
213 (inst sll temp shift temp)
215 (inst and old temp old))
216 (unless (sc-is value zero)
220 (logand (tn-value value)
227 (inst sll temp shift temp)
228 (inst bis old temp old))
230 (- (* vector-data-offset word-bytes)
235 (inst li (tn-value value) result))
237 (move zero-tn result))
239 (move value result)))))
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)
249 ,(1- (* (1+ (- (floor (+ #x7fff
253 elements-per-word))))
256 (:results (result :scs (unsigned-reg)))
257 (:result-types positive-fixnum)
258 (:temporary (:scs (non-descriptor-reg)) temp old)
260 (multiple-value-bind (word extra)
261 (floor index ,elements-per-word)
263 (- (* (+ word vector-data-offset)
267 (unless (and (sc-is value immediate)
270 (cond ((= extra ,(1- elements-per-word))
271 (inst sll old ,bits old)
272 (inst srl old ,bits old))
275 (lognot (ash ,(1- (ash 1
279 (inst and old temp old))))
284 (ash (logand (tn-value
290 (cond ((< value #x10000)
291 (inst bis old value old))
294 (inst bis old temp old)))))
296 (inst sll value (* extra ,bits)
298 (inst bis old temp old)))
300 (- (* (+ word vector-data-offset)
306 (inst li (tn-value value) result))
308 (move zero-tn result))
310 (move value result))))))))))
311 (def-full-data-vector-frobs simple-vector *
312 descriptor-reg any-reg null zero)
314 (def-partial-data-vector-frobs simple-string base-char :byte nil
317 (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
318 :byte nil unsigned-reg signed-reg)
320 (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
321 :short nil unsigned-reg signed-reg)
323 (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
326 (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
329 (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
332 (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
334 (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
337 ;; Integer vectors whos elements are smaller than a byte. I.e. bit,
338 ;; 2-bit, and 4-bit vectors.
339 (def-small-data-vector-frobs simple-bit-vector 1)
340 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
341 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
343 ;;; and the float variants..
345 (define-vop (data-vector-ref/simple-array-single-float)
346 (:note "inline array access")
347 (:translate data-vector-ref)
349 (:args (object :scs (descriptor-reg))
350 (index :scs (any-reg)))
351 (:arg-types simple-array-single-float positive-fixnum)
352 (:results (value :scs (single-reg)))
353 (:result-types single-float)
354 (:temporary (:scs (interior-reg)) lip)
356 (inst addq object index lip)
358 (- (* vector-data-offset word-bytes)
362 (define-vop (data-vector-set/simple-array-single-float)
363 (:note "inline array store")
364 (:translate data-vector-set)
366 (:args (object :scs (descriptor-reg))
367 (index :scs (any-reg))
368 (value :scs (single-reg) :target result))
369 (:arg-types simple-array-single-float positive-fixnum single-float)
370 (:results (result :scs (single-reg)))
371 (:result-types single-float)
372 (:temporary (:scs (interior-reg)) lip)
374 (inst addq object index lip)
376 (- (* vector-data-offset word-bytes)
379 (unless (location= result value)
380 (inst fmove value result))))
382 (define-vop (data-vector-ref/simple-array-double-float)
383 (:note "inline array access")
384 (:translate data-vector-ref)
386 (:args (object :scs (descriptor-reg))
387 (index :scs (any-reg)))
388 (:arg-types simple-array-double-float positive-fixnum)
389 (:results (value :scs (double-reg)))
390 (:result-types double-float)
391 (:temporary (:scs (interior-reg)) lip)
393 (inst addq object index lip)
394 (inst addq lip index lip)
396 (- (* vector-data-offset word-bytes)
400 (define-vop (data-vector-set/simple-array-double-float)
401 (:note "inline array store")
402 (:translate data-vector-set)
404 (:args (object :scs (descriptor-reg))
405 (index :scs (any-reg))
406 (value :scs (double-reg) :target result))
407 (:arg-types simple-array-double-float positive-fixnum double-float)
408 (:results (result :scs (double-reg)))
409 (:result-types double-float)
410 (:temporary (:scs (interior-reg)) lip)
412 (inst addq object index lip)
413 (inst addq lip index lip)
415 (- (* vector-data-offset word-bytes)
416 other-pointer-type) lip)
417 (unless (location= result value)
418 (inst fmove value result))))
420 ;;; complex float arrays
422 (define-vop (data-vector-ref/simple-array-complex-single-float)
423 (:note "inline array access")
424 (:translate data-vector-ref)
426 (:args (object :scs (descriptor-reg))
427 (index :scs (any-reg)))
428 (:arg-types simple-array-complex-single-float positive-fixnum)
429 (:results (value :scs (complex-single-reg)))
430 (:temporary (:scs (interior-reg)) lip)
431 (:result-types complex-single-float)
433 (let ((real-tn (complex-single-reg-real-tn value)))
434 (inst addq object index lip)
435 (inst addq lip index lip)
437 (- (* vector-data-offset word-bytes) other-pointer-type)
439 (let ((imag-tn (complex-single-reg-imag-tn value)))
441 (- (* (1+ vector-data-offset) word-bytes) other-pointer-type)
444 (define-vop (data-vector-set/simple-array-complex-single-float)
445 (:note "inline array store")
446 (:translate data-vector-set)
448 (:args (object :scs (descriptor-reg))
449 (index :scs (any-reg))
450 (value :scs (complex-single-reg) :target result))
451 (:arg-types simple-array-complex-single-float positive-fixnum
452 complex-single-float)
453 (:results (result :scs (complex-single-reg)))
454 (:result-types complex-single-float)
455 (:temporary (:scs (interior-reg)) lip)
457 (let ((value-real (complex-single-reg-real-tn value))
458 (result-real (complex-single-reg-real-tn result)))
459 (inst addq object index lip)
460 (inst addq lip index lip)
462 (- (* vector-data-offset word-bytes) other-pointer-type)
464 (unless (location= result-real value-real)
465 (inst fmove value-real result-real)))
466 (let ((value-imag (complex-single-reg-imag-tn value))
467 (result-imag (complex-single-reg-imag-tn result)))
469 (- (* (1+ vector-data-offset) word-bytes) other-pointer-type)
471 (unless (location= result-imag value-imag)
472 (inst fmove value-imag result-imag)))))
474 (define-vop (data-vector-ref/simple-array-complex-double-float)
475 (:note "inline array access")
476 (:translate data-vector-ref)
478 (:args (object :scs (descriptor-reg))
479 (index :scs (any-reg)))
480 (:arg-types simple-array-complex-double-float positive-fixnum)
481 (:results (value :scs (complex-double-reg)))
482 (:result-types complex-double-float)
483 (:temporary (:scs (interior-reg)) lip)
485 (let ((real-tn (complex-double-reg-real-tn value)))
486 (inst addq object index lip)
487 (inst addq lip index lip)
488 (inst addq lip index lip)
489 (inst addq lip index lip)
491 (- (* vector-data-offset word-bytes) other-pointer-type)
493 (let ((imag-tn (complex-double-reg-imag-tn value)))
495 (- (* (+ vector-data-offset 2) word-bytes) other-pointer-type)
498 (define-vop (data-vector-set/simple-array-complex-double-float)
499 (:note "inline array store")
500 (:translate data-vector-set)
502 (:args (object :scs (descriptor-reg))
503 (index :scs (any-reg))
504 (value :scs (complex-double-reg) :target result))
505 (:arg-types simple-array-complex-double-float positive-fixnum
506 complex-double-float)
507 (:results (result :scs (complex-double-reg)))
508 (:result-types complex-double-float)
509 (:temporary (:scs (interior-reg)) lip)
511 (let ((value-real (complex-double-reg-real-tn value))
512 (result-real (complex-double-reg-real-tn result)))
513 (inst addq object index lip)
514 (inst addq lip index lip)
515 (inst addq lip index lip)
516 (inst addq lip index lip)
518 (- (* vector-data-offset word-bytes) other-pointer-type)
520 (unless (location= result-real value-real)
521 (inst fmove value-real result-real)))
522 (let ((value-imag (complex-double-reg-imag-tn value))
523 (result-imag (complex-double-reg-imag-tn result)))
525 (- (* (+ vector-data-offset 2) word-bytes) other-pointer-type)
527 (unless (location= result-imag value-imag)
528 (inst fmove value-imag result-imag)))))
531 ;;; These VOPs are used for implementing float slots in structures
532 ;;; (whose raw data is an unsigned-32 vector).
534 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
535 (:translate %raw-ref-single)
536 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
538 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
539 (:translate %raw-set-single)
540 (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
542 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
543 (:translate %raw-ref-double)
544 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
546 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
547 (:translate %raw-set-double)
548 (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
550 (define-vop (raw-ref-complex-single
551 data-vector-ref/simple-array-complex-single-float)
552 (:translate %raw-ref-complex-single)
553 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
555 (define-vop (raw-set-complex-single
556 data-vector-set/simple-array-complex-single-float)
557 (:translate %raw-set-complex-single)
558 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
559 complex-single-float))
561 (define-vop (raw-ref-complex-double
562 data-vector-ref/simple-array-complex-double-float)
563 (:translate %raw-ref-complex-double)
564 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
566 (define-vop (raw-set-complex-double
567 data-vector-set/simple-array-complex-double-float)
568 (:translate %raw-set-complex-double)
569 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
570 complex-double-float))
572 ;;; These vops are useful for accessing the bits of a vector irrespective of
573 ;;; what type of vector it is.
575 (define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num
577 (define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
578 unsigned-num %set-raw-bits #+gengc nil)
581 ;;;; misc. array VOPs
583 (define-vop (get-vector-subtype get-header-data))
584 (define-vop (set-vector-subtype set-header-data))