1 ;;;; array operations for the x86 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.
14 ;;;; allocator for the array header
16 (define-vop (make-array-header)
17 (:translate make-array-header)
19 (:args (type :scs (any-reg))
20 (rank :scs (any-reg)))
21 (:arg-types positive-fixnum positive-fixnum)
22 (:temporary (:sc any-reg :to :eval) bytes)
23 (:temporary (:sc any-reg :to :result) header)
24 (:results (result :scs (descriptor-reg) :from :eval))
28 (make-ea :dword :base rank
29 :disp (+ (* (1+ array-dimensions-offset) n-word-bytes)
31 (inst and bytes (lognot lowtag-mask))
32 (inst lea header (make-ea :dword :base rank
33 :disp (fixnumize (1- array-dimensions-offset))))
34 (inst shl header n-widetag-bits)
38 (allocation result bytes node)
39 (inst lea result (make-ea :dword :base result :disp other-pointer-lowtag))
40 (storew header result 0 other-pointer-lowtag))))
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)
51 (define-vop (array-rank-vop)
52 (:translate sb!kernel:%array-rank)
54 (:args (x :scs (descriptor-reg)))
55 (:results (res :scs (unsigned-reg)))
56 (:result-types positive-fixnum)
58 (loadw res x 0 other-pointer-lowtag)
59 (inst shr res n-widetag-bits)
60 (inst sub res (1- array-dimensions-offset))))
62 ;;;; bounds checking routine
64 ;;; Note that the immediate SC for the index argument is disabled
65 ;;; because it is not possible to generate a valid error code SC for
66 ;;; an immediate value.
68 ;;; FIXME: As per the KLUDGE note explaining the :IGNORE-FAILURE-P
69 ;;; flag in build-order.lisp-expr, compiling this file causes warnings
70 ;;; Argument FOO to VOP CHECK-BOUND has SC restriction
71 ;;; DESCRIPTOR-REG which is not allowed by the operand type:
72 ;;; (:OR POSITIVE-FIXNUM)
73 ;;; CSR's message "format ~/ /" on sbcl-devel 2002-03-12 contained
74 ;;; a possible patch, described as
75 ;;; Another patch is included more for information than anything --
76 ;;; removing the descriptor-reg SCs from the CHECK-BOUND vop in
77 ;;; x86/array.lisp seems to allow that file to compile without error[*],
78 ;;; and build; I haven't tested rebuilding capability, but I'd be
79 ;;; surprised if there were a problem. I'm not certain that this is the
80 ;;; correct fix, though, as the restrictions on the arguments to the VOP
81 ;;; aren't the same as in the sparc and alpha ports, where, incidentally,
82 ;;; the corresponding file builds without error currently.
83 ;;; Since neither of us (CSR or WHN) was quite sure that this is the
84 ;;; right thing, I've just recorded the patch here in hopes it might
85 ;;; help when someone attacks this problem again:
86 ;;; diff -u -r1.7 array.lisp
87 ;;; --- src/compiler/x86/array.lisp 11 Oct 2001 14:05:26 -0000 1.7
88 ;;; +++ src/compiler/x86/array.lisp 12 Mar 2002 12:23:37 -0000
89 ;;; @@ -76,10 +76,10 @@
90 ;;; (:translate %check-bound)
91 ;;; (:policy :fast-safe)
92 ;;; (:args (array :scs (descriptor-reg))
93 ;;; - (bound :scs (any-reg descriptor-reg))
94 ;;; - (index :scs (any-reg descriptor-reg #+nil immediate) :target result))
95 ;;; + (bound :scs (any-reg))
96 ;;; + (index :scs (any-reg #+nil immediate) :target result))
97 ;;; (:arg-types * positive-fixnum tagged-num)
98 ;;; - (:results (result :scs (any-reg descriptor-reg)))
99 ;;; + (:results (result :scs (any-reg)))
100 ;;; (:result-types positive-fixnum)
102 ;;; (:save-p :compute-only)
103 (define-vop (check-bound)
104 (:translate %check-bound)
106 (:args (array :scs (descriptor-reg))
107 (bound :scs (any-reg))
108 (index :scs (any-reg #+nil immediate) :target result))
109 (:arg-types * positive-fixnum tagged-num)
110 (:results (result :scs (any-reg)))
111 (:result-types positive-fixnum)
113 (:save-p :compute-only)
115 (let ((error (generate-error-code vop invalid-array-index-error
117 (index (if (sc-is index immediate)
118 (fixnumize (tn-value index))
120 (inst cmp bound index)
121 ;; We use below-or-equal even though it's an unsigned test,
122 ;; because negative indexes appear as large unsigned numbers.
123 ;; Therefore, we get the <0 and >=bound test all rolled into one.
125 (unless (and (tn-p index) (location= result index))
126 (inst mov result index)))))
128 ;;;; accessors/setters
130 ;;; variants built on top of WORD-INDEX-REF, etc. I.e., those vectors
131 ;;; whose elements are represented in integer registers and are built
132 ;;; out of 8, 16, or 32 bit elements.
133 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
135 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
136 ,type vector-data-offset other-pointer-lowtag ,scs
137 ,element-type data-vector-ref)
138 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
139 ,type vector-data-offset other-pointer-lowtag ,scs
140 ,element-type data-vector-set))))
141 (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
142 (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
144 (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
145 (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg)
146 (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
148 (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
151 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
152 ;;;; bit, 2-bit, and 4-bit vectors
154 (macrolet ((def-small-data-vector-frobs (type bits)
155 (let* ((elements-per-word (floor 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 (result :scs (unsigned-reg) :from (:argument 0)))
166 (:result-types positive-fixnum)
167 (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
170 (inst shr ecx ,bit-shift)
172 (make-ea :dword :base object :index ecx :scale 4
173 :disp (- (* vector-data-offset n-word-bytes)
174 other-pointer-lowtag)))
176 (inst and ecx ,(1- elements-per-word))
178 `((inst shl ecx ,(1- (integer-length bits)))))
179 (inst shr result :cl)
180 (inst and result ,(1- (ash 1 bits)))))
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)
190 (multiple-value-bind (word extra) (floor index ,elements-per-word)
191 (loadw result object (+ word vector-data-offset)
192 other-pointer-lowtag)
193 (unless (zerop extra)
194 (inst shr result (* extra ,bits)))
195 (unless (= extra ,(1- elements-per-word))
196 (inst and result ,(1- (ash 1 bits)))))))
197 (define-vop (,(symbolicate 'data-vector-set/ type))
198 (:note "inline array store")
199 (:translate data-vector-set)
201 (:args (object :scs (descriptor-reg) :target ptr)
202 (index :scs (unsigned-reg) :target ecx)
203 (value :scs (unsigned-reg immediate) :target result))
204 (:arg-types ,type positive-fixnum positive-fixnum)
205 (:results (result :scs (unsigned-reg)))
206 (:result-types positive-fixnum)
207 (:temporary (:sc unsigned-reg) word-index)
208 (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old)
209 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1))
212 (move word-index index)
213 (inst shr word-index ,bit-shift)
215 (make-ea :dword :base object :index word-index :scale 4
216 :disp (- (* vector-data-offset n-word-bytes)
217 other-pointer-lowtag)))
220 (inst and ecx ,(1- elements-per-word))
222 `((inst shl ecx ,(1- (integer-length bits)))))
224 (unless (and (sc-is value immediate)
225 (= (tn-value value) ,(1- (ash 1 bits))))
226 (inst and old ,(lognot (1- (ash 1 bits)))))
229 (unless (zerop (tn-value value))
230 (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
232 (inst or old value)))
237 (inst mov 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 immediate) :target result))
245 (:arg-types ,type (:constant index) positive-fixnum)
247 (:results (result :scs (unsigned-reg)))
248 (:result-types positive-fixnum)
249 (:temporary (:sc unsigned-reg :to (:result 0)) old)
251 (multiple-value-bind (word extra) (floor index ,elements-per-word)
253 (make-ea :dword :base object
254 :disp (- (* (+ word vector-data-offset)
256 other-pointer-lowtag)))
259 (let* ((value (tn-value value))
260 (mask ,(1- (ash 1 bits)))
261 (shift (* extra ,bits)))
262 (unless (= value mask)
263 (inst and old (ldb (byte 32 0) (lognot (ash mask shift)))))
264 (unless (zerop value)
265 (inst or old (ash value shift)))))
267 (let ((shift (* extra ,bits)))
268 (unless (zerop shift)
269 (inst ror old shift))
270 (inst and old (lognot ,(1- (ash 1 bits))))
272 (unless (zerop shift)
273 (inst rol old shift)))))
274 (inst mov (make-ea :dword :base object
275 :disp (- (* (+ word vector-data-offset)
277 other-pointer-lowtag))
281 (inst mov result (tn-value value)))
283 (move result value))))))))))
284 (def-small-data-vector-frobs simple-bit-vector 1)
285 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
286 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
288 ;;; And the float variants.
290 (define-vop (data-vector-ref/simple-array-single-float)
291 (:note "inline array access")
292 (:translate data-vector-ref)
294 (:args (object :scs (descriptor-reg))
295 (index :scs (any-reg)))
296 (:arg-types simple-array-single-float positive-fixnum)
297 (:results (value :scs (single-reg)))
298 (:result-types single-float)
300 (with-empty-tn@fp-top(value)
301 (inst fld (make-ea :dword :base object :index index :scale 1
302 :disp (- (* vector-data-offset
304 other-pointer-lowtag))))))
306 (define-vop (data-vector-ref-c/simple-array-single-float)
307 (:note "inline array access")
308 (:translate data-vector-ref)
310 (:args (object :scs (descriptor-reg)))
312 (:arg-types simple-array-single-float (:constant (signed-byte 30)))
313 (:results (value :scs (single-reg)))
314 (:result-types single-float)
316 (with-empty-tn@fp-top(value)
317 (inst fld (make-ea :dword :base object
318 :disp (- (+ (* vector-data-offset
321 other-pointer-lowtag))))))
323 (define-vop (data-vector-set/simple-array-single-float)
324 (:note "inline array store")
325 (:translate data-vector-set)
327 (:args (object :scs (descriptor-reg))
328 (index :scs (any-reg))
329 (value :scs (single-reg) :target result))
330 (:arg-types simple-array-single-float positive-fixnum single-float)
331 (:results (result :scs (single-reg)))
332 (:result-types single-float)
334 (cond ((zerop (tn-offset value))
336 (inst fst (make-ea :dword :base object :index index :scale 1
337 :disp (- (* vector-data-offset
339 other-pointer-lowtag)))
340 (unless (zerop (tn-offset result))
341 ;; Value is in ST0 but not result.
344 ;; Value is not in ST0.
346 (inst fst (make-ea :dword :base object :index index :scale 1
347 :disp (- (* vector-data-offset
349 other-pointer-lowtag)))
350 (cond ((zerop (tn-offset result))
351 ;; The result is in ST0.
354 ;; Neither value or result are in ST0
355 (unless (location= value result)
357 (inst fxch value)))))))
359 (define-vop (data-vector-set-c/simple-array-single-float)
360 (:note "inline array store")
361 (:translate data-vector-set)
363 (:args (object :scs (descriptor-reg))
364 (value :scs (single-reg) :target result))
366 (:arg-types simple-array-single-float (:constant (signed-byte 30))
368 (:results (result :scs (single-reg)))
369 (:result-types single-float)
371 (cond ((zerop (tn-offset value))
373 (inst fst (make-ea :dword :base object
374 :disp (- (+ (* vector-data-offset
377 other-pointer-lowtag)))
378 (unless (zerop (tn-offset result))
379 ;; Value is in ST0 but not result.
382 ;; Value is not in ST0.
384 (inst fst (make-ea :dword :base object
385 :disp (- (+ (* vector-data-offset
388 other-pointer-lowtag)))
389 (cond ((zerop (tn-offset result))
390 ;; The result is in ST0.
393 ;; Neither value or result are in ST0
394 (unless (location= value result)
396 (inst fxch value)))))))
398 (define-vop (data-vector-ref/simple-array-double-float)
399 (:note "inline array access")
400 (:translate data-vector-ref)
402 (:args (object :scs (descriptor-reg))
403 (index :scs (any-reg)))
404 (:arg-types simple-array-double-float positive-fixnum)
405 (:results (value :scs (double-reg)))
406 (:result-types double-float)
408 (with-empty-tn@fp-top(value)
409 (inst fldd (make-ea :dword :base object :index index :scale 2
410 :disp (- (* vector-data-offset
412 other-pointer-lowtag))))))
414 (define-vop (data-vector-ref-c/simple-array-double-float)
415 (:note "inline array access")
416 (:translate data-vector-ref)
418 (:args (object :scs (descriptor-reg)))
420 (:arg-types simple-array-double-float (:constant (signed-byte 30)))
421 (:results (value :scs (double-reg)))
422 (:result-types double-float)
424 (with-empty-tn@fp-top(value)
425 (inst fldd (make-ea :dword :base object
426 :disp (- (+ (* vector-data-offset
429 other-pointer-lowtag))))))
431 (define-vop (data-vector-set/simple-array-double-float)
432 (:note "inline array store")
433 (:translate data-vector-set)
435 (:args (object :scs (descriptor-reg))
436 (index :scs (any-reg))
437 (value :scs (double-reg) :target result))
438 (:arg-types simple-array-double-float positive-fixnum double-float)
439 (:results (result :scs (double-reg)))
440 (:result-types double-float)
442 (cond ((zerop (tn-offset value))
444 (inst fstd (make-ea :dword :base object :index index :scale 2
445 :disp (- (* vector-data-offset
447 other-pointer-lowtag)))
448 (unless (zerop (tn-offset result))
449 ;; Value is in ST0 but not result.
452 ;; Value is not in ST0.
454 (inst fstd (make-ea :dword :base object :index index :scale 2
455 :disp (- (* vector-data-offset
457 other-pointer-lowtag)))
458 (cond ((zerop (tn-offset result))
459 ;; The result is in ST0.
462 ;; Neither value or result are in ST0
463 (unless (location= value result)
465 (inst fxch value)))))))
467 (define-vop (data-vector-set-c/simple-array-double-float)
468 (:note "inline array store")
469 (:translate data-vector-set)
471 (:args (object :scs (descriptor-reg))
472 (value :scs (double-reg) :target result))
474 (:arg-types simple-array-double-float (:constant (signed-byte 30))
476 (:results (result :scs (double-reg)))
477 (:result-types double-float)
479 (cond ((zerop (tn-offset value))
481 (inst fstd (make-ea :dword :base object
482 :disp (- (+ (* vector-data-offset
485 other-pointer-lowtag)))
486 (unless (zerop (tn-offset result))
487 ;; Value is in ST0 but not result.
490 ;; Value is not in ST0.
492 (inst fstd (make-ea :dword :base object
493 :disp (- (+ (* vector-data-offset
496 other-pointer-lowtag)))
497 (cond ((zerop (tn-offset result))
498 ;; The result is in ST0.
501 ;; Neither value or result are in ST0
502 (unless (location= value result)
504 (inst fxch value)))))))
508 ;;; complex float variants
510 (define-vop (data-vector-ref/simple-array-complex-single-float)
511 (:note "inline array access")
512 (:translate data-vector-ref)
514 (:args (object :scs (descriptor-reg))
515 (index :scs (any-reg)))
516 (:arg-types simple-array-complex-single-float positive-fixnum)
517 (:results (value :scs (complex-single-reg)))
518 (:result-types complex-single-float)
520 (let ((real-tn (complex-single-reg-real-tn value)))
521 (with-empty-tn@fp-top (real-tn)
522 (inst fld (make-ea :dword :base object :index index :scale 2
523 :disp (- (* vector-data-offset
525 other-pointer-lowtag)))))
526 (let ((imag-tn (complex-single-reg-imag-tn value)))
527 (with-empty-tn@fp-top (imag-tn)
528 (inst fld (make-ea :dword :base object :index index :scale 2
529 :disp (- (* (1+ vector-data-offset)
531 other-pointer-lowtag)))))))
533 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
534 (:note "inline array access")
535 (:translate data-vector-ref)
537 (:args (object :scs (descriptor-reg)))
539 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
540 (:results (value :scs (complex-single-reg)))
541 (:result-types complex-single-float)
543 (let ((real-tn (complex-single-reg-real-tn value)))
544 (with-empty-tn@fp-top (real-tn)
545 (inst fld (make-ea :dword :base object
546 :disp (- (+ (* vector-data-offset
549 other-pointer-lowtag)))))
550 (let ((imag-tn (complex-single-reg-imag-tn value)))
551 (with-empty-tn@fp-top (imag-tn)
552 (inst fld (make-ea :dword :base object
553 :disp (- (+ (* vector-data-offset
556 other-pointer-lowtag)))))))
558 (define-vop (data-vector-set/simple-array-complex-single-float)
559 (:note "inline array store")
560 (:translate data-vector-set)
562 (:args (object :scs (descriptor-reg))
563 (index :scs (any-reg))
564 (value :scs (complex-single-reg) :target result))
565 (:arg-types simple-array-complex-single-float positive-fixnum
566 complex-single-float)
567 (:results (result :scs (complex-single-reg)))
568 (:result-types complex-single-float)
570 (let ((value-real (complex-single-reg-real-tn value))
571 (result-real (complex-single-reg-real-tn result)))
572 (cond ((zerop (tn-offset value-real))
574 (inst fst (make-ea :dword :base object :index index :scale 2
575 :disp (- (* vector-data-offset
577 other-pointer-lowtag)))
578 (unless (zerop (tn-offset result-real))
579 ;; Value is in ST0 but not result.
580 (inst fst result-real)))
582 ;; Value is not in ST0.
583 (inst fxch value-real)
584 (inst fst (make-ea :dword :base object :index index :scale 2
585 :disp (- (* vector-data-offset
587 other-pointer-lowtag)))
588 (cond ((zerop (tn-offset result-real))
589 ;; The result is in ST0.
590 (inst fst value-real))
592 ;; Neither value or result are in ST0
593 (unless (location= value-real result-real)
594 (inst fst result-real))
595 (inst fxch value-real))))))
596 (let ((value-imag (complex-single-reg-imag-tn value))
597 (result-imag (complex-single-reg-imag-tn result)))
598 (inst fxch value-imag)
599 (inst fst (make-ea :dword :base object :index index :scale 2
600 :disp (- (+ (* vector-data-offset
603 other-pointer-lowtag)))
604 (unless (location= value-imag result-imag)
605 (inst fst result-imag))
606 (inst fxch value-imag))))
608 (define-vop (data-vector-set-c/simple-array-complex-single-float)
609 (:note "inline array store")
610 (:translate data-vector-set)
612 (:args (object :scs (descriptor-reg))
613 (value :scs (complex-single-reg) :target result))
615 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
616 complex-single-float)
617 (:results (result :scs (complex-single-reg)))
618 (:result-types complex-single-float)
620 (let ((value-real (complex-single-reg-real-tn value))
621 (result-real (complex-single-reg-real-tn result)))
622 (cond ((zerop (tn-offset value-real))
624 (inst fst (make-ea :dword :base object
625 :disp (- (+ (* vector-data-offset
628 other-pointer-lowtag)))
629 (unless (zerop (tn-offset result-real))
630 ;; Value is in ST0 but not result.
631 (inst fst result-real)))
633 ;; Value is not in ST0.
634 (inst fxch value-real)
635 (inst fst (make-ea :dword :base object
636 :disp (- (+ (* vector-data-offset
639 other-pointer-lowtag)))
640 (cond ((zerop (tn-offset result-real))
641 ;; The result is in ST0.
642 (inst fst value-real))
644 ;; Neither value or result are in ST0
645 (unless (location= value-real result-real)
646 (inst fst result-real))
647 (inst fxch value-real))))))
648 (let ((value-imag (complex-single-reg-imag-tn value))
649 (result-imag (complex-single-reg-imag-tn result)))
650 (inst fxch value-imag)
651 (inst fst (make-ea :dword :base object
652 :disp (- (+ (* vector-data-offset
655 other-pointer-lowtag)))
656 (unless (location= value-imag result-imag)
657 (inst fst result-imag))
658 (inst fxch value-imag))))
661 (define-vop (data-vector-ref/simple-array-complex-double-float)
662 (:note "inline array access")
663 (:translate data-vector-ref)
665 (:args (object :scs (descriptor-reg))
666 (index :scs (any-reg)))
667 (:arg-types simple-array-complex-double-float positive-fixnum)
668 (:results (value :scs (complex-double-reg)))
669 (:result-types complex-double-float)
671 (let ((real-tn (complex-double-reg-real-tn value)))
672 (with-empty-tn@fp-top (real-tn)
673 (inst fldd (make-ea :dword :base object :index index :scale 4
674 :disp (- (* vector-data-offset
676 other-pointer-lowtag)))))
677 (let ((imag-tn (complex-double-reg-imag-tn value)))
678 (with-empty-tn@fp-top (imag-tn)
679 (inst fldd (make-ea :dword :base object :index index :scale 4
680 :disp (- (+ (* vector-data-offset
683 other-pointer-lowtag)))))))
685 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
686 (:note "inline array access")
687 (:translate data-vector-ref)
689 (:args (object :scs (descriptor-reg)))
691 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
692 (:results (value :scs (complex-double-reg)))
693 (:result-types complex-double-float)
695 (let ((real-tn (complex-double-reg-real-tn value)))
696 (with-empty-tn@fp-top (real-tn)
697 (inst fldd (make-ea :dword :base object
698 :disp (- (+ (* vector-data-offset
701 other-pointer-lowtag)))))
702 (let ((imag-tn (complex-double-reg-imag-tn value)))
703 (with-empty-tn@fp-top (imag-tn)
704 (inst fldd (make-ea :dword :base object
705 :disp (- (+ (* vector-data-offset
708 other-pointer-lowtag)))))))
710 (define-vop (data-vector-set/simple-array-complex-double-float)
711 (:note "inline array store")
712 (:translate data-vector-set)
714 (:args (object :scs (descriptor-reg))
715 (index :scs (any-reg))
716 (value :scs (complex-double-reg) :target result))
717 (:arg-types simple-array-complex-double-float positive-fixnum
718 complex-double-float)
719 (:results (result :scs (complex-double-reg)))
720 (:result-types complex-double-float)
722 (let ((value-real (complex-double-reg-real-tn value))
723 (result-real (complex-double-reg-real-tn result)))
724 (cond ((zerop (tn-offset value-real))
726 (inst fstd (make-ea :dword :base object :index index :scale 4
727 :disp (- (* vector-data-offset
729 other-pointer-lowtag)))
730 (unless (zerop (tn-offset result-real))
731 ;; Value is in ST0 but not result.
732 (inst fstd result-real)))
734 ;; Value is not in ST0.
735 (inst fxch value-real)
736 (inst fstd (make-ea :dword :base object :index index :scale 4
737 :disp (- (* vector-data-offset
739 other-pointer-lowtag)))
740 (cond ((zerop (tn-offset result-real))
741 ;; The result is in ST0.
742 (inst fstd value-real))
744 ;; Neither value or result are in ST0
745 (unless (location= value-real result-real)
746 (inst fstd result-real))
747 (inst fxch value-real))))))
748 (let ((value-imag (complex-double-reg-imag-tn value))
749 (result-imag (complex-double-reg-imag-tn result)))
750 (inst fxch value-imag)
751 (inst fstd (make-ea :dword :base object :index index :scale 4
752 :disp (- (+ (* vector-data-offset
755 other-pointer-lowtag)))
756 (unless (location= value-imag result-imag)
757 (inst fstd result-imag))
758 (inst fxch value-imag))))
760 (define-vop (data-vector-set-c/simple-array-complex-double-float)
761 (:note "inline array store")
762 (:translate data-vector-set)
764 (:args (object :scs (descriptor-reg))
765 (value :scs (complex-double-reg) :target result))
767 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
768 complex-double-float)
769 (:results (result :scs (complex-double-reg)))
770 (:result-types complex-double-float)
772 (let ((value-real (complex-double-reg-real-tn value))
773 (result-real (complex-double-reg-real-tn result)))
774 (cond ((zerop (tn-offset value-real))
776 (inst fstd (make-ea :dword :base object
777 :disp (- (+ (* vector-data-offset
780 other-pointer-lowtag)))
781 (unless (zerop (tn-offset result-real))
782 ;; Value is in ST0 but not result.
783 (inst fstd result-real)))
785 ;; Value is not in ST0.
786 (inst fxch value-real)
787 (inst fstd (make-ea :dword :base object
788 :disp (- (+ (* vector-data-offset
791 other-pointer-lowtag)))
792 (cond ((zerop (tn-offset result-real))
793 ;; The result is in ST0.
794 (inst fstd value-real))
796 ;; Neither value or result are in ST0
797 (unless (location= value-real result-real)
798 (inst fstd result-real))
799 (inst fxch value-real))))))
800 (let ((value-imag (complex-double-reg-imag-tn value))
801 (result-imag (complex-double-reg-imag-tn result)))
802 (inst fxch value-imag)
803 (inst fstd (make-ea :dword :base object
804 :disp (- (+ (* vector-data-offset
807 other-pointer-lowtag)))
808 (unless (location= value-imag result-imag)
809 (inst fstd result-imag))
810 (inst fxch value-imag))))
816 (macrolet ((define-data-vector-frobs (ptype)
818 (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
819 (:translate data-vector-ref)
821 (:args (object :scs (descriptor-reg))
822 (index :scs (unsigned-reg)))
823 (:arg-types ,ptype positive-fixnum)
824 (:results (value :scs (unsigned-reg signed-reg)))
825 (:result-types positive-fixnum)
828 (make-ea :byte :base object :index index :scale 1
829 :disp (- (* vector-data-offset n-word-bytes)
830 other-pointer-lowtag)))))
831 (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
832 (:translate data-vector-ref)
834 (:args (object :scs (descriptor-reg)))
836 (:arg-types ,ptype (:constant (signed-byte 30)))
837 (:results (value :scs (unsigned-reg signed-reg)))
838 (:result-types positive-fixnum)
841 (make-ea :byte :base object
842 :disp (- (+ (* vector-data-offset n-word-bytes) index)
843 other-pointer-lowtag)))))
844 (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
845 (:translate data-vector-set)
847 (:args (object :scs (descriptor-reg) :to (:eval 0))
848 (index :scs (unsigned-reg) :to (:eval 0))
849 (value :scs (unsigned-reg signed-reg) :target eax))
850 (:arg-types ,ptype positive-fixnum positive-fixnum)
851 (:temporary (:sc unsigned-reg :offset eax-offset :target result
852 :from (:argument 2) :to (:result 0))
854 (:results (result :scs (unsigned-reg signed-reg)))
855 (:result-types positive-fixnum)
858 (inst mov (make-ea :byte :base object :index index :scale 1
859 :disp (- (* vector-data-offset n-word-bytes)
860 other-pointer-lowtag))
863 (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
864 (:translate data-vector-set)
866 (:args (object :scs (descriptor-reg) :to (:eval 0))
867 (value :scs (unsigned-reg signed-reg) :target eax))
869 (:arg-types ,ptype (:constant (signed-byte 30))
871 (:temporary (:sc unsigned-reg :offset eax-offset :target result
872 :from (:argument 1) :to (:result 0))
874 (:results (result :scs (unsigned-reg signed-reg)))
875 (:result-types positive-fixnum)
878 (inst mov (make-ea :byte :base object
879 :disp (- (+ (* vector-data-offset n-word-bytes) index)
880 other-pointer-lowtag))
882 (move result eax))))))
883 (define-data-vector-frobs simple-array-unsigned-byte-7)
884 (define-data-vector-frobs simple-array-unsigned-byte-8))
887 (macrolet ((define-data-vector-frobs (ptype)
889 (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
890 (:translate data-vector-ref)
892 (:args (object :scs (descriptor-reg))
893 (index :scs (unsigned-reg)))
894 (:arg-types ,ptype positive-fixnum)
895 (:results (value :scs (unsigned-reg signed-reg)))
896 (:result-types positive-fixnum)
899 (make-ea :word :base object :index index :scale 2
900 :disp (- (* vector-data-offset n-word-bytes)
901 other-pointer-lowtag)))))
902 (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
903 (:translate data-vector-ref)
905 (:args (object :scs (descriptor-reg)))
907 (:arg-types ,ptype (:constant (signed-byte 30)))
908 (:results (value :scs (unsigned-reg signed-reg)))
909 (:result-types positive-fixnum)
912 (make-ea :word :base object
913 :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
914 other-pointer-lowtag)))))
915 (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
916 (:translate data-vector-set)
918 (:args (object :scs (descriptor-reg) :to (:eval 0))
919 (index :scs (unsigned-reg) :to (:eval 0))
920 (value :scs (unsigned-reg signed-reg) :target eax))
921 (:arg-types ,ptype positive-fixnum positive-fixnum)
922 (:temporary (:sc unsigned-reg :offset eax-offset :target result
923 :from (:argument 2) :to (:result 0))
925 (:results (result :scs (unsigned-reg signed-reg)))
926 (:result-types positive-fixnum)
929 (inst mov (make-ea :word :base object :index index :scale 2
930 :disp (- (* vector-data-offset n-word-bytes)
931 other-pointer-lowtag))
935 (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
936 (:translate data-vector-set)
938 (:args (object :scs (descriptor-reg) :to (:eval 0))
939 (value :scs (unsigned-reg signed-reg) :target eax))
941 (:arg-types ,ptype (:constant (signed-byte 30))
943 (:temporary (:sc unsigned-reg :offset eax-offset :target result
944 :from (:argument 1) :to (:result 0))
946 (:results (result :scs (unsigned-reg signed-reg)))
947 (:result-types positive-fixnum)
950 (inst mov (make-ea :word :base object
951 :disp (- (+ (* vector-data-offset n-word-bytes)
953 other-pointer-lowtag))
955 (move result eax))))))
956 (define-data-vector-frobs simple-array-unsigned-byte-15)
957 (define-data-vector-frobs simple-array-unsigned-byte-16))
963 (define-vop (data-vector-ref/simple-base-string)
964 (:translate data-vector-ref)
966 (:args (object :scs (descriptor-reg))
967 (index :scs (unsigned-reg)))
968 (:arg-types simple-base-string positive-fixnum)
969 (:results (value :scs (character-reg)))
970 (:result-types character)
973 (make-ea :byte :base object :index index :scale 1
974 :disp (- (* vector-data-offset n-word-bytes)
975 other-pointer-lowtag)))))
977 (define-vop (data-vector-ref-c/simple-base-string)
978 (:translate data-vector-ref)
980 (:args (object :scs (descriptor-reg)))
982 (:arg-types simple-base-string (:constant (signed-byte 30)))
983 (:results (value :scs (character-reg)))
984 (:result-types character)
987 (make-ea :byte :base object
988 :disp (- (+ (* vector-data-offset n-word-bytes) index)
989 other-pointer-lowtag)))))
991 (define-vop (data-vector-set/simple-base-string)
992 (:translate data-vector-set)
994 (:args (object :scs (descriptor-reg) :to (:eval 0))
995 (index :scs (unsigned-reg) :to (:eval 0))
996 (value :scs (character-reg) :target eax))
997 (:arg-types simple-base-string positive-fixnum character)
998 (:temporary (:sc character-reg :offset eax-offset :target result
999 :from (:argument 2) :to (:result 0))
1001 (:results (result :scs (character-reg)))
1002 (:result-types character)
1005 (inst mov (make-ea :byte :base object :index index :scale 1
1006 :disp (- (* vector-data-offset n-word-bytes)
1007 other-pointer-lowtag))
1011 (define-vop (data-vector-set-c/simple-base-string)
1012 (:translate data-vector-set)
1013 (:policy :fast-safe)
1014 (:args (object :scs (descriptor-reg) :to (:eval 0))
1015 (value :scs (character-reg)))
1017 (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1018 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1019 :from (:argument 1) :to (:result 0))
1021 (:results (result :scs (character-reg)))
1022 (:result-types character)
1025 (inst mov (make-ea :byte :base object
1026 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1027 other-pointer-lowtag))
1034 (define-vop (data-vector-ref/simple-base-string)
1035 (:translate data-vector-ref)
1036 (:policy :fast-safe)
1037 (:args (object :scs (descriptor-reg))
1038 (index :scs (unsigned-reg)))
1039 (:arg-types simple-base-string positive-fixnum)
1040 (:results (value :scs (character-reg)))
1041 (:result-types character)
1044 (make-ea :byte :base object :index index :scale 1
1045 :disp (- (* vector-data-offset n-word-bytes)
1046 other-pointer-lowtag)))))
1048 (define-vop (data-vector-ref-c/simple-base-string)
1049 (:translate data-vector-ref)
1050 (:policy :fast-safe)
1051 (:args (object :scs (descriptor-reg)))
1053 (:arg-types simple-base-string (:constant (signed-byte 30)))
1054 (:results (value :scs (character-reg)))
1055 (:result-types character)
1058 (make-ea :byte :base object
1059 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1060 other-pointer-lowtag)))))
1062 (define-vop (data-vector-set/simple-base-string)
1063 (:translate data-vector-set)
1064 (:policy :fast-safe)
1065 (:args (object :scs (descriptor-reg) :to (:eval 0))
1066 (index :scs (unsigned-reg) :to (:eval 0))
1067 (value :scs (character-reg) :target result))
1068 (:arg-types simple-base-string positive-fixnum character)
1069 (:results (result :scs (character-reg)))
1070 (:result-types character)
1072 (inst mov (make-ea :byte :base object :index index :scale 1
1073 :disp (- (* vector-data-offset n-word-bytes)
1074 other-pointer-lowtag))
1076 (move result value)))
1078 (define-vop (data-vector-set-c/simple-base-string)
1079 (:translate data-vector-set)
1080 (:policy :fast-safe)
1081 (:args (object :scs (descriptor-reg) :to (:eval 0))
1082 (value :scs (character-reg)))
1084 (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1085 (:results (result :scs (character-reg)))
1086 (:result-types character)
1088 (inst mov (make-ea :byte :base object
1089 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1090 other-pointer-lowtag))
1092 (move result value)))
1096 (define-full-reffer data-vector-ref/simple-character-string
1097 simple-character-string vector-data-offset other-pointer-lowtag
1098 (character-reg) character data-vector-ref)
1100 (define-full-setter data-vector-set/simple-character-string
1101 simple-character-string vector-data-offset other-pointer-lowtag
1102 (character-reg) character data-vector-set)
1106 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1107 (:translate data-vector-ref)
1108 (:policy :fast-safe)
1109 (:args (object :scs (descriptor-reg))
1110 (index :scs (unsigned-reg)))
1111 (:arg-types simple-array-signed-byte-8 positive-fixnum)
1112 (:results (value :scs (signed-reg)))
1113 (:result-types tagged-num)
1116 (make-ea :byte :base object :index index :scale 1
1117 :disp (- (* vector-data-offset n-word-bytes)
1118 other-pointer-lowtag)))))
1120 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1121 (:translate data-vector-ref)
1122 (:policy :fast-safe)
1123 (:args (object :scs (descriptor-reg)))
1125 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1126 (:results (value :scs (signed-reg)))
1127 (:result-types tagged-num)
1130 (make-ea :byte :base object
1131 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1132 other-pointer-lowtag)))))
1134 (define-vop (data-vector-set/simple-array-signed-byte-8)
1135 (:translate data-vector-set)
1136 (:policy :fast-safe)
1137 (:args (object :scs (descriptor-reg) :to (:eval 0))
1138 (index :scs (unsigned-reg) :to (:eval 0))
1139 (value :scs (signed-reg) :target eax))
1140 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1141 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1142 :from (:argument 2) :to (:result 0))
1144 (:results (result :scs (signed-reg)))
1145 (:result-types tagged-num)
1148 (inst mov (make-ea :byte :base object :index index :scale 1
1149 :disp (- (* vector-data-offset n-word-bytes)
1150 other-pointer-lowtag))
1154 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1155 (:translate data-vector-set)
1156 (:policy :fast-safe)
1157 (:args (object :scs (descriptor-reg) :to (:eval 0))
1158 (value :scs (signed-reg) :target eax))
1160 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1162 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1163 :from (:argument 1) :to (:result 0))
1165 (:results (result :scs (signed-reg)))
1166 (:result-types tagged-num)
1169 (inst mov (make-ea :byte :base object
1170 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1171 other-pointer-lowtag))
1177 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1178 (:translate data-vector-ref)
1179 (:policy :fast-safe)
1180 (:args (object :scs (descriptor-reg))
1181 (index :scs (unsigned-reg)))
1182 (:arg-types simple-array-signed-byte-16 positive-fixnum)
1183 (:results (value :scs (signed-reg)))
1184 (:result-types tagged-num)
1187 (make-ea :word :base object :index index :scale 2
1188 :disp (- (* vector-data-offset n-word-bytes)
1189 other-pointer-lowtag)))))
1191 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1192 (:translate data-vector-ref)
1193 (:policy :fast-safe)
1194 (:args (object :scs (descriptor-reg)))
1196 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1197 (:results (value :scs (signed-reg)))
1198 (:result-types tagged-num)
1201 (make-ea :word :base object
1202 :disp (- (+ (* vector-data-offset n-word-bytes)
1204 other-pointer-lowtag)))))
1206 (define-vop (data-vector-set/simple-array-signed-byte-16)
1207 (:translate data-vector-set)
1208 (:policy :fast-safe)
1209 (:args (object :scs (descriptor-reg) :to (:eval 0))
1210 (index :scs (unsigned-reg) :to (:eval 0))
1211 (value :scs (signed-reg) :target eax))
1212 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1213 (:temporary (:sc signed-reg :offset eax-offset :target result
1214 :from (:argument 2) :to (:result 0))
1216 (:results (result :scs (signed-reg)))
1217 (:result-types tagged-num)
1220 (inst mov (make-ea :word :base object :index index :scale 2
1221 :disp (- (* vector-data-offset n-word-bytes)
1222 other-pointer-lowtag))
1226 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1227 (:translate data-vector-set)
1228 (:policy :fast-safe)
1229 (:args (object :scs (descriptor-reg) :to (:eval 0))
1230 (value :scs (signed-reg) :target eax))
1232 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1233 (:temporary (:sc signed-reg :offset eax-offset :target result
1234 :from (:argument 1) :to (:result 0))
1236 (:results (result :scs (signed-reg)))
1237 (:result-types tagged-num)
1241 (make-ea :word :base object
1242 :disp (- (+ (* vector-data-offset n-word-bytes)
1244 other-pointer-lowtag))
1248 ;;; These VOPs are used for implementing float slots in structures (whose raw
1249 ;;; data is an unsigned-32 vector).
1250 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
1251 (:translate %raw-ref-single)
1252 (:arg-types sb!c::raw-vector positive-fixnum))
1253 (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
1254 (:translate %raw-ref-single)
1255 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1256 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
1257 (:translate %raw-set-single)
1258 (:arg-types sb!c::raw-vector positive-fixnum single-float))
1259 (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
1260 (:translate %raw-set-single)
1261 (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) single-float))
1262 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
1263 (:translate %raw-ref-double)
1264 (:arg-types sb!c::raw-vector positive-fixnum))
1265 (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
1266 (:translate %raw-ref-double)
1267 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1268 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
1269 (:translate %raw-set-double)
1270 (:arg-types sb!c::raw-vector positive-fixnum double-float))
1271 (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
1272 (:translate %raw-set-double)
1273 (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) double-float))
1276 ;;;; complex-float raw structure slot accessors
1278 (define-vop (raw-ref-complex-single
1279 data-vector-ref/simple-array-complex-single-float)
1280 (:translate %raw-ref-complex-single)
1281 (:arg-types sb!c::raw-vector positive-fixnum))
1282 (define-vop (raw-ref-complex-single-c
1283 data-vector-ref-c/simple-array-complex-single-float)
1284 (:translate %raw-ref-complex-single)
1285 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1286 (define-vop (raw-set-complex-single
1287 data-vector-set/simple-array-complex-single-float)
1288 (:translate %raw-set-complex-single)
1289 (:arg-types sb!c::raw-vector positive-fixnum complex-single-float))
1290 (define-vop (raw-set-complex-single-c
1291 data-vector-set-c/simple-array-complex-single-float)
1292 (:translate %raw-set-complex-single)
1293 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1294 complex-single-float))
1295 (define-vop (raw-ref-complex-double
1296 data-vector-ref/simple-array-complex-double-float)
1297 (:translate %raw-ref-complex-double)
1298 (:arg-types sb!c::raw-vector positive-fixnum))
1299 (define-vop (raw-ref-complex-double-c
1300 data-vector-ref-c/simple-array-complex-double-float)
1301 (:translate %raw-ref-complex-double)
1302 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1303 (define-vop (raw-set-complex-double
1304 data-vector-set/simple-array-complex-double-float)
1305 (:translate %raw-set-complex-double)
1306 (:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
1307 (define-vop (raw-set-complex-double-c
1308 data-vector-set-c/simple-array-complex-double-float)
1309 (:translate %raw-set-complex-double)
1310 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1311 complex-double-float))
1314 ;;; These vops are useful for accessing the bits of a vector
1315 ;;; irrespective of what type of vector it is.
1316 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1317 unsigned-num %raw-bits)
1318 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1319 unsigned-num %set-raw-bits)
1321 ;;;; miscellaneous array VOPs
1323 (define-vop (get-vector-subtype get-header-data))
1324 (define-vop (set-vector-subtype set-header-data))