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 (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)))))))
507 (define-vop (data-vector-ref/simple-array-long-float)
508 (:note "inline array access")
509 (:translate data-vector-ref)
511 (:args (object :scs (descriptor-reg) :to :result)
512 (index :scs (any-reg)))
513 (:arg-types simple-array-long-float positive-fixnum)
514 (:temporary (:sc any-reg :from :eval :to :result) temp)
515 (:results (value :scs (long-reg)))
516 (:result-types long-float)
519 (inst lea temp (make-ea :dword :base index :index index :scale 2))
520 (with-empty-tn@fp-top(value)
521 (inst fldl (make-ea :dword :base object :index temp :scale 1
522 :disp (- (* vector-data-offset
524 other-pointer-lowtag))))))
527 (define-vop (data-vector-ref-c/simple-array-long-float)
528 (:note "inline array access")
529 (:translate data-vector-ref)
531 (:args (object :scs (descriptor-reg)))
533 (:arg-types simple-array-long-float (:constant (signed-byte 30)))
534 (:results (value :scs (long-reg)))
535 (:result-types long-float)
537 (with-empty-tn@fp-top(value)
538 (inst fldl (make-ea :dword :base object
539 :disp (- (+ (* vector-data-offset
542 other-pointer-lowtag))))))
545 (define-vop (data-vector-set/simple-array-long-float)
546 (:note "inline array store")
547 (:translate data-vector-set)
549 (:args (object :scs (descriptor-reg) :to :result)
550 (index :scs (any-reg))
551 (value :scs (long-reg) :target result))
552 (:arg-types simple-array-long-float positive-fixnum long-float)
553 (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
554 (:results (result :scs (long-reg)))
555 (:result-types long-float)
558 (inst lea temp (make-ea :dword :base index :index index :scale 2))
559 (cond ((zerop (tn-offset value))
562 (make-ea :dword :base object :index temp :scale 1
563 :disp (- (* vector-data-offset n-word-bytes)
564 other-pointer-lowtag)))
565 (unless (zerop (tn-offset result))
566 ;; Value is in ST0 but not result.
569 ;; Value is not in ST0.
572 (make-ea :dword :base object :index temp :scale 1
573 :disp (- (* vector-data-offset n-word-bytes)
574 other-pointer-lowtag)))
575 (cond ((zerop (tn-offset result))
576 ;; The result is in ST0.
579 ;; Neither value or result are in ST0
580 (unless (location= value result)
582 (inst fxch value)))))))
585 (define-vop (data-vector-set-c/simple-array-long-float)
586 (:note "inline array store")
587 (:translate data-vector-set)
589 (:args (object :scs (descriptor-reg))
590 (value :scs (long-reg) :target result))
592 (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
593 (:results (result :scs (long-reg)))
594 (:result-types long-float)
596 (cond ((zerop (tn-offset value))
598 (store-long-float (make-ea :dword :base object
599 :disp (- (+ (* vector-data-offset
602 other-pointer-lowtag)))
603 (unless (zerop (tn-offset result))
604 ;; Value is in ST0 but not result.
607 ;; Value is not in ST0.
609 (store-long-float (make-ea :dword :base object
610 :disp (- (+ (* vector-data-offset
613 other-pointer-lowtag)))
614 (cond ((zerop (tn-offset result))
615 ;; The result is in ST0.
618 ;; Neither value or result are in ST0
619 (unless (location= value result)
621 (inst fxch value)))))))
623 ;;; complex float variants
625 (define-vop (data-vector-ref/simple-array-complex-single-float)
626 (:note "inline array access")
627 (:translate data-vector-ref)
629 (:args (object :scs (descriptor-reg))
630 (index :scs (any-reg)))
631 (:arg-types simple-array-complex-single-float positive-fixnum)
632 (:results (value :scs (complex-single-reg)))
633 (:result-types complex-single-float)
635 (let ((real-tn (complex-single-reg-real-tn value)))
636 (with-empty-tn@fp-top (real-tn)
637 (inst fld (make-ea :dword :base object :index index :scale 2
638 :disp (- (* vector-data-offset
640 other-pointer-lowtag)))))
641 (let ((imag-tn (complex-single-reg-imag-tn value)))
642 (with-empty-tn@fp-top (imag-tn)
643 (inst fld (make-ea :dword :base object :index index :scale 2
644 :disp (- (* (1+ vector-data-offset)
646 other-pointer-lowtag)))))))
648 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
649 (:note "inline array access")
650 (:translate data-vector-ref)
652 (:args (object :scs (descriptor-reg)))
654 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
655 (:results (value :scs (complex-single-reg)))
656 (:result-types complex-single-float)
658 (let ((real-tn (complex-single-reg-real-tn value)))
659 (with-empty-tn@fp-top (real-tn)
660 (inst fld (make-ea :dword :base object
661 :disp (- (+ (* vector-data-offset
664 other-pointer-lowtag)))))
665 (let ((imag-tn (complex-single-reg-imag-tn value)))
666 (with-empty-tn@fp-top (imag-tn)
667 (inst fld (make-ea :dword :base object
668 :disp (- (+ (* vector-data-offset
671 other-pointer-lowtag)))))))
673 (define-vop (data-vector-set/simple-array-complex-single-float)
674 (:note "inline array store")
675 (:translate data-vector-set)
677 (:args (object :scs (descriptor-reg))
678 (index :scs (any-reg))
679 (value :scs (complex-single-reg) :target result))
680 (:arg-types simple-array-complex-single-float positive-fixnum
681 complex-single-float)
682 (:results (result :scs (complex-single-reg)))
683 (:result-types complex-single-float)
685 (let ((value-real (complex-single-reg-real-tn value))
686 (result-real (complex-single-reg-real-tn result)))
687 (cond ((zerop (tn-offset value-real))
689 (inst fst (make-ea :dword :base object :index index :scale 2
690 :disp (- (* vector-data-offset
692 other-pointer-lowtag)))
693 (unless (zerop (tn-offset result-real))
694 ;; Value is in ST0 but not result.
695 (inst fst result-real)))
697 ;; Value is not in ST0.
698 (inst fxch value-real)
699 (inst fst (make-ea :dword :base object :index index :scale 2
700 :disp (- (* vector-data-offset
702 other-pointer-lowtag)))
703 (cond ((zerop (tn-offset result-real))
704 ;; The result is in ST0.
705 (inst fst value-real))
707 ;; Neither value or result are in ST0
708 (unless (location= value-real result-real)
709 (inst fst result-real))
710 (inst fxch value-real))))))
711 (let ((value-imag (complex-single-reg-imag-tn value))
712 (result-imag (complex-single-reg-imag-tn result)))
713 (inst fxch value-imag)
714 (inst fst (make-ea :dword :base object :index index :scale 2
715 :disp (- (+ (* vector-data-offset
718 other-pointer-lowtag)))
719 (unless (location= value-imag result-imag)
720 (inst fst result-imag))
721 (inst fxch value-imag))))
723 (define-vop (data-vector-set-c/simple-array-complex-single-float)
724 (:note "inline array store")
725 (:translate data-vector-set)
727 (:args (object :scs (descriptor-reg))
728 (value :scs (complex-single-reg) :target result))
730 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
731 complex-single-float)
732 (:results (result :scs (complex-single-reg)))
733 (:result-types complex-single-float)
735 (let ((value-real (complex-single-reg-real-tn value))
736 (result-real (complex-single-reg-real-tn result)))
737 (cond ((zerop (tn-offset value-real))
739 (inst fst (make-ea :dword :base object
740 :disp (- (+ (* vector-data-offset
743 other-pointer-lowtag)))
744 (unless (zerop (tn-offset result-real))
745 ;; Value is in ST0 but not result.
746 (inst fst result-real)))
748 ;; Value is not in ST0.
749 (inst fxch value-real)
750 (inst fst (make-ea :dword :base object
751 :disp (- (+ (* vector-data-offset
754 other-pointer-lowtag)))
755 (cond ((zerop (tn-offset result-real))
756 ;; The result is in ST0.
757 (inst fst value-real))
759 ;; Neither value or result are in ST0
760 (unless (location= value-real result-real)
761 (inst fst result-real))
762 (inst fxch value-real))))))
763 (let ((value-imag (complex-single-reg-imag-tn value))
764 (result-imag (complex-single-reg-imag-tn result)))
765 (inst fxch value-imag)
766 (inst fst (make-ea :dword :base object
767 :disp (- (+ (* vector-data-offset
770 other-pointer-lowtag)))
771 (unless (location= value-imag result-imag)
772 (inst fst result-imag))
773 (inst fxch value-imag))))
776 (define-vop (data-vector-ref/simple-array-complex-double-float)
777 (:note "inline array access")
778 (:translate data-vector-ref)
780 (:args (object :scs (descriptor-reg))
781 (index :scs (any-reg)))
782 (:arg-types simple-array-complex-double-float positive-fixnum)
783 (:results (value :scs (complex-double-reg)))
784 (:result-types complex-double-float)
786 (let ((real-tn (complex-double-reg-real-tn value)))
787 (with-empty-tn@fp-top (real-tn)
788 (inst fldd (make-ea :dword :base object :index index :scale 4
789 :disp (- (* vector-data-offset
791 other-pointer-lowtag)))))
792 (let ((imag-tn (complex-double-reg-imag-tn value)))
793 (with-empty-tn@fp-top (imag-tn)
794 (inst fldd (make-ea :dword :base object :index index :scale 4
795 :disp (- (+ (* vector-data-offset
798 other-pointer-lowtag)))))))
800 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
801 (:note "inline array access")
802 (:translate data-vector-ref)
804 (:args (object :scs (descriptor-reg)))
806 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
807 (:results (value :scs (complex-double-reg)))
808 (:result-types complex-double-float)
810 (let ((real-tn (complex-double-reg-real-tn value)))
811 (with-empty-tn@fp-top (real-tn)
812 (inst fldd (make-ea :dword :base object
813 :disp (- (+ (* vector-data-offset
816 other-pointer-lowtag)))))
817 (let ((imag-tn (complex-double-reg-imag-tn value)))
818 (with-empty-tn@fp-top (imag-tn)
819 (inst fldd (make-ea :dword :base object
820 :disp (- (+ (* vector-data-offset
823 other-pointer-lowtag)))))))
825 (define-vop (data-vector-set/simple-array-complex-double-float)
826 (:note "inline array store")
827 (:translate data-vector-set)
829 (:args (object :scs (descriptor-reg))
830 (index :scs (any-reg))
831 (value :scs (complex-double-reg) :target result))
832 (:arg-types simple-array-complex-double-float positive-fixnum
833 complex-double-float)
834 (:results (result :scs (complex-double-reg)))
835 (:result-types complex-double-float)
837 (let ((value-real (complex-double-reg-real-tn value))
838 (result-real (complex-double-reg-real-tn result)))
839 (cond ((zerop (tn-offset value-real))
841 (inst fstd (make-ea :dword :base object :index index :scale 4
842 :disp (- (* vector-data-offset
844 other-pointer-lowtag)))
845 (unless (zerop (tn-offset result-real))
846 ;; Value is in ST0 but not result.
847 (inst fstd result-real)))
849 ;; Value is not in ST0.
850 (inst fxch value-real)
851 (inst fstd (make-ea :dword :base object :index index :scale 4
852 :disp (- (* vector-data-offset
854 other-pointer-lowtag)))
855 (cond ((zerop (tn-offset result-real))
856 ;; The result is in ST0.
857 (inst fstd value-real))
859 ;; Neither value or result are in ST0
860 (unless (location= value-real result-real)
861 (inst fstd result-real))
862 (inst fxch value-real))))))
863 (let ((value-imag (complex-double-reg-imag-tn value))
864 (result-imag (complex-double-reg-imag-tn result)))
865 (inst fxch value-imag)
866 (inst fstd (make-ea :dword :base object :index index :scale 4
867 :disp (- (+ (* vector-data-offset
870 other-pointer-lowtag)))
871 (unless (location= value-imag result-imag)
872 (inst fstd result-imag))
873 (inst fxch value-imag))))
875 (define-vop (data-vector-set-c/simple-array-complex-double-float)
876 (:note "inline array store")
877 (:translate data-vector-set)
879 (:args (object :scs (descriptor-reg))
880 (value :scs (complex-double-reg) :target result))
882 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
883 complex-double-float)
884 (:results (result :scs (complex-double-reg)))
885 (:result-types complex-double-float)
887 (let ((value-real (complex-double-reg-real-tn value))
888 (result-real (complex-double-reg-real-tn result)))
889 (cond ((zerop (tn-offset value-real))
891 (inst fstd (make-ea :dword :base object
892 :disp (- (+ (* vector-data-offset
895 other-pointer-lowtag)))
896 (unless (zerop (tn-offset result-real))
897 ;; Value is in ST0 but not result.
898 (inst fstd result-real)))
900 ;; Value is not in ST0.
901 (inst fxch value-real)
902 (inst fstd (make-ea :dword :base object
903 :disp (- (+ (* vector-data-offset
906 other-pointer-lowtag)))
907 (cond ((zerop (tn-offset result-real))
908 ;; The result is in ST0.
909 (inst fstd value-real))
911 ;; Neither value or result are in ST0
912 (unless (location= value-real result-real)
913 (inst fstd result-real))
914 (inst fxch value-real))))))
915 (let ((value-imag (complex-double-reg-imag-tn value))
916 (result-imag (complex-double-reg-imag-tn result)))
917 (inst fxch value-imag)
918 (inst fstd (make-ea :dword :base object
919 :disp (- (+ (* vector-data-offset
922 other-pointer-lowtag)))
923 (unless (location= value-imag result-imag)
924 (inst fstd result-imag))
925 (inst fxch value-imag))))
929 (define-vop (data-vector-ref/simple-array-complex-long-float)
930 (:note "inline array access")
931 (:translate data-vector-ref)
933 (:args (object :scs (descriptor-reg) :to :result)
934 (index :scs (any-reg)))
935 (:arg-types simple-array-complex-long-float positive-fixnum)
936 (:temporary (:sc any-reg :from :eval :to :result) temp)
937 (:results (value :scs (complex-long-reg)))
938 (:result-types complex-long-float)
941 (inst lea temp (make-ea :dword :base index :index index :scale 2))
942 (let ((real-tn (complex-long-reg-real-tn value)))
943 (with-empty-tn@fp-top (real-tn)
944 (inst fldl (make-ea :dword :base object :index temp :scale 2
945 :disp (- (* vector-data-offset
947 other-pointer-lowtag)))))
948 (let ((imag-tn (complex-long-reg-imag-tn value)))
949 (with-empty-tn@fp-top (imag-tn)
950 (inst fldl (make-ea :dword :base object :index temp :scale 2
951 :disp (- (+ (* vector-data-offset
954 other-pointer-lowtag)))))))
957 (define-vop (data-vector-ref-c/simple-array-complex-long-float)
958 (:note "inline array access")
959 (:translate data-vector-ref)
961 (:args (object :scs (descriptor-reg)))
963 (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
964 (:results (value :scs (complex-long-reg)))
965 (:result-types complex-long-float)
967 (let ((real-tn (complex-long-reg-real-tn value)))
968 (with-empty-tn@fp-top (real-tn)
969 (inst fldl (make-ea :dword :base object
970 :disp (- (+ (* vector-data-offset
973 other-pointer-lowtag)))))
974 (let ((imag-tn (complex-long-reg-imag-tn value)))
975 (with-empty-tn@fp-top (imag-tn)
976 (inst fldl (make-ea :dword :base object
977 :disp (- (+ (* vector-data-offset
980 other-pointer-lowtag)))))))
983 (define-vop (data-vector-set/simple-array-complex-long-float)
984 (:note "inline array store")
985 (:translate data-vector-set)
987 (:args (object :scs (descriptor-reg) :to :result)
988 (index :scs (any-reg))
989 (value :scs (complex-long-reg) :target result))
990 (:arg-types simple-array-complex-long-float positive-fixnum
992 (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
993 (:results (result :scs (complex-long-reg)))
994 (:result-types complex-long-float)
997 (inst lea temp (make-ea :dword :base index :index index :scale 2))
998 (let ((value-real (complex-long-reg-real-tn value))
999 (result-real (complex-long-reg-real-tn result)))
1000 (cond ((zerop (tn-offset value-real))
1003 (make-ea :dword :base object :index temp :scale 2
1004 :disp (- (* vector-data-offset n-word-bytes)
1005 other-pointer-lowtag)))
1006 (unless (zerop (tn-offset result-real))
1007 ;; Value is in ST0 but not result.
1008 (inst fstd result-real)))
1010 ;; Value is not in ST0.
1011 (inst fxch value-real)
1013 (make-ea :dword :base object :index temp :scale 2
1014 :disp (- (* vector-data-offset n-word-bytes)
1015 other-pointer-lowtag)))
1016 (cond ((zerop (tn-offset result-real))
1017 ;; The result is in ST0.
1018 (inst fstd value-real))
1020 ;; Neither value or result are in ST0
1021 (unless (location= value-real result-real)
1022 (inst fstd result-real))
1023 (inst fxch value-real))))))
1024 (let ((value-imag (complex-long-reg-imag-tn value))
1025 (result-imag (complex-long-reg-imag-tn result)))
1026 (inst fxch value-imag)
1028 (make-ea :dword :base object :index temp :scale 2
1029 :disp (- (+ (* vector-data-offset n-word-bytes) 12)
1030 other-pointer-lowtag)))
1031 (unless (location= value-imag result-imag)
1032 (inst fstd result-imag))
1033 (inst fxch value-imag))))
1036 (define-vop (data-vector-set-c/simple-array-complex-long-float)
1037 (:note "inline array store")
1038 (:translate data-vector-set)
1039 (:policy :fast-safe)
1040 (:args (object :scs (descriptor-reg))
1041 (value :scs (complex-long-reg) :target result))
1043 (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
1045 (:results (result :scs (complex-long-reg)))
1046 (:result-types complex-long-float)
1048 (let ((value-real (complex-long-reg-real-tn value))
1049 (result-real (complex-long-reg-real-tn result)))
1050 (cond ((zerop (tn-offset value-real))
1053 (make-ea :dword :base object
1054 :disp (- (+ (* vector-data-offset
1057 other-pointer-lowtag)))
1058 (unless (zerop (tn-offset result-real))
1059 ;; Value is in ST0 but not result.
1060 (inst fstd result-real)))
1062 ;; Value is not in ST0.
1063 (inst fxch value-real)
1065 (make-ea :dword :base object
1066 :disp (- (+ (* vector-data-offset
1069 other-pointer-lowtag)))
1070 (cond ((zerop (tn-offset result-real))
1071 ;; The result is in ST0.
1072 (inst fstd value-real))
1074 ;; Neither value or result are in ST0
1075 (unless (location= value-real result-real)
1076 (inst fstd result-real))
1077 (inst fxch value-real))))))
1078 (let ((value-imag (complex-long-reg-imag-tn value))
1079 (result-imag (complex-long-reg-imag-tn result)))
1080 (inst fxch value-imag)
1082 (make-ea :dword :base object
1083 :disp (- (+ (* vector-data-offset
1085 ;; FIXME: There are so many of these bare constants
1086 ;; (24, 12..) in the LONG-FLOAT code that it's
1087 ;; ridiculous. I should probably just delete it all
1088 ;; instead of appearing to flirt with supporting
1089 ;; this maintenance nightmare.
1091 other-pointer-lowtag)))
1092 (unless (location= value-imag result-imag)
1093 (inst fstd result-imag))
1094 (inst fxch value-imag))))
1097 (macrolet ((define-data-vector-frobs (ptype)
1099 (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
1100 (:translate data-vector-ref)
1101 (:policy :fast-safe)
1102 (:args (object :scs (descriptor-reg))
1103 (index :scs (unsigned-reg)))
1104 (:arg-types ,ptype positive-fixnum)
1105 (:results (value :scs (unsigned-reg signed-reg)))
1106 (:result-types positive-fixnum)
1109 (make-ea :byte :base object :index index :scale 1
1110 :disp (- (* vector-data-offset n-word-bytes)
1111 other-pointer-lowtag)))))
1112 (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
1113 (:translate data-vector-ref)
1114 (:policy :fast-safe)
1115 (:args (object :scs (descriptor-reg)))
1117 (:arg-types ,ptype (:constant (signed-byte 30)))
1118 (:results (value :scs (unsigned-reg signed-reg)))
1119 (:result-types positive-fixnum)
1122 (make-ea :byte :base object
1123 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1124 other-pointer-lowtag)))))
1125 (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
1126 (:translate data-vector-set)
1127 (:policy :fast-safe)
1128 (:args (object :scs (descriptor-reg) :to (:eval 0))
1129 (index :scs (unsigned-reg) :to (:eval 0))
1130 (value :scs (unsigned-reg signed-reg) :target eax))
1131 (:arg-types ,ptype positive-fixnum positive-fixnum)
1132 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1133 :from (:argument 2) :to (:result 0))
1135 (:results (result :scs (unsigned-reg signed-reg)))
1136 (:result-types positive-fixnum)
1139 (inst mov (make-ea :byte :base object :index index :scale 1
1140 :disp (- (* vector-data-offset n-word-bytes)
1141 other-pointer-lowtag))
1144 (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
1145 (:translate data-vector-set)
1146 (:policy :fast-safe)
1147 (:args (object :scs (descriptor-reg) :to (:eval 0))
1148 (value :scs (unsigned-reg signed-reg) :target eax))
1150 (:arg-types ,ptype (:constant (signed-byte 30))
1152 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1153 :from (:argument 1) :to (:result 0))
1155 (:results (result :scs (unsigned-reg signed-reg)))
1156 (:result-types positive-fixnum)
1159 (inst mov (make-ea :byte :base object
1160 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1161 other-pointer-lowtag))
1163 (move result eax))))))
1164 (define-data-vector-frobs simple-array-unsigned-byte-7)
1165 (define-data-vector-frobs simple-array-unsigned-byte-8))
1167 ;;; unsigned-byte-16
1168 (macrolet ((define-data-vector-frobs (ptype)
1170 (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
1171 (:translate data-vector-ref)
1172 (:policy :fast-safe)
1173 (:args (object :scs (descriptor-reg))
1174 (index :scs (unsigned-reg)))
1175 (:arg-types ,ptype positive-fixnum)
1176 (:results (value :scs (unsigned-reg signed-reg)))
1177 (:result-types positive-fixnum)
1180 (make-ea :word :base object :index index :scale 2
1181 :disp (- (* vector-data-offset n-word-bytes)
1182 other-pointer-lowtag)))))
1183 (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
1184 (:translate data-vector-ref)
1185 (:policy :fast-safe)
1186 (:args (object :scs (descriptor-reg)))
1188 (:arg-types ,ptype (:constant (signed-byte 30)))
1189 (:results (value :scs (unsigned-reg signed-reg)))
1190 (:result-types positive-fixnum)
1193 (make-ea :word :base object
1194 :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
1195 other-pointer-lowtag)))))
1196 (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
1197 (:translate data-vector-set)
1198 (:policy :fast-safe)
1199 (:args (object :scs (descriptor-reg) :to (:eval 0))
1200 (index :scs (unsigned-reg) :to (:eval 0))
1201 (value :scs (unsigned-reg signed-reg) :target eax))
1202 (:arg-types ,ptype positive-fixnum positive-fixnum)
1203 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1204 :from (:argument 2) :to (:result 0))
1206 (:results (result :scs (unsigned-reg signed-reg)))
1207 (:result-types positive-fixnum)
1210 (inst mov (make-ea :word :base object :index index :scale 2
1211 :disp (- (* vector-data-offset n-word-bytes)
1212 other-pointer-lowtag))
1216 (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
1217 (:translate data-vector-set)
1218 (:policy :fast-safe)
1219 (:args (object :scs (descriptor-reg) :to (:eval 0))
1220 (value :scs (unsigned-reg signed-reg) :target eax))
1222 (:arg-types ,ptype (:constant (signed-byte 30))
1224 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1225 :from (:argument 1) :to (:result 0))
1227 (:results (result :scs (unsigned-reg signed-reg)))
1228 (:result-types positive-fixnum)
1231 (inst mov (make-ea :word :base object
1232 :disp (- (+ (* vector-data-offset n-word-bytes)
1234 other-pointer-lowtag))
1236 (move result eax))))))
1237 (define-data-vector-frobs simple-array-unsigned-byte-15)
1238 (define-data-vector-frobs simple-array-unsigned-byte-16))
1244 (define-vop (data-vector-ref/simple-base-string)
1245 (:translate data-vector-ref)
1246 (:policy :fast-safe)
1247 (:args (object :scs (descriptor-reg))
1248 (index :scs (unsigned-reg)))
1249 (:arg-types simple-base-string positive-fixnum)
1250 (:results (value :scs (character-reg)))
1251 (:result-types character)
1254 (make-ea :byte :base object :index index :scale 1
1255 :disp (- (* vector-data-offset n-word-bytes)
1256 other-pointer-lowtag)))))
1258 (define-vop (data-vector-ref-c/simple-base-string)
1259 (:translate data-vector-ref)
1260 (:policy :fast-safe)
1261 (:args (object :scs (descriptor-reg)))
1263 (:arg-types simple-base-string (:constant (signed-byte 30)))
1264 (:results (value :scs (character-reg)))
1265 (:result-types character)
1268 (make-ea :byte :base object
1269 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1270 other-pointer-lowtag)))))
1272 (define-vop (data-vector-set/simple-base-string)
1273 (:translate data-vector-set)
1274 (:policy :fast-safe)
1275 (:args (object :scs (descriptor-reg) :to (:eval 0))
1276 (index :scs (unsigned-reg) :to (:eval 0))
1277 (value :scs (character-reg) :target eax))
1278 (:arg-types simple-base-string positive-fixnum character)
1279 (:temporary (:sc character-reg :offset eax-offset :target result
1280 :from (:argument 2) :to (:result 0))
1282 (:results (result :scs (character-reg)))
1283 (:result-types character)
1286 (inst mov (make-ea :byte :base object :index index :scale 1
1287 :disp (- (* vector-data-offset n-word-bytes)
1288 other-pointer-lowtag))
1292 (define-vop (data-vector-set-c/simple-base-string)
1293 (:translate data-vector-set)
1294 (:policy :fast-safe)
1295 (:args (object :scs (descriptor-reg) :to (:eval 0))
1296 (value :scs (character-reg)))
1298 (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1299 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1300 :from (:argument 1) :to (:result 0))
1302 (:results (result :scs (character-reg)))
1303 (:result-types character)
1306 (inst mov (make-ea :byte :base object
1307 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1308 other-pointer-lowtag))
1315 (define-vop (data-vector-ref/simple-base-string)
1316 (:translate data-vector-ref)
1317 (:policy :fast-safe)
1318 (:args (object :scs (descriptor-reg))
1319 (index :scs (unsigned-reg)))
1320 (:arg-types simple-base-string positive-fixnum)
1321 (:results (value :scs (character-reg)))
1322 (:result-types character)
1325 (make-ea :byte :base object :index index :scale 1
1326 :disp (- (* vector-data-offset n-word-bytes)
1327 other-pointer-lowtag)))))
1329 (define-vop (data-vector-ref-c/simple-base-string)
1330 (:translate data-vector-ref)
1331 (:policy :fast-safe)
1332 (:args (object :scs (descriptor-reg)))
1334 (:arg-types simple-base-string (:constant (signed-byte 30)))
1335 (:results (value :scs (character-reg)))
1336 (:result-types character)
1339 (make-ea :byte :base object
1340 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1341 other-pointer-lowtag)))))
1343 (define-vop (data-vector-set/simple-base-string)
1344 (:translate data-vector-set)
1345 (:policy :fast-safe)
1346 (:args (object :scs (descriptor-reg) :to (:eval 0))
1347 (index :scs (unsigned-reg) :to (:eval 0))
1348 (value :scs (character-reg) :target result))
1349 (:arg-types simple-base-string positive-fixnum character)
1350 (:results (result :scs (character-reg)))
1351 (:result-types character)
1353 (inst mov (make-ea :byte :base object :index index :scale 1
1354 :disp (- (* vector-data-offset n-word-bytes)
1355 other-pointer-lowtag))
1357 (move result value)))
1359 (define-vop (data-vector-set-c/simple-base-string)
1360 (:translate data-vector-set)
1361 (:policy :fast-safe)
1362 (:args (object :scs (descriptor-reg) :to (:eval 0))
1363 (value :scs (character-reg)))
1365 (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1366 (:results (result :scs (character-reg)))
1367 (:result-types character)
1369 (inst mov (make-ea :byte :base object
1370 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1371 other-pointer-lowtag))
1373 (move result value)))
1377 (define-full-reffer data-vector-ref/simple-character-string
1378 simple-character-string vector-data-offset other-pointer-lowtag
1379 (character-reg) character data-vector-ref)
1381 (define-full-setter data-vector-ref/simple-character-string
1382 simple-character-string vector-data-offset other-pointer-lowtag
1383 (character-reg) character data-vector-set)
1387 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1388 (:translate data-vector-ref)
1389 (:policy :fast-safe)
1390 (:args (object :scs (descriptor-reg))
1391 (index :scs (unsigned-reg)))
1392 (:arg-types simple-array-signed-byte-8 positive-fixnum)
1393 (:results (value :scs (signed-reg)))
1394 (:result-types tagged-num)
1397 (make-ea :byte :base object :index index :scale 1
1398 :disp (- (* vector-data-offset n-word-bytes)
1399 other-pointer-lowtag)))))
1401 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1402 (:translate data-vector-ref)
1403 (:policy :fast-safe)
1404 (:args (object :scs (descriptor-reg)))
1406 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1407 (:results (value :scs (signed-reg)))
1408 (:result-types tagged-num)
1411 (make-ea :byte :base object
1412 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1413 other-pointer-lowtag)))))
1415 (define-vop (data-vector-set/simple-array-signed-byte-8)
1416 (:translate data-vector-set)
1417 (:policy :fast-safe)
1418 (:args (object :scs (descriptor-reg) :to (:eval 0))
1419 (index :scs (unsigned-reg) :to (:eval 0))
1420 (value :scs (signed-reg) :target eax))
1421 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1422 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1423 :from (:argument 2) :to (:result 0))
1425 (:results (result :scs (signed-reg)))
1426 (:result-types tagged-num)
1429 (inst mov (make-ea :byte :base object :index index :scale 1
1430 :disp (- (* vector-data-offset n-word-bytes)
1431 other-pointer-lowtag))
1435 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1436 (:translate data-vector-set)
1437 (:policy :fast-safe)
1438 (:args (object :scs (descriptor-reg) :to (:eval 0))
1439 (value :scs (signed-reg) :target eax))
1441 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1443 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1444 :from (:argument 1) :to (:result 0))
1446 (:results (result :scs (signed-reg)))
1447 (:result-types tagged-num)
1450 (inst mov (make-ea :byte :base object
1451 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1452 other-pointer-lowtag))
1458 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1459 (:translate data-vector-ref)
1460 (:policy :fast-safe)
1461 (:args (object :scs (descriptor-reg))
1462 (index :scs (unsigned-reg)))
1463 (:arg-types simple-array-signed-byte-16 positive-fixnum)
1464 (:results (value :scs (signed-reg)))
1465 (:result-types tagged-num)
1468 (make-ea :word :base object :index index :scale 2
1469 :disp (- (* vector-data-offset n-word-bytes)
1470 other-pointer-lowtag)))))
1472 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1473 (:translate data-vector-ref)
1474 (:policy :fast-safe)
1475 (:args (object :scs (descriptor-reg)))
1477 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1478 (:results (value :scs (signed-reg)))
1479 (:result-types tagged-num)
1482 (make-ea :word :base object
1483 :disp (- (+ (* vector-data-offset n-word-bytes)
1485 other-pointer-lowtag)))))
1487 (define-vop (data-vector-set/simple-array-signed-byte-16)
1488 (:translate data-vector-set)
1489 (:policy :fast-safe)
1490 (:args (object :scs (descriptor-reg) :to (:eval 0))
1491 (index :scs (unsigned-reg) :to (:eval 0))
1492 (value :scs (signed-reg) :target eax))
1493 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1494 (:temporary (:sc signed-reg :offset eax-offset :target result
1495 :from (:argument 2) :to (:result 0))
1497 (:results (result :scs (signed-reg)))
1498 (:result-types tagged-num)
1501 (inst mov (make-ea :word :base object :index index :scale 2
1502 :disp (- (* vector-data-offset n-word-bytes)
1503 other-pointer-lowtag))
1507 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1508 (:translate data-vector-set)
1509 (:policy :fast-safe)
1510 (:args (object :scs (descriptor-reg) :to (:eval 0))
1511 (value :scs (signed-reg) :target eax))
1513 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1514 (:temporary (:sc signed-reg :offset eax-offset :target result
1515 :from (:argument 1) :to (:result 0))
1517 (:results (result :scs (signed-reg)))
1518 (:result-types tagged-num)
1522 (make-ea :word :base object
1523 :disp (- (+ (* vector-data-offset n-word-bytes)
1525 other-pointer-lowtag))
1529 ;;; These VOPs are used for implementing float slots in structures (whose raw
1530 ;;; data is an unsigned-32 vector).
1531 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
1532 (:translate %raw-ref-single)
1533 (:arg-types sb!c::raw-vector positive-fixnum))
1534 (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
1535 (:translate %raw-ref-single)
1536 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1537 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
1538 (:translate %raw-set-single)
1539 (:arg-types sb!c::raw-vector positive-fixnum single-float))
1540 (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
1541 (:translate %raw-set-single)
1542 (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) single-float))
1543 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
1544 (:translate %raw-ref-double)
1545 (:arg-types sb!c::raw-vector positive-fixnum))
1546 (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
1547 (:translate %raw-ref-double)
1548 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1549 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
1550 (:translate %raw-set-double)
1551 (:arg-types sb!c::raw-vector positive-fixnum double-float))
1552 (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
1553 (:translate %raw-set-double)
1554 (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) double-float))
1556 (define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
1557 (:translate %raw-ref-long)
1558 (:arg-types sb!c::raw-vector positive-fixnum))
1560 (define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
1561 (:translate %raw-ref-long)
1562 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1564 (define-vop (raw-set-double data-vector-set/simple-array-long-float)
1565 (:translate %raw-set-long)
1566 (:arg-types sb!c::raw-vector positive-fixnum long-float))
1568 (define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
1569 (:translate %raw-set-long)
1570 (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) long-float))
1572 ;;;; complex-float raw structure slot accessors
1574 (define-vop (raw-ref-complex-single
1575 data-vector-ref/simple-array-complex-single-float)
1576 (:translate %raw-ref-complex-single)
1577 (:arg-types sb!c::raw-vector positive-fixnum))
1578 (define-vop (raw-ref-complex-single-c
1579 data-vector-ref-c/simple-array-complex-single-float)
1580 (:translate %raw-ref-complex-single)
1581 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1582 (define-vop (raw-set-complex-single
1583 data-vector-set/simple-array-complex-single-float)
1584 (:translate %raw-set-complex-single)
1585 (:arg-types sb!c::raw-vector positive-fixnum complex-single-float))
1586 (define-vop (raw-set-complex-single-c
1587 data-vector-set-c/simple-array-complex-single-float)
1588 (:translate %raw-set-complex-single)
1589 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1590 complex-single-float))
1591 (define-vop (raw-ref-complex-double
1592 data-vector-ref/simple-array-complex-double-float)
1593 (:translate %raw-ref-complex-double)
1594 (:arg-types sb!c::raw-vector positive-fixnum))
1595 (define-vop (raw-ref-complex-double-c
1596 data-vector-ref-c/simple-array-complex-double-float)
1597 (:translate %raw-ref-complex-double)
1598 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1599 (define-vop (raw-set-complex-double
1600 data-vector-set/simple-array-complex-double-float)
1601 (:translate %raw-set-complex-double)
1602 (:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
1603 (define-vop (raw-set-complex-double-c
1604 data-vector-set-c/simple-array-complex-double-float)
1605 (:translate %raw-set-complex-double)
1606 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1607 complex-double-float))
1609 (define-vop (raw-ref-complex-long
1610 data-vector-ref/simple-array-complex-long-float)
1611 (:translate %raw-ref-complex-long)
1612 (:arg-types sb!c::raw-vector positive-fixnum))
1614 (define-vop (raw-ref-complex-long-c
1615 data-vector-ref-c/simple-array-complex-long-float)
1616 (:translate %raw-ref-complex-long)
1617 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1619 (define-vop (raw-set-complex-long
1620 data-vector-set/simple-array-complex-long-float)
1621 (:translate %raw-set-complex-long)
1622 (:arg-types sb!c::raw-vector positive-fixnum complex-long-float))
1624 (define-vop (raw-set-complex-long-c
1625 data-vector-set-c/simple-array-complex-long-float)
1626 (:translate %raw-set-complex-long)
1627 (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1628 complex-long-float))
1630 ;;; These vops are useful for accessing the bits of a vector
1631 ;;; irrespective of what type of vector it is.
1632 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1633 unsigned-num %raw-bits)
1634 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1635 unsigned-num %set-raw-bits)
1637 ;;;; miscellaneous array VOPs
1639 (define-vop (get-vector-subtype get-header-data))
1640 (define-vop (set-vector-subtype set-header-data))