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 n-word-bits 0)
264 (lognot (ash mask shift)))))
265 (unless (zerop value)
266 (inst or old (ash value shift)))))
268 (let ((shift (* extra ,bits)))
269 (unless (zerop shift)
270 (inst ror old shift))
271 (inst and old (lognot ,(1- (ash 1 bits))))
273 (unless (zerop shift)
274 (inst rol old shift)))))
275 (inst mov (make-ea :dword :base object
276 :disp (- (* (+ word vector-data-offset)
278 other-pointer-lowtag))
282 (inst mov result (tn-value value)))
284 (move result value))))))))))
285 (def-small-data-vector-frobs simple-bit-vector 1)
286 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
287 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
289 ;;; And the float variants.
291 (define-vop (data-vector-ref/simple-array-single-float)
292 (:note "inline array access")
293 (:translate data-vector-ref)
295 (:args (object :scs (descriptor-reg))
296 (index :scs (any-reg)))
297 (:arg-types simple-array-single-float positive-fixnum)
298 (:results (value :scs (single-reg)))
299 (:result-types single-float)
301 (with-empty-tn@fp-top(value)
302 (inst fld (make-ea :dword :base object :index index :scale 1
303 :disp (- (* vector-data-offset
305 other-pointer-lowtag))))))
307 (define-vop (data-vector-ref-c/simple-array-single-float)
308 (:note "inline array access")
309 (:translate data-vector-ref)
311 (:args (object :scs (descriptor-reg)))
313 (:arg-types simple-array-single-float (:constant (signed-byte 30)))
314 (:results (value :scs (single-reg)))
315 (:result-types single-float)
317 (with-empty-tn@fp-top(value)
318 (inst fld (make-ea :dword :base object
319 :disp (- (+ (* vector-data-offset
322 other-pointer-lowtag))))))
324 (define-vop (data-vector-set/simple-array-single-float)
325 (:note "inline array store")
326 (:translate data-vector-set)
328 (:args (object :scs (descriptor-reg))
329 (index :scs (any-reg))
330 (value :scs (single-reg) :target result))
331 (:arg-types simple-array-single-float positive-fixnum single-float)
332 (:results (result :scs (single-reg)))
333 (:result-types single-float)
335 (cond ((zerop (tn-offset value))
337 (inst fst (make-ea :dword :base object :index index :scale 1
338 :disp (- (* vector-data-offset
340 other-pointer-lowtag)))
341 (unless (zerop (tn-offset result))
342 ;; Value is in ST0 but not result.
345 ;; Value is not in ST0.
347 (inst fst (make-ea :dword :base object :index index :scale 1
348 :disp (- (* vector-data-offset
350 other-pointer-lowtag)))
351 (cond ((zerop (tn-offset result))
352 ;; The result is in ST0.
355 ;; Neither value or result are in ST0
356 (unless (location= value result)
358 (inst fxch value)))))))
360 (define-vop (data-vector-set-c/simple-array-single-float)
361 (:note "inline array store")
362 (:translate data-vector-set)
364 (:args (object :scs (descriptor-reg))
365 (value :scs (single-reg) :target result))
367 (:arg-types simple-array-single-float (:constant (signed-byte 30))
369 (:results (result :scs (single-reg)))
370 (:result-types single-float)
372 (cond ((zerop (tn-offset value))
374 (inst fst (make-ea :dword :base object
375 :disp (- (+ (* vector-data-offset
378 other-pointer-lowtag)))
379 (unless (zerop (tn-offset result))
380 ;; Value is in ST0 but not result.
383 ;; Value is not in ST0.
385 (inst fst (make-ea :dword :base object
386 :disp (- (+ (* vector-data-offset
389 other-pointer-lowtag)))
390 (cond ((zerop (tn-offset result))
391 ;; The result is in ST0.
394 ;; Neither value or result are in ST0
395 (unless (location= value result)
397 (inst fxch value)))))))
399 (define-vop (data-vector-ref/simple-array-double-float)
400 (:note "inline array access")
401 (:translate data-vector-ref)
403 (:args (object :scs (descriptor-reg))
404 (index :scs (any-reg)))
405 (:arg-types simple-array-double-float positive-fixnum)
406 (:results (value :scs (double-reg)))
407 (:result-types double-float)
409 (with-empty-tn@fp-top(value)
410 (inst fldd (make-ea :dword :base object :index index :scale 2
411 :disp (- (* vector-data-offset
413 other-pointer-lowtag))))))
415 (define-vop (data-vector-ref-c/simple-array-double-float)
416 (:note "inline array access")
417 (:translate data-vector-ref)
419 (:args (object :scs (descriptor-reg)))
421 (:arg-types simple-array-double-float (:constant (signed-byte 30)))
422 (:results (value :scs (double-reg)))
423 (:result-types double-float)
425 (with-empty-tn@fp-top(value)
426 (inst fldd (make-ea :dword :base object
427 :disp (- (+ (* vector-data-offset
430 other-pointer-lowtag))))))
432 (define-vop (data-vector-set/simple-array-double-float)
433 (:note "inline array store")
434 (:translate data-vector-set)
436 (:args (object :scs (descriptor-reg))
437 (index :scs (any-reg))
438 (value :scs (double-reg) :target result))
439 (:arg-types simple-array-double-float positive-fixnum double-float)
440 (:results (result :scs (double-reg)))
441 (:result-types double-float)
443 (cond ((zerop (tn-offset value))
445 (inst fstd (make-ea :dword :base object :index index :scale 2
446 :disp (- (* vector-data-offset
448 other-pointer-lowtag)))
449 (unless (zerop (tn-offset result))
450 ;; Value is in ST0 but not result.
453 ;; Value is not in ST0.
455 (inst fstd (make-ea :dword :base object :index index :scale 2
456 :disp (- (* vector-data-offset
458 other-pointer-lowtag)))
459 (cond ((zerop (tn-offset result))
460 ;; The result is in ST0.
463 ;; Neither value or result are in ST0
464 (unless (location= value result)
466 (inst fxch value)))))))
468 (define-vop (data-vector-set-c/simple-array-double-float)
469 (:note "inline array store")
470 (:translate data-vector-set)
472 (:args (object :scs (descriptor-reg))
473 (value :scs (double-reg) :target result))
475 (:arg-types simple-array-double-float (:constant (signed-byte 30))
477 (:results (result :scs (double-reg)))
478 (:result-types double-float)
480 (cond ((zerop (tn-offset value))
482 (inst fstd (make-ea :dword :base object
483 :disp (- (+ (* vector-data-offset
486 other-pointer-lowtag)))
487 (unless (zerop (tn-offset result))
488 ;; Value is in ST0 but not result.
491 ;; Value is not in ST0.
493 (inst fstd (make-ea :dword :base object
494 :disp (- (+ (* vector-data-offset
497 other-pointer-lowtag)))
498 (cond ((zerop (tn-offset result))
499 ;; The result is in ST0.
502 ;; Neither value or result are in ST0
503 (unless (location= value result)
505 (inst fxch value)))))))
509 ;;; complex float variants
511 (define-vop (data-vector-ref/simple-array-complex-single-float)
512 (:note "inline array access")
513 (:translate data-vector-ref)
515 (:args (object :scs (descriptor-reg))
516 (index :scs (any-reg)))
517 (:arg-types simple-array-complex-single-float positive-fixnum)
518 (:results (value :scs (complex-single-reg)))
519 (:result-types complex-single-float)
521 (let ((real-tn (complex-single-reg-real-tn value)))
522 (with-empty-tn@fp-top (real-tn)
523 (inst fld (make-ea :dword :base object :index index :scale 2
524 :disp (- (* vector-data-offset
526 other-pointer-lowtag)))))
527 (let ((imag-tn (complex-single-reg-imag-tn value)))
528 (with-empty-tn@fp-top (imag-tn)
529 (inst fld (make-ea :dword :base object :index index :scale 2
530 :disp (- (* (1+ vector-data-offset)
532 other-pointer-lowtag)))))))
534 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
535 (:note "inline array access")
536 (:translate data-vector-ref)
538 (:args (object :scs (descriptor-reg)))
540 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
541 (:results (value :scs (complex-single-reg)))
542 (:result-types complex-single-float)
544 (let ((real-tn (complex-single-reg-real-tn value)))
545 (with-empty-tn@fp-top (real-tn)
546 (inst fld (make-ea :dword :base object
547 :disp (- (+ (* vector-data-offset
550 other-pointer-lowtag)))))
551 (let ((imag-tn (complex-single-reg-imag-tn value)))
552 (with-empty-tn@fp-top (imag-tn)
553 (inst fld (make-ea :dword :base object
554 :disp (- (+ (* vector-data-offset
557 other-pointer-lowtag)))))))
559 (define-vop (data-vector-set/simple-array-complex-single-float)
560 (:note "inline array store")
561 (:translate data-vector-set)
563 (:args (object :scs (descriptor-reg))
564 (index :scs (any-reg))
565 (value :scs (complex-single-reg) :target result))
566 (:arg-types simple-array-complex-single-float positive-fixnum
567 complex-single-float)
568 (:results (result :scs (complex-single-reg)))
569 (:result-types complex-single-float)
571 (let ((value-real (complex-single-reg-real-tn value))
572 (result-real (complex-single-reg-real-tn result)))
573 (cond ((zerop (tn-offset value-real))
575 (inst fst (make-ea :dword :base object :index index :scale 2
576 :disp (- (* vector-data-offset
578 other-pointer-lowtag)))
579 (unless (zerop (tn-offset result-real))
580 ;; Value is in ST0 but not result.
581 (inst fst result-real)))
583 ;; Value is not in ST0.
584 (inst fxch value-real)
585 (inst fst (make-ea :dword :base object :index index :scale 2
586 :disp (- (* vector-data-offset
588 other-pointer-lowtag)))
589 (cond ((zerop (tn-offset result-real))
590 ;; The result is in ST0.
591 (inst fst value-real))
593 ;; Neither value or result are in ST0
594 (unless (location= value-real result-real)
595 (inst fst result-real))
596 (inst fxch value-real))))))
597 (let ((value-imag (complex-single-reg-imag-tn value))
598 (result-imag (complex-single-reg-imag-tn result)))
599 (inst fxch value-imag)
600 (inst fst (make-ea :dword :base object :index index :scale 2
601 :disp (- (+ (* vector-data-offset
604 other-pointer-lowtag)))
605 (unless (location= value-imag result-imag)
606 (inst fst result-imag))
607 (inst fxch value-imag))))
609 (define-vop (data-vector-set-c/simple-array-complex-single-float)
610 (:note "inline array store")
611 (:translate data-vector-set)
613 (:args (object :scs (descriptor-reg))
614 (value :scs (complex-single-reg) :target result))
616 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
617 complex-single-float)
618 (:results (result :scs (complex-single-reg)))
619 (:result-types complex-single-float)
621 (let ((value-real (complex-single-reg-real-tn value))
622 (result-real (complex-single-reg-real-tn result)))
623 (cond ((zerop (tn-offset value-real))
625 (inst fst (make-ea :dword :base object
626 :disp (- (+ (* vector-data-offset
629 other-pointer-lowtag)))
630 (unless (zerop (tn-offset result-real))
631 ;; Value is in ST0 but not result.
632 (inst fst result-real)))
634 ;; Value is not in ST0.
635 (inst fxch value-real)
636 (inst fst (make-ea :dword :base object
637 :disp (- (+ (* vector-data-offset
640 other-pointer-lowtag)))
641 (cond ((zerop (tn-offset result-real))
642 ;; The result is in ST0.
643 (inst fst value-real))
645 ;; Neither value or result are in ST0
646 (unless (location= value-real result-real)
647 (inst fst result-real))
648 (inst fxch value-real))))))
649 (let ((value-imag (complex-single-reg-imag-tn value))
650 (result-imag (complex-single-reg-imag-tn result)))
651 (inst fxch value-imag)
652 (inst fst (make-ea :dword :base object
653 :disp (- (+ (* vector-data-offset
656 other-pointer-lowtag)))
657 (unless (location= value-imag result-imag)
658 (inst fst result-imag))
659 (inst fxch value-imag))))
662 (define-vop (data-vector-ref/simple-array-complex-double-float)
663 (:note "inline array access")
664 (:translate data-vector-ref)
666 (:args (object :scs (descriptor-reg))
667 (index :scs (any-reg)))
668 (:arg-types simple-array-complex-double-float positive-fixnum)
669 (:results (value :scs (complex-double-reg)))
670 (:result-types complex-double-float)
672 (let ((real-tn (complex-double-reg-real-tn value)))
673 (with-empty-tn@fp-top (real-tn)
674 (inst fldd (make-ea :dword :base object :index index :scale 4
675 :disp (- (* vector-data-offset
677 other-pointer-lowtag)))))
678 (let ((imag-tn (complex-double-reg-imag-tn value)))
679 (with-empty-tn@fp-top (imag-tn)
680 (inst fldd (make-ea :dword :base object :index index :scale 4
681 :disp (- (+ (* vector-data-offset
684 other-pointer-lowtag)))))))
686 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
687 (:note "inline array access")
688 (:translate data-vector-ref)
690 (:args (object :scs (descriptor-reg)))
692 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
693 (:results (value :scs (complex-double-reg)))
694 (:result-types complex-double-float)
696 (let ((real-tn (complex-double-reg-real-tn value)))
697 (with-empty-tn@fp-top (real-tn)
698 (inst fldd (make-ea :dword :base object
699 :disp (- (+ (* vector-data-offset
702 other-pointer-lowtag)))))
703 (let ((imag-tn (complex-double-reg-imag-tn value)))
704 (with-empty-tn@fp-top (imag-tn)
705 (inst fldd (make-ea :dword :base object
706 :disp (- (+ (* vector-data-offset
709 other-pointer-lowtag)))))))
711 (define-vop (data-vector-set/simple-array-complex-double-float)
712 (:note "inline array store")
713 (:translate data-vector-set)
715 (:args (object :scs (descriptor-reg))
716 (index :scs (any-reg))
717 (value :scs (complex-double-reg) :target result))
718 (:arg-types simple-array-complex-double-float positive-fixnum
719 complex-double-float)
720 (:results (result :scs (complex-double-reg)))
721 (:result-types complex-double-float)
723 (let ((value-real (complex-double-reg-real-tn value))
724 (result-real (complex-double-reg-real-tn result)))
725 (cond ((zerop (tn-offset value-real))
727 (inst fstd (make-ea :dword :base object :index index :scale 4
728 :disp (- (* vector-data-offset
730 other-pointer-lowtag)))
731 (unless (zerop (tn-offset result-real))
732 ;; Value is in ST0 but not result.
733 (inst fstd result-real)))
735 ;; Value is not in ST0.
736 (inst fxch value-real)
737 (inst fstd (make-ea :dword :base object :index index :scale 4
738 :disp (- (* vector-data-offset
740 other-pointer-lowtag)))
741 (cond ((zerop (tn-offset result-real))
742 ;; The result is in ST0.
743 (inst fstd value-real))
745 ;; Neither value or result are in ST0
746 (unless (location= value-real result-real)
747 (inst fstd result-real))
748 (inst fxch value-real))))))
749 (let ((value-imag (complex-double-reg-imag-tn value))
750 (result-imag (complex-double-reg-imag-tn result)))
751 (inst fxch value-imag)
752 (inst fstd (make-ea :dword :base object :index index :scale 4
753 :disp (- (+ (* vector-data-offset
756 other-pointer-lowtag)))
757 (unless (location= value-imag result-imag)
758 (inst fstd result-imag))
759 (inst fxch value-imag))))
761 (define-vop (data-vector-set-c/simple-array-complex-double-float)
762 (:note "inline array store")
763 (:translate data-vector-set)
765 (:args (object :scs (descriptor-reg))
766 (value :scs (complex-double-reg) :target result))
768 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
769 complex-double-float)
770 (:results (result :scs (complex-double-reg)))
771 (:result-types complex-double-float)
773 (let ((value-real (complex-double-reg-real-tn value))
774 (result-real (complex-double-reg-real-tn result)))
775 (cond ((zerop (tn-offset value-real))
777 (inst fstd (make-ea :dword :base object
778 :disp (- (+ (* vector-data-offset
781 other-pointer-lowtag)))
782 (unless (zerop (tn-offset result-real))
783 ;; Value is in ST0 but not result.
784 (inst fstd result-real)))
786 ;; Value is not in ST0.
787 (inst fxch value-real)
788 (inst fstd (make-ea :dword :base object
789 :disp (- (+ (* vector-data-offset
792 other-pointer-lowtag)))
793 (cond ((zerop (tn-offset result-real))
794 ;; The result is in ST0.
795 (inst fstd value-real))
797 ;; Neither value or result are in ST0
798 (unless (location= value-real result-real)
799 (inst fstd result-real))
800 (inst fxch value-real))))))
801 (let ((value-imag (complex-double-reg-imag-tn value))
802 (result-imag (complex-double-reg-imag-tn result)))
803 (inst fxch value-imag)
804 (inst fstd (make-ea :dword :base object
805 :disp (- (+ (* vector-data-offset
808 other-pointer-lowtag)))
809 (unless (location= value-imag result-imag)
810 (inst fstd result-imag))
811 (inst fxch value-imag))))
817 (macrolet ((define-data-vector-frobs (ptype)
819 (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
820 (:translate data-vector-ref)
822 (:args (object :scs (descriptor-reg))
823 (index :scs (unsigned-reg)))
824 (:arg-types ,ptype positive-fixnum)
825 (:results (value :scs (unsigned-reg signed-reg)))
826 (:result-types positive-fixnum)
829 (make-ea :byte :base object :index index :scale 1
830 :disp (- (* vector-data-offset n-word-bytes)
831 other-pointer-lowtag)))))
832 (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
833 (:translate data-vector-ref)
835 (:args (object :scs (descriptor-reg)))
837 (:arg-types ,ptype (:constant (signed-byte 30)))
838 (:results (value :scs (unsigned-reg signed-reg)))
839 (:result-types positive-fixnum)
842 (make-ea :byte :base object
843 :disp (- (+ (* vector-data-offset n-word-bytes) index)
844 other-pointer-lowtag)))))
845 (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
846 (:translate data-vector-set)
848 (:args (object :scs (descriptor-reg) :to (:eval 0))
849 (index :scs (unsigned-reg) :to (:eval 0))
850 (value :scs (unsigned-reg signed-reg) :target eax))
851 (:arg-types ,ptype positive-fixnum positive-fixnum)
852 (:temporary (:sc unsigned-reg :offset eax-offset :target result
853 :from (:argument 2) :to (:result 0))
855 (:results (result :scs (unsigned-reg signed-reg)))
856 (:result-types positive-fixnum)
859 (inst mov (make-ea :byte :base object :index index :scale 1
860 :disp (- (* vector-data-offset n-word-bytes)
861 other-pointer-lowtag))
864 (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
865 (:translate data-vector-set)
867 (:args (object :scs (descriptor-reg) :to (:eval 0))
868 (value :scs (unsigned-reg signed-reg) :target eax))
870 (:arg-types ,ptype (:constant (signed-byte 30))
872 (:temporary (:sc unsigned-reg :offset eax-offset :target result
873 :from (:argument 1) :to (:result 0))
875 (:results (result :scs (unsigned-reg signed-reg)))
876 (:result-types positive-fixnum)
879 (inst mov (make-ea :byte :base object
880 :disp (- (+ (* vector-data-offset n-word-bytes) index)
881 other-pointer-lowtag))
883 (move result eax))))))
884 (define-data-vector-frobs simple-array-unsigned-byte-7)
885 (define-data-vector-frobs simple-array-unsigned-byte-8))
888 (macrolet ((define-data-vector-frobs (ptype)
890 (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
891 (:translate data-vector-ref)
893 (:args (object :scs (descriptor-reg))
894 (index :scs (unsigned-reg)))
895 (:arg-types ,ptype positive-fixnum)
896 (:results (value :scs (unsigned-reg signed-reg)))
897 (:result-types positive-fixnum)
900 (make-ea :word :base object :index index :scale 2
901 :disp (- (* vector-data-offset n-word-bytes)
902 other-pointer-lowtag)))))
903 (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
904 (:translate data-vector-ref)
906 (:args (object :scs (descriptor-reg)))
908 (:arg-types ,ptype (:constant (signed-byte 30)))
909 (:results (value :scs (unsigned-reg signed-reg)))
910 (:result-types positive-fixnum)
913 (make-ea :word :base object
914 :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
915 other-pointer-lowtag)))))
916 (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
917 (:translate data-vector-set)
919 (:args (object :scs (descriptor-reg) :to (:eval 0))
920 (index :scs (unsigned-reg) :to (:eval 0))
921 (value :scs (unsigned-reg signed-reg) :target eax))
922 (:arg-types ,ptype positive-fixnum positive-fixnum)
923 (:temporary (:sc unsigned-reg :offset eax-offset :target result
924 :from (:argument 2) :to (:result 0))
926 (:results (result :scs (unsigned-reg signed-reg)))
927 (:result-types positive-fixnum)
930 (inst mov (make-ea :word :base object :index index :scale 2
931 :disp (- (* vector-data-offset n-word-bytes)
932 other-pointer-lowtag))
936 (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
937 (:translate data-vector-set)
939 (:args (object :scs (descriptor-reg) :to (:eval 0))
940 (value :scs (unsigned-reg signed-reg) :target eax))
942 (:arg-types ,ptype (:constant (signed-byte 30))
944 (:temporary (:sc unsigned-reg :offset eax-offset :target result
945 :from (:argument 1) :to (:result 0))
947 (:results (result :scs (unsigned-reg signed-reg)))
948 (:result-types positive-fixnum)
951 (inst mov (make-ea :word :base object
952 :disp (- (+ (* vector-data-offset n-word-bytes)
954 other-pointer-lowtag))
956 (move result eax))))))
957 (define-data-vector-frobs simple-array-unsigned-byte-15)
958 (define-data-vector-frobs simple-array-unsigned-byte-16))
964 (define-vop (data-vector-ref/simple-base-string)
965 (:translate data-vector-ref)
967 (:args (object :scs (descriptor-reg))
968 (index :scs (unsigned-reg)))
969 (:arg-types simple-base-string positive-fixnum)
970 (:results (value :scs (character-reg)))
971 (:result-types character)
974 (make-ea :byte :base object :index index :scale 1
975 :disp (- (* vector-data-offset n-word-bytes)
976 other-pointer-lowtag)))))
978 (define-vop (data-vector-ref-c/simple-base-string)
979 (:translate data-vector-ref)
981 (:args (object :scs (descriptor-reg)))
983 (:arg-types simple-base-string (:constant (signed-byte 30)))
984 (:results (value :scs (character-reg)))
985 (:result-types character)
988 (make-ea :byte :base object
989 :disp (- (+ (* vector-data-offset n-word-bytes) index)
990 other-pointer-lowtag)))))
992 (define-vop (data-vector-set/simple-base-string)
993 (:translate data-vector-set)
995 (:args (object :scs (descriptor-reg) :to (:eval 0))
996 (index :scs (unsigned-reg) :to (:eval 0))
997 (value :scs (character-reg) :target eax))
998 (:arg-types simple-base-string positive-fixnum character)
999 (:temporary (:sc character-reg :offset eax-offset :target result
1000 :from (:argument 2) :to (:result 0))
1002 (:results (result :scs (character-reg)))
1003 (:result-types character)
1006 (inst mov (make-ea :byte :base object :index index :scale 1
1007 :disp (- (* vector-data-offset n-word-bytes)
1008 other-pointer-lowtag))
1012 (define-vop (data-vector-set-c/simple-base-string)
1013 (:translate data-vector-set)
1014 (:policy :fast-safe)
1015 (:args (object :scs (descriptor-reg) :to (:eval 0))
1016 (value :scs (character-reg)))
1018 (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1019 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1020 :from (:argument 1) :to (:result 0))
1022 (:results (result :scs (character-reg)))
1023 (:result-types character)
1026 (inst mov (make-ea :byte :base object
1027 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1028 other-pointer-lowtag))
1035 (define-vop (data-vector-ref/simple-base-string)
1036 (:translate data-vector-ref)
1037 (:policy :fast-safe)
1038 (:args (object :scs (descriptor-reg))
1039 (index :scs (unsigned-reg)))
1040 (:arg-types simple-base-string positive-fixnum)
1041 (:results (value :scs (character-reg)))
1042 (:result-types character)
1045 (make-ea :byte :base object :index index :scale 1
1046 :disp (- (* vector-data-offset n-word-bytes)
1047 other-pointer-lowtag)))))
1049 (define-vop (data-vector-ref-c/simple-base-string)
1050 (:translate data-vector-ref)
1051 (:policy :fast-safe)
1052 (:args (object :scs (descriptor-reg)))
1054 (:arg-types simple-base-string (:constant (signed-byte 30)))
1055 (:results (value :scs (character-reg)))
1056 (:result-types character)
1059 (make-ea :byte :base object
1060 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1061 other-pointer-lowtag)))))
1063 (define-vop (data-vector-set/simple-base-string)
1064 (:translate data-vector-set)
1065 (:policy :fast-safe)
1066 (:args (object :scs (descriptor-reg) :to (:eval 0))
1067 (index :scs (unsigned-reg) :to (:eval 0))
1068 (value :scs (character-reg) :target result))
1069 (:arg-types simple-base-string positive-fixnum character)
1070 (:results (result :scs (character-reg)))
1071 (:result-types character)
1073 (inst mov (make-ea :byte :base object :index index :scale 1
1074 :disp (- (* vector-data-offset n-word-bytes)
1075 other-pointer-lowtag))
1077 (move result value)))
1079 (define-vop (data-vector-set-c/simple-base-string)
1080 (:translate data-vector-set)
1081 (:policy :fast-safe)
1082 (:args (object :scs (descriptor-reg) :to (:eval 0))
1083 (value :scs (character-reg)))
1085 (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1086 (:results (result :scs (character-reg)))
1087 (:result-types character)
1089 (inst mov (make-ea :byte :base object
1090 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1091 other-pointer-lowtag))
1093 (move result value)))
1097 (define-full-reffer data-vector-ref/simple-character-string
1098 simple-character-string vector-data-offset other-pointer-lowtag
1099 (character-reg) character data-vector-ref)
1101 (define-full-setter data-vector-set/simple-character-string
1102 simple-character-string vector-data-offset other-pointer-lowtag
1103 (character-reg) character data-vector-set)
1107 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1108 (:translate data-vector-ref)
1109 (:policy :fast-safe)
1110 (:args (object :scs (descriptor-reg))
1111 (index :scs (unsigned-reg)))
1112 (:arg-types simple-array-signed-byte-8 positive-fixnum)
1113 (:results (value :scs (signed-reg)))
1114 (:result-types tagged-num)
1117 (make-ea :byte :base object :index index :scale 1
1118 :disp (- (* vector-data-offset n-word-bytes)
1119 other-pointer-lowtag)))))
1121 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1122 (:translate data-vector-ref)
1123 (:policy :fast-safe)
1124 (:args (object :scs (descriptor-reg)))
1126 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1127 (:results (value :scs (signed-reg)))
1128 (:result-types tagged-num)
1131 (make-ea :byte :base object
1132 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1133 other-pointer-lowtag)))))
1135 (define-vop (data-vector-set/simple-array-signed-byte-8)
1136 (:translate data-vector-set)
1137 (:policy :fast-safe)
1138 (:args (object :scs (descriptor-reg) :to (:eval 0))
1139 (index :scs (unsigned-reg) :to (:eval 0))
1140 (value :scs (signed-reg) :target eax))
1141 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1142 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1143 :from (:argument 2) :to (:result 0))
1145 (:results (result :scs (signed-reg)))
1146 (:result-types tagged-num)
1149 (inst mov (make-ea :byte :base object :index index :scale 1
1150 :disp (- (* vector-data-offset n-word-bytes)
1151 other-pointer-lowtag))
1155 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1156 (:translate data-vector-set)
1157 (:policy :fast-safe)
1158 (:args (object :scs (descriptor-reg) :to (:eval 0))
1159 (value :scs (signed-reg) :target eax))
1161 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1163 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1164 :from (:argument 1) :to (:result 0))
1166 (:results (result :scs (signed-reg)))
1167 (:result-types tagged-num)
1170 (inst mov (make-ea :byte :base object
1171 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1172 other-pointer-lowtag))
1178 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1179 (:translate data-vector-ref)
1180 (:policy :fast-safe)
1181 (:args (object :scs (descriptor-reg))
1182 (index :scs (unsigned-reg)))
1183 (:arg-types simple-array-signed-byte-16 positive-fixnum)
1184 (:results (value :scs (signed-reg)))
1185 (:result-types tagged-num)
1188 (make-ea :word :base object :index index :scale 2
1189 :disp (- (* vector-data-offset n-word-bytes)
1190 other-pointer-lowtag)))))
1192 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1193 (:translate data-vector-ref)
1194 (:policy :fast-safe)
1195 (:args (object :scs (descriptor-reg)))
1197 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1198 (:results (value :scs (signed-reg)))
1199 (:result-types tagged-num)
1202 (make-ea :word :base object
1203 :disp (- (+ (* vector-data-offset n-word-bytes)
1205 other-pointer-lowtag)))))
1207 (define-vop (data-vector-set/simple-array-signed-byte-16)
1208 (:translate data-vector-set)
1209 (:policy :fast-safe)
1210 (:args (object :scs (descriptor-reg) :to (:eval 0))
1211 (index :scs (unsigned-reg) :to (:eval 0))
1212 (value :scs (signed-reg) :target eax))
1213 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1214 (:temporary (:sc signed-reg :offset eax-offset :target result
1215 :from (:argument 2) :to (:result 0))
1217 (:results (result :scs (signed-reg)))
1218 (:result-types tagged-num)
1221 (inst mov (make-ea :word :base object :index index :scale 2
1222 :disp (- (* vector-data-offset n-word-bytes)
1223 other-pointer-lowtag))
1227 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1228 (:translate data-vector-set)
1229 (:policy :fast-safe)
1230 (:args (object :scs (descriptor-reg) :to (:eval 0))
1231 (value :scs (signed-reg) :target eax))
1233 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1234 (:temporary (:sc signed-reg :offset eax-offset :target result
1235 :from (:argument 1) :to (:result 0))
1237 (:results (result :scs (signed-reg)))
1238 (:result-types tagged-num)
1242 (make-ea :word :base object
1243 :disp (- (+ (* vector-data-offset n-word-bytes)
1245 other-pointer-lowtag))
1249 ;;; These VOPs are used for implementing float slots in structures (whose raw
1250 ;;; data is an unsigned-32 vector).
1251 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
1252 (:translate %raw-ref-single)
1253 (:arg-types sb!c::raw-vector positive-fixnum))
1254 (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
1255 (:translate %raw-ref-single)
1256 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1257 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
1258 (:translate %raw-set-single)
1259 (:arg-types sb!c::raw-vector positive-fixnum single-float))
1260 (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
1261 (:translate %raw-set-single)
1262 (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) single-float))
1263 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
1264 (:translate %raw-ref-double)
1265 (:arg-types sb!c::raw-vector positive-fixnum))
1266 (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
1267 (:translate %raw-ref-double)
1268 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1269 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
1270 (:translate %raw-set-double)
1271 (:arg-types sb!c::raw-vector positive-fixnum double-float))
1272 (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
1273 (:translate %raw-set-double)
1274 (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) double-float))
1277 ;;;; complex-float raw structure slot accessors
1279 (define-vop (raw-ref-complex-single
1280 data-vector-ref/simple-array-complex-single-float)
1281 (:translate %raw-ref-complex-single)
1282 (:arg-types sb!c::raw-vector positive-fixnum))
1283 (define-vop (raw-ref-complex-single-c
1284 data-vector-ref-c/simple-array-complex-single-float)
1285 (:translate %raw-ref-complex-single)
1286 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1287 (define-vop (raw-set-complex-single
1288 data-vector-set/simple-array-complex-single-float)
1289 (:translate %raw-set-complex-single)
1290 (:arg-types sb!c::raw-vector positive-fixnum complex-single-float))
1291 (define-vop (raw-set-complex-single-c
1292 data-vector-set-c/simple-array-complex-single-float)
1293 (:translate %raw-set-complex-single)
1294 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1295 complex-single-float))
1296 (define-vop (raw-ref-complex-double
1297 data-vector-ref/simple-array-complex-double-float)
1298 (:translate %raw-ref-complex-double)
1299 (:arg-types sb!c::raw-vector positive-fixnum))
1300 (define-vop (raw-ref-complex-double-c
1301 data-vector-ref-c/simple-array-complex-double-float)
1302 (:translate %raw-ref-complex-double)
1303 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1304 (define-vop (raw-set-complex-double
1305 data-vector-set/simple-array-complex-double-float)
1306 (:translate %raw-set-complex-double)
1307 (:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
1308 (define-vop (raw-set-complex-double-c
1309 data-vector-set-c/simple-array-complex-double-float)
1310 (:translate %raw-set-complex-double)
1311 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1312 complex-double-float))
1315 ;;; These vops are useful for accessing the bits of a vector
1316 ;;; irrespective of what type of vector it is.
1317 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1318 unsigned-num %raw-bits)
1319 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1320 unsigned-num %set-raw-bits)
1321 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
1322 (unsigned-reg) unsigned-num %vector-raw-bits)
1323 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
1324 (unsigned-reg) unsigned-num %set-vector-raw-bits)
1326 ;;;; miscellaneous array VOPs
1328 (define-vop (get-vector-subtype get-header-data))
1329 (define-vop (set-vector-subtype set-header-data))