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
44 (defknown sb!impl::%array-dimension (t index) index
46 (defknown sb!impl::%set-array-dimension (t index index) index
49 (define-full-reffer %array-dimension *
50 array-dimensions-offset other-pointer-lowtag
51 (any-reg) positive-fixnum sb!impl::%array-dimension)
53 (define-full-setter %set-array-dimension *
54 array-dimensions-offset other-pointer-lowtag
55 (any-reg) positive-fixnum sb!impl::%set-array-dimension)
57 (defknown sb!impl::%array-rank (t) index (flushable))
59 (define-vop (array-rank-vop)
60 (:translate sb!impl::%array-rank)
62 (:args (x :scs (descriptor-reg)))
63 (:results (res :scs (unsigned-reg)))
64 (:result-types positive-fixnum)
66 (loadw res x 0 other-pointer-lowtag)
67 (inst shr res n-widetag-bits)
68 (inst sub res (1- array-dimensions-offset))))
70 ;;;; bounds checking routine
72 ;;; Note that the immediate SC for the index argument is disabled
73 ;;; because it is not possible to generate a valid error code SC for
74 ;;; an immediate value.
76 ;;; FIXME: As per the KLUDGE note explaining the :IGNORE-FAILURE-P
77 ;;; flag in build-order.lisp-expr, compiling this file causes warnings
78 ;;; Argument FOO to VOP CHECK-BOUND has SC restriction
79 ;;; DESCRIPTOR-REG which is not allowed by the operand type:
80 ;;; (:OR POSITIVE-FIXNUM)
81 ;;; CSR's message "format ~/ /" on sbcl-devel 2002-03-12 contained
82 ;;; a possible patch, described as
83 ;;; Another patch is included more for information than anything --
84 ;;; removing the descriptor-reg SCs from the CHECK-BOUND vop in
85 ;;; x86/array.lisp seems to allow that file to compile without error[*],
86 ;;; and build; I haven't tested rebuilding capability, but I'd be
87 ;;; surprised if there were a problem. I'm not certain that this is the
88 ;;; correct fix, though, as the restrictions on the arguments to the VOP
89 ;;; aren't the same as in the sparc and alpha ports, where, incidentally,
90 ;;; the corresponding file builds without error currently.
91 ;;; Since neither of us (CSR or WHN) was quite sure that this is the
92 ;;; right thing, I've just recorded the patch here in hopes it might
93 ;;; help when someone attacks this problem again:
94 ;;; diff -u -r1.7 array.lisp
95 ;;; --- src/compiler/x86/array.lisp 11 Oct 2001 14:05:26 -0000 1.7
96 ;;; +++ src/compiler/x86/array.lisp 12 Mar 2002 12:23:37 -0000
97 ;;; @@ -76,10 +76,10 @@
98 ;;; (:translate %check-bound)
99 ;;; (:policy :fast-safe)
100 ;;; (:args (array :scs (descriptor-reg))
101 ;;; - (bound :scs (any-reg descriptor-reg))
102 ;;; - (index :scs (any-reg descriptor-reg #+nil immediate) :target result))
103 ;;; + (bound :scs (any-reg))
104 ;;; + (index :scs (any-reg #+nil immediate) :target result))
105 ;;; (:arg-types * positive-fixnum tagged-num)
106 ;;; - (:results (result :scs (any-reg descriptor-reg)))
107 ;;; + (:results (result :scs (any-reg)))
108 ;;; (:result-types positive-fixnum)
110 ;;; (:save-p :compute-only)
111 (define-vop (check-bound)
112 (:translate %check-bound)
114 (:args (array :scs (descriptor-reg))
115 (bound :scs (any-reg descriptor-reg))
116 (index :scs (any-reg descriptor-reg #+nil immediate) :target result))
117 (:arg-types * positive-fixnum tagged-num)
118 (:results (result :scs (any-reg descriptor-reg)))
119 (:result-types positive-fixnum)
121 (:save-p :compute-only)
123 (let ((error (generate-error-code vop invalid-array-index-error
125 (index (if (sc-is index immediate)
126 (fixnumize (tn-value index))
128 (inst cmp bound index)
129 ;; We use below-or-equal even though it's an unsigned test,
130 ;; because negative indexes appear as large unsigned numbers.
131 ;; Therefore, we get the <0 and >=bound test all rolled into one.
133 (unless (and (tn-p index) (location= result index))
134 (inst mov result index)))))
136 ;;;; accessors/setters
138 ;;; variants built on top of WORD-INDEX-REF, etc. I.e., those vectors
139 ;;; whose elements are represented in integer registers and are built
140 ;;; out of 8, 16, or 32 bit elements.
141 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
143 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
144 ,type vector-data-offset other-pointer-lowtag ,scs
145 ,element-type data-vector-ref)
146 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
147 ,type vector-data-offset other-pointer-lowtag ,scs
148 ,element-type data-vector-set))))
149 (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
150 (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
152 (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
153 (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg)
154 (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
156 (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
159 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
160 ;;;; bit, 2-bit, and 4-bit vectors
162 (macrolet ((def-small-data-vector-frobs (type bits)
163 (let* ((elements-per-word (floor sb!vm:n-word-bits bits))
164 (bit-shift (1- (integer-length elements-per-word))))
166 (define-vop (,(symbolicate 'data-vector-ref/ type))
167 (:note "inline array access")
168 (:translate data-vector-ref)
170 (:args (object :scs (descriptor-reg))
171 (index :scs (unsigned-reg)))
172 (:arg-types ,type positive-fixnum)
173 (:results (result :scs (unsigned-reg) :from (:argument 0)))
174 (:result-types positive-fixnum)
175 (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
178 (inst shr ecx ,bit-shift)
180 (make-ea :dword :base object :index ecx :scale 4
181 :disp (- (* vector-data-offset n-word-bytes)
182 other-pointer-lowtag)))
184 (inst and ecx ,(1- elements-per-word))
186 `((inst shl ecx ,(1- (integer-length bits)))))
187 (inst shr result :cl)
188 (inst and result ,(1- (ash 1 bits)))))
189 (define-vop (,(symbolicate 'data-vector-ref-c/ type))
190 (:translate data-vector-ref)
192 (:args (object :scs (descriptor-reg)))
193 (:arg-types ,type (:constant index))
195 (:results (result :scs (unsigned-reg)))
196 (:result-types positive-fixnum)
198 (multiple-value-bind (word extra) (floor index ,elements-per-word)
199 (loadw result object (+ word vector-data-offset)
200 other-pointer-lowtag)
201 (unless (zerop extra)
202 (inst shr result (* extra ,bits)))
203 (unless (= extra ,(1- elements-per-word))
204 (inst and result ,(1- (ash 1 bits)))))))
205 (define-vop (,(symbolicate 'data-vector-set/ type))
206 (:note "inline array store")
207 (:translate data-vector-set)
209 (:args (object :scs (descriptor-reg) :target ptr)
210 (index :scs (unsigned-reg) :target ecx)
211 (value :scs (unsigned-reg immediate) :target result))
212 (:arg-types ,type positive-fixnum positive-fixnum)
213 (:results (result :scs (unsigned-reg)))
214 (:result-types positive-fixnum)
215 (:temporary (:sc unsigned-reg) word-index)
216 (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old)
217 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1))
220 (move word-index index)
221 (inst shr word-index ,bit-shift)
223 (make-ea :dword :base object :index word-index :scale 4
224 :disp (- (* vector-data-offset n-word-bytes)
225 other-pointer-lowtag)))
228 (inst and ecx ,(1- elements-per-word))
230 `((inst shl ecx ,(1- (integer-length bits)))))
232 (unless (and (sc-is value immediate)
233 (= (tn-value value) ,(1- (ash 1 bits))))
234 (inst and old ,(lognot (1- (ash 1 bits)))))
237 (unless (zerop (tn-value value))
238 (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
240 (inst or old value)))
245 (inst mov result (tn-value value)))
247 (move result value)))))
248 (define-vop (,(symbolicate 'data-vector-set-c/ type))
249 (:translate data-vector-set)
251 (:args (object :scs (descriptor-reg))
252 (value :scs (unsigned-reg immediate) :target result))
253 (:arg-types ,type (:constant index) positive-fixnum)
255 (:results (result :scs (unsigned-reg)))
256 (:result-types positive-fixnum)
257 (:temporary (:sc unsigned-reg :to (:result 0)) old)
259 (multiple-value-bind (word extra) (floor index ,elements-per-word)
261 (make-ea :dword :base object
262 :disp (- (* (+ word vector-data-offset)
264 other-pointer-lowtag)))
267 (let* ((value (tn-value value))
268 (mask ,(1- (ash 1 bits)))
269 (shift (* extra ,bits)))
270 (unless (= value mask)
271 (inst and old (lognot (ash mask shift))))
272 (unless (zerop value)
273 (inst or old (ash value shift)))))
275 (let ((shift (* extra ,bits)))
276 (unless (zerop shift)
277 (inst ror old shift))
278 (inst and old (lognot ,(1- (ash 1 bits))))
280 (unless (zerop shift)
281 (inst rol old shift)))))
282 (inst mov (make-ea :dword :base object
283 :disp (- (* (+ word vector-data-offset)
285 other-pointer-lowtag))
289 (inst mov result (tn-value value)))
291 (move result value))))))))))
292 (def-small-data-vector-frobs simple-bit-vector 1)
293 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
294 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
296 ;;; And the float variants.
298 (define-vop (data-vector-ref/simple-array-single-float)
299 (:note "inline array access")
300 (:translate data-vector-ref)
302 (:args (object :scs (descriptor-reg))
303 (index :scs (any-reg)))
304 (:arg-types simple-array-single-float positive-fixnum)
305 (:results (value :scs (single-reg)))
306 (:result-types single-float)
308 (with-empty-tn@fp-top(value)
309 (inst fld (make-ea :dword :base object :index index :scale 1
310 :disp (- (* sb!vm:vector-data-offset
312 sb!vm:other-pointer-lowtag))))))
314 (define-vop (data-vector-ref-c/simple-array-single-float)
315 (:note "inline array access")
316 (:translate data-vector-ref)
318 (:args (object :scs (descriptor-reg)))
320 (:arg-types simple-array-single-float (:constant (signed-byte 30)))
321 (:results (value :scs (single-reg)))
322 (:result-types single-float)
324 (with-empty-tn@fp-top(value)
325 (inst fld (make-ea :dword :base object
326 :disp (- (+ (* sb!vm:vector-data-offset
329 sb!vm:other-pointer-lowtag))))))
331 (define-vop (data-vector-set/simple-array-single-float)
332 (:note "inline array store")
333 (:translate data-vector-set)
335 (:args (object :scs (descriptor-reg))
336 (index :scs (any-reg))
337 (value :scs (single-reg) :target result))
338 (:arg-types simple-array-single-float positive-fixnum single-float)
339 (:results (result :scs (single-reg)))
340 (:result-types single-float)
342 (cond ((zerop (tn-offset value))
344 (inst fst (make-ea :dword :base object :index index :scale 1
345 :disp (- (* sb!vm:vector-data-offset
347 sb!vm:other-pointer-lowtag)))
348 (unless (zerop (tn-offset result))
349 ;; Value is in ST0 but not result.
352 ;; Value is not in ST0.
354 (inst fst (make-ea :dword :base object :index index :scale 1
355 :disp (- (* sb!vm:vector-data-offset
357 sb!vm:other-pointer-lowtag)))
358 (cond ((zerop (tn-offset result))
359 ;; The result is in ST0.
362 ;; Neither value or result are in ST0
363 (unless (location= value result)
365 (inst fxch value)))))))
367 (define-vop (data-vector-set-c/simple-array-single-float)
368 (:note "inline array store")
369 (:translate data-vector-set)
371 (:args (object :scs (descriptor-reg))
372 (value :scs (single-reg) :target result))
374 (:arg-types simple-array-single-float (:constant (signed-byte 30))
376 (:results (result :scs (single-reg)))
377 (:result-types single-float)
379 (cond ((zerop (tn-offset value))
381 (inst fst (make-ea :dword :base object
382 :disp (- (+ (* sb!vm:vector-data-offset
385 sb!vm:other-pointer-lowtag)))
386 (unless (zerop (tn-offset result))
387 ;; Value is in ST0 but not result.
390 ;; Value is not in ST0.
392 (inst fst (make-ea :dword :base object
393 :disp (- (+ (* sb!vm:vector-data-offset
396 sb!vm:other-pointer-lowtag)))
397 (cond ((zerop (tn-offset result))
398 ;; The result is in ST0.
401 ;; Neither value or result are in ST0
402 (unless (location= value result)
404 (inst fxch value)))))))
406 (define-vop (data-vector-ref/simple-array-double-float)
407 (:note "inline array access")
408 (:translate data-vector-ref)
410 (:args (object :scs (descriptor-reg))
411 (index :scs (any-reg)))
412 (:arg-types simple-array-double-float positive-fixnum)
413 (:results (value :scs (double-reg)))
414 (:result-types double-float)
416 (with-empty-tn@fp-top(value)
417 (inst fldd (make-ea :dword :base object :index index :scale 2
418 :disp (- (* sb!vm:vector-data-offset
420 sb!vm:other-pointer-lowtag))))))
422 (define-vop (data-vector-ref-c/simple-array-double-float)
423 (:note "inline array access")
424 (:translate data-vector-ref)
426 (:args (object :scs (descriptor-reg)))
428 (:arg-types simple-array-double-float (:constant (signed-byte 30)))
429 (:results (value :scs (double-reg)))
430 (:result-types double-float)
432 (with-empty-tn@fp-top(value)
433 (inst fldd (make-ea :dword :base object
434 :disp (- (+ (* sb!vm:vector-data-offset
437 sb!vm:other-pointer-lowtag))))))
439 (define-vop (data-vector-set/simple-array-double-float)
440 (:note "inline array store")
441 (:translate data-vector-set)
443 (:args (object :scs (descriptor-reg))
444 (index :scs (any-reg))
445 (value :scs (double-reg) :target result))
446 (:arg-types simple-array-double-float positive-fixnum double-float)
447 (:results (result :scs (double-reg)))
448 (:result-types double-float)
450 (cond ((zerop (tn-offset value))
452 (inst fstd (make-ea :dword :base object :index index :scale 2
453 :disp (- (* sb!vm:vector-data-offset
455 sb!vm:other-pointer-lowtag)))
456 (unless (zerop (tn-offset result))
457 ;; Value is in ST0 but not result.
460 ;; Value is not in ST0.
462 (inst fstd (make-ea :dword :base object :index index :scale 2
463 :disp (- (* sb!vm:vector-data-offset
465 sb!vm:other-pointer-lowtag)))
466 (cond ((zerop (tn-offset result))
467 ;; The result is in ST0.
470 ;; Neither value or result are in ST0
471 (unless (location= value result)
473 (inst fxch value)))))))
475 (define-vop (data-vector-set-c/simple-array-double-float)
476 (:note "inline array store")
477 (:translate data-vector-set)
479 (:args (object :scs (descriptor-reg))
480 (value :scs (double-reg) :target result))
482 (:arg-types simple-array-double-float (:constant (signed-byte 30))
484 (:results (result :scs (double-reg)))
485 (:result-types double-float)
487 (cond ((zerop (tn-offset value))
489 (inst fstd (make-ea :dword :base object
490 :disp (- (+ (* sb!vm:vector-data-offset
493 sb!vm:other-pointer-lowtag)))
494 (unless (zerop (tn-offset result))
495 ;; Value is in ST0 but not result.
498 ;; Value is not in ST0.
500 (inst fstd (make-ea :dword :base object
501 :disp (- (+ (* sb!vm:vector-data-offset
504 sb!vm:other-pointer-lowtag)))
505 (cond ((zerop (tn-offset result))
506 ;; The result is in ST0.
509 ;; Neither value or result are in ST0
510 (unless (location= value result)
512 (inst fxch value)))))))
515 (define-vop (data-vector-ref/simple-array-long-float)
516 (:note "inline array access")
517 (:translate data-vector-ref)
519 (:args (object :scs (descriptor-reg) :to :result)
520 (index :scs (any-reg)))
521 (:arg-types simple-array-long-float positive-fixnum)
522 (:temporary (:sc any-reg :from :eval :to :result) temp)
523 (:results (value :scs (long-reg)))
524 (:result-types long-float)
527 (inst lea temp (make-ea :dword :base index :index index :scale 2))
528 (with-empty-tn@fp-top(value)
529 (inst fldl (make-ea :dword :base object :index temp :scale 1
530 :disp (- (* sb!vm:vector-data-offset
532 sb!vm:other-pointer-lowtag))))))
535 (define-vop (data-vector-ref-c/simple-array-long-float)
536 (:note "inline array access")
537 (:translate data-vector-ref)
539 (:args (object :scs (descriptor-reg)))
541 (:arg-types simple-array-long-float (:constant (signed-byte 30)))
542 (:results (value :scs (long-reg)))
543 (:result-types long-float)
545 (with-empty-tn@fp-top(value)
546 (inst fldl (make-ea :dword :base object
547 :disp (- (+ (* sb!vm:vector-data-offset
550 sb!vm:other-pointer-lowtag))))))
553 (define-vop (data-vector-set/simple-array-long-float)
554 (:note "inline array store")
555 (:translate data-vector-set)
557 (:args (object :scs (descriptor-reg) :to :result)
558 (index :scs (any-reg))
559 (value :scs (long-reg) :target result))
560 (:arg-types simple-array-long-float positive-fixnum long-float)
561 (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
562 (:results (result :scs (long-reg)))
563 (:result-types long-float)
566 (inst lea temp (make-ea :dword :base index :index index :scale 2))
567 (cond ((zerop (tn-offset value))
570 (make-ea :dword :base object :index temp :scale 1
571 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
572 sb!vm:other-pointer-lowtag)))
573 (unless (zerop (tn-offset result))
574 ;; Value is in ST0 but not result.
577 ;; Value is not in ST0.
580 (make-ea :dword :base object :index temp :scale 1
581 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
582 sb!vm:other-pointer-lowtag)))
583 (cond ((zerop (tn-offset result))
584 ;; The result is in ST0.
587 ;; Neither value or result are in ST0
588 (unless (location= value result)
590 (inst fxch value)))))))
593 (define-vop (data-vector-set-c/simple-array-long-float)
594 (:note "inline array store")
595 (:translate data-vector-set)
597 (:args (object :scs (descriptor-reg))
598 (value :scs (long-reg) :target result))
600 (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
601 (:results (result :scs (long-reg)))
602 (:result-types long-float)
604 (cond ((zerop (tn-offset value))
606 (store-long-float (make-ea :dword :base object
607 :disp (- (+ (* sb!vm:vector-data-offset
610 sb!vm:other-pointer-lowtag)))
611 (unless (zerop (tn-offset result))
612 ;; Value is in ST0 but not result.
615 ;; Value is not in ST0.
617 (store-long-float (make-ea :dword :base object
618 :disp (- (+ (* sb!vm:vector-data-offset
621 sb!vm:other-pointer-lowtag)))
622 (cond ((zerop (tn-offset result))
623 ;; The result is in ST0.
626 ;; Neither value or result are in ST0
627 (unless (location= value result)
629 (inst fxch value)))))))
631 ;;; complex float variants
633 (define-vop (data-vector-ref/simple-array-complex-single-float)
634 (:note "inline array access")
635 (:translate data-vector-ref)
637 (:args (object :scs (descriptor-reg))
638 (index :scs (any-reg)))
639 (:arg-types simple-array-complex-single-float positive-fixnum)
640 (:results (value :scs (complex-single-reg)))
641 (:result-types complex-single-float)
643 (let ((real-tn (complex-single-reg-real-tn value)))
644 (with-empty-tn@fp-top (real-tn)
645 (inst fld (make-ea :dword :base object :index index :scale 2
646 :disp (- (* sb!vm:vector-data-offset
648 sb!vm:other-pointer-lowtag)))))
649 (let ((imag-tn (complex-single-reg-imag-tn value)))
650 (with-empty-tn@fp-top (imag-tn)
651 (inst fld (make-ea :dword :base object :index index :scale 2
652 :disp (- (* (1+ sb!vm:vector-data-offset)
654 sb!vm:other-pointer-lowtag)))))))
656 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
657 (:note "inline array access")
658 (:translate data-vector-ref)
660 (:args (object :scs (descriptor-reg)))
662 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
663 (:results (value :scs (complex-single-reg)))
664 (:result-types complex-single-float)
666 (let ((real-tn (complex-single-reg-real-tn value)))
667 (with-empty-tn@fp-top (real-tn)
668 (inst fld (make-ea :dword :base object
669 :disp (- (+ (* sb!vm:vector-data-offset
672 sb!vm:other-pointer-lowtag)))))
673 (let ((imag-tn (complex-single-reg-imag-tn value)))
674 (with-empty-tn@fp-top (imag-tn)
675 (inst fld (make-ea :dword :base object
676 :disp (- (+ (* sb!vm:vector-data-offset
679 sb!vm:other-pointer-lowtag)))))))
681 (define-vop (data-vector-set/simple-array-complex-single-float)
682 (:note "inline array store")
683 (:translate data-vector-set)
685 (:args (object :scs (descriptor-reg))
686 (index :scs (any-reg))
687 (value :scs (complex-single-reg) :target result))
688 (:arg-types simple-array-complex-single-float positive-fixnum
689 complex-single-float)
690 (:results (result :scs (complex-single-reg)))
691 (:result-types complex-single-float)
693 (let ((value-real (complex-single-reg-real-tn value))
694 (result-real (complex-single-reg-real-tn result)))
695 (cond ((zerop (tn-offset value-real))
697 (inst fst (make-ea :dword :base object :index index :scale 2
698 :disp (- (* sb!vm:vector-data-offset
700 sb!vm:other-pointer-lowtag)))
701 (unless (zerop (tn-offset result-real))
702 ;; Value is in ST0 but not result.
703 (inst fst result-real)))
705 ;; Value is not in ST0.
706 (inst fxch value-real)
707 (inst fst (make-ea :dword :base object :index index :scale 2
708 :disp (- (* sb!vm:vector-data-offset
710 sb!vm:other-pointer-lowtag)))
711 (cond ((zerop (tn-offset result-real))
712 ;; The result is in ST0.
713 (inst fst value-real))
715 ;; Neither value or result are in ST0
716 (unless (location= value-real result-real)
717 (inst fst result-real))
718 (inst fxch value-real))))))
719 (let ((value-imag (complex-single-reg-imag-tn value))
720 (result-imag (complex-single-reg-imag-tn result)))
721 (inst fxch value-imag)
722 (inst fst (make-ea :dword :base object :index index :scale 2
723 :disp (- (+ (* sb!vm:vector-data-offset
726 sb!vm:other-pointer-lowtag)))
727 (unless (location= value-imag result-imag)
728 (inst fst result-imag))
729 (inst fxch value-imag))))
731 (define-vop (data-vector-set-c/simple-array-complex-single-float)
732 (:note "inline array store")
733 (:translate data-vector-set)
735 (:args (object :scs (descriptor-reg))
736 (value :scs (complex-single-reg) :target result))
738 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
739 complex-single-float)
740 (:results (result :scs (complex-single-reg)))
741 (:result-types complex-single-float)
743 (let ((value-real (complex-single-reg-real-tn value))
744 (result-real (complex-single-reg-real-tn result)))
745 (cond ((zerop (tn-offset value-real))
747 (inst fst (make-ea :dword :base object
748 :disp (- (+ (* sb!vm:vector-data-offset
751 sb!vm:other-pointer-lowtag)))
752 (unless (zerop (tn-offset result-real))
753 ;; Value is in ST0 but not result.
754 (inst fst result-real)))
756 ;; Value is not in ST0.
757 (inst fxch value-real)
758 (inst fst (make-ea :dword :base object
759 :disp (- (+ (* sb!vm:vector-data-offset
762 sb!vm:other-pointer-lowtag)))
763 (cond ((zerop (tn-offset result-real))
764 ;; The result is in ST0.
765 (inst fst value-real))
767 ;; Neither value or result are in ST0
768 (unless (location= value-real result-real)
769 (inst fst result-real))
770 (inst fxch value-real))))))
771 (let ((value-imag (complex-single-reg-imag-tn value))
772 (result-imag (complex-single-reg-imag-tn result)))
773 (inst fxch value-imag)
774 (inst fst (make-ea :dword :base object
775 :disp (- (+ (* sb!vm:vector-data-offset
778 sb!vm:other-pointer-lowtag)))
779 (unless (location= value-imag result-imag)
780 (inst fst result-imag))
781 (inst fxch value-imag))))
784 (define-vop (data-vector-ref/simple-array-complex-double-float)
785 (:note "inline array access")
786 (:translate data-vector-ref)
788 (:args (object :scs (descriptor-reg))
789 (index :scs (any-reg)))
790 (:arg-types simple-array-complex-double-float positive-fixnum)
791 (:results (value :scs (complex-double-reg)))
792 (:result-types complex-double-float)
794 (let ((real-tn (complex-double-reg-real-tn value)))
795 (with-empty-tn@fp-top (real-tn)
796 (inst fldd (make-ea :dword :base object :index index :scale 4
797 :disp (- (* sb!vm:vector-data-offset
799 sb!vm:other-pointer-lowtag)))))
800 (let ((imag-tn (complex-double-reg-imag-tn value)))
801 (with-empty-tn@fp-top (imag-tn)
802 (inst fldd (make-ea :dword :base object :index index :scale 4
803 :disp (- (+ (* sb!vm:vector-data-offset
806 sb!vm:other-pointer-lowtag)))))))
808 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
809 (:note "inline array access")
810 (:translate data-vector-ref)
812 (:args (object :scs (descriptor-reg)))
814 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
815 (:results (value :scs (complex-double-reg)))
816 (:result-types complex-double-float)
818 (let ((real-tn (complex-double-reg-real-tn value)))
819 (with-empty-tn@fp-top (real-tn)
820 (inst fldd (make-ea :dword :base object
821 :disp (- (+ (* sb!vm:vector-data-offset
824 sb!vm:other-pointer-lowtag)))))
825 (let ((imag-tn (complex-double-reg-imag-tn value)))
826 (with-empty-tn@fp-top (imag-tn)
827 (inst fldd (make-ea :dword :base object
828 :disp (- (+ (* sb!vm:vector-data-offset
831 sb!vm:other-pointer-lowtag)))))))
833 (define-vop (data-vector-set/simple-array-complex-double-float)
834 (:note "inline array store")
835 (:translate data-vector-set)
837 (:args (object :scs (descriptor-reg))
838 (index :scs (any-reg))
839 (value :scs (complex-double-reg) :target result))
840 (:arg-types simple-array-complex-double-float positive-fixnum
841 complex-double-float)
842 (:results (result :scs (complex-double-reg)))
843 (:result-types complex-double-float)
845 (let ((value-real (complex-double-reg-real-tn value))
846 (result-real (complex-double-reg-real-tn result)))
847 (cond ((zerop (tn-offset value-real))
849 (inst fstd (make-ea :dword :base object :index index :scale 4
850 :disp (- (* sb!vm:vector-data-offset
852 sb!vm:other-pointer-lowtag)))
853 (unless (zerop (tn-offset result-real))
854 ;; Value is in ST0 but not result.
855 (inst fstd result-real)))
857 ;; Value is not in ST0.
858 (inst fxch value-real)
859 (inst fstd (make-ea :dword :base object :index index :scale 4
860 :disp (- (* sb!vm:vector-data-offset
862 sb!vm:other-pointer-lowtag)))
863 (cond ((zerop (tn-offset result-real))
864 ;; The result is in ST0.
865 (inst fstd value-real))
867 ;; Neither value or result are in ST0
868 (unless (location= value-real result-real)
869 (inst fstd result-real))
870 (inst fxch value-real))))))
871 (let ((value-imag (complex-double-reg-imag-tn value))
872 (result-imag (complex-double-reg-imag-tn result)))
873 (inst fxch value-imag)
874 (inst fstd (make-ea :dword :base object :index index :scale 4
875 :disp (- (+ (* sb!vm:vector-data-offset
878 sb!vm:other-pointer-lowtag)))
879 (unless (location= value-imag result-imag)
880 (inst fstd result-imag))
881 (inst fxch value-imag))))
883 (define-vop (data-vector-set-c/simple-array-complex-double-float)
884 (:note "inline array store")
885 (:translate data-vector-set)
887 (:args (object :scs (descriptor-reg))
888 (value :scs (complex-double-reg) :target result))
890 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
891 complex-double-float)
892 (:results (result :scs (complex-double-reg)))
893 (:result-types complex-double-float)
895 (let ((value-real (complex-double-reg-real-tn value))
896 (result-real (complex-double-reg-real-tn result)))
897 (cond ((zerop (tn-offset value-real))
899 (inst fstd (make-ea :dword :base object
900 :disp (- (+ (* sb!vm:vector-data-offset
903 sb!vm:other-pointer-lowtag)))
904 (unless (zerop (tn-offset result-real))
905 ;; Value is in ST0 but not result.
906 (inst fstd result-real)))
908 ;; Value is not in ST0.
909 (inst fxch value-real)
910 (inst fstd (make-ea :dword :base object
911 :disp (- (+ (* sb!vm:vector-data-offset
914 sb!vm:other-pointer-lowtag)))
915 (cond ((zerop (tn-offset result-real))
916 ;; The result is in ST0.
917 (inst fstd value-real))
919 ;; Neither value or result are in ST0
920 (unless (location= value-real result-real)
921 (inst fstd result-real))
922 (inst fxch value-real))))))
923 (let ((value-imag (complex-double-reg-imag-tn value))
924 (result-imag (complex-double-reg-imag-tn result)))
925 (inst fxch value-imag)
926 (inst fstd (make-ea :dword :base object
927 :disp (- (+ (* sb!vm:vector-data-offset
930 sb!vm:other-pointer-lowtag)))
931 (unless (location= value-imag result-imag)
932 (inst fstd result-imag))
933 (inst fxch value-imag))))
937 (define-vop (data-vector-ref/simple-array-complex-long-float)
938 (:note "inline array access")
939 (:translate data-vector-ref)
941 (:args (object :scs (descriptor-reg) :to :result)
942 (index :scs (any-reg)))
943 (:arg-types simple-array-complex-long-float positive-fixnum)
944 (:temporary (:sc any-reg :from :eval :to :result) temp)
945 (:results (value :scs (complex-long-reg)))
946 (:result-types complex-long-float)
949 (inst lea temp (make-ea :dword :base index :index index :scale 2))
950 (let ((real-tn (complex-long-reg-real-tn value)))
951 (with-empty-tn@fp-top (real-tn)
952 (inst fldl (make-ea :dword :base object :index temp :scale 2
953 :disp (- (* sb!vm:vector-data-offset
955 sb!vm:other-pointer-lowtag)))))
956 (let ((imag-tn (complex-long-reg-imag-tn value)))
957 (with-empty-tn@fp-top (imag-tn)
958 (inst fldl (make-ea :dword :base object :index temp :scale 2
959 :disp (- (+ (* sb!vm:vector-data-offset
962 sb!vm:other-pointer-lowtag)))))))
965 (define-vop (data-vector-ref-c/simple-array-complex-long-float)
966 (:note "inline array access")
967 (:translate data-vector-ref)
969 (:args (object :scs (descriptor-reg)))
971 (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
972 (:results (value :scs (complex-long-reg)))
973 (:result-types complex-long-float)
975 (let ((real-tn (complex-long-reg-real-tn value)))
976 (with-empty-tn@fp-top (real-tn)
977 (inst fldl (make-ea :dword :base object
978 :disp (- (+ (* sb!vm:vector-data-offset
981 sb!vm:other-pointer-lowtag)))))
982 (let ((imag-tn (complex-long-reg-imag-tn value)))
983 (with-empty-tn@fp-top (imag-tn)
984 (inst fldl (make-ea :dword :base object
985 :disp (- (+ (* sb!vm:vector-data-offset
988 sb!vm:other-pointer-lowtag)))))))
991 (define-vop (data-vector-set/simple-array-complex-long-float)
992 (:note "inline array store")
993 (:translate data-vector-set)
995 (:args (object :scs (descriptor-reg) :to :result)
996 (index :scs (any-reg))
997 (value :scs (complex-long-reg) :target result))
998 (:arg-types simple-array-complex-long-float positive-fixnum
1000 (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
1001 (:results (result :scs (complex-long-reg)))
1002 (:result-types complex-long-float)
1005 (inst lea temp (make-ea :dword :base index :index index :scale 2))
1006 (let ((value-real (complex-long-reg-real-tn value))
1007 (result-real (complex-long-reg-real-tn result)))
1008 (cond ((zerop (tn-offset value-real))
1011 (make-ea :dword :base object :index temp :scale 2
1012 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
1013 sb!vm:other-pointer-lowtag)))
1014 (unless (zerop (tn-offset result-real))
1015 ;; Value is in ST0 but not result.
1016 (inst fstd result-real)))
1018 ;; Value is not in ST0.
1019 (inst fxch value-real)
1021 (make-ea :dword :base object :index temp :scale 2
1022 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
1023 sb!vm:other-pointer-lowtag)))
1024 (cond ((zerop (tn-offset result-real))
1025 ;; The result is in ST0.
1026 (inst fstd value-real))
1028 ;; Neither value or result are in ST0
1029 (unless (location= value-real result-real)
1030 (inst fstd result-real))
1031 (inst fxch value-real))))))
1032 (let ((value-imag (complex-long-reg-imag-tn value))
1033 (result-imag (complex-long-reg-imag-tn result)))
1034 (inst fxch value-imag)
1036 (make-ea :dword :base object :index temp :scale 2
1037 :disp (- (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes) 12)
1038 sb!vm:other-pointer-lowtag)))
1039 (unless (location= value-imag result-imag)
1040 (inst fstd result-imag))
1041 (inst fxch value-imag))))
1044 (define-vop (data-vector-set-c/simple-array-complex-long-float)
1045 (:note "inline array store")
1046 (:translate data-vector-set)
1047 (:policy :fast-safe)
1048 (:args (object :scs (descriptor-reg))
1049 (value :scs (complex-long-reg) :target result))
1051 (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
1053 (:results (result :scs (complex-long-reg)))
1054 (:result-types complex-long-float)
1056 (let ((value-real (complex-long-reg-real-tn value))
1057 (result-real (complex-long-reg-real-tn result)))
1058 (cond ((zerop (tn-offset value-real))
1061 (make-ea :dword :base object
1062 :disp (- (+ (* sb!vm:vector-data-offset
1065 sb!vm:other-pointer-lowtag)))
1066 (unless (zerop (tn-offset result-real))
1067 ;; Value is in ST0 but not result.
1068 (inst fstd result-real)))
1070 ;; Value is not in ST0.
1071 (inst fxch value-real)
1073 (make-ea :dword :base object
1074 :disp (- (+ (* sb!vm:vector-data-offset
1077 sb!vm:other-pointer-lowtag)))
1078 (cond ((zerop (tn-offset result-real))
1079 ;; The result is in ST0.
1080 (inst fstd value-real))
1082 ;; Neither value or result are in ST0
1083 (unless (location= value-real result-real)
1084 (inst fstd result-real))
1085 (inst fxch value-real))))))
1086 (let ((value-imag (complex-long-reg-imag-tn value))
1087 (result-imag (complex-long-reg-imag-tn result)))
1088 (inst fxch value-imag)
1090 (make-ea :dword :base object
1091 :disp (- (+ (* sb!vm:vector-data-offset
1093 ;; FIXME: There are so many of these bare constants
1094 ;; (24, 12..) in the LONG-FLOAT code that it's
1095 ;; ridiculous. I should probably just delete it all
1096 ;; instead of appearing to flirt with supporting
1097 ;; this maintenance nightmare.
1099 sb!vm:other-pointer-lowtag)))
1100 (unless (location= value-imag result-imag)
1101 (inst fstd result-imag))
1102 (inst fxch value-imag))))
1105 (macrolet ((define-data-vector-frobs (ptype)
1107 (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
1108 (:translate data-vector-ref)
1109 (:policy :fast-safe)
1110 (:args (object :scs (descriptor-reg))
1111 (index :scs (unsigned-reg)))
1112 (:arg-types ,ptype positive-fixnum)
1113 (:results (value :scs (unsigned-reg signed-reg)))
1114 (:result-types positive-fixnum)
1117 (make-ea :byte :base object :index index :scale 1
1118 :disp (- (* vector-data-offset n-word-bytes)
1119 other-pointer-lowtag)))))
1120 (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
1121 (:translate data-vector-ref)
1122 (:policy :fast-safe)
1123 (:args (object :scs (descriptor-reg)))
1125 (:arg-types ,ptype (:constant (signed-byte 30)))
1126 (:results (value :scs (unsigned-reg signed-reg)))
1127 (:result-types positive-fixnum)
1130 (make-ea :byte :base object
1131 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1132 other-pointer-lowtag)))))
1133 (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
1134 (:translate data-vector-set)
1135 (:policy :fast-safe)
1136 (:args (object :scs (descriptor-reg) :to (:eval 0))
1137 (index :scs (unsigned-reg) :to (:eval 0))
1138 (value :scs (unsigned-reg signed-reg) :target eax))
1139 (:arg-types ,ptype positive-fixnum positive-fixnum)
1140 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1141 :from (:argument 2) :to (:result 0))
1143 (:results (result :scs (unsigned-reg signed-reg)))
1144 (:result-types positive-fixnum)
1147 (inst mov (make-ea :byte :base object :index index :scale 1
1148 :disp (- (* vector-data-offset n-word-bytes)
1149 other-pointer-lowtag))
1152 (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
1153 (:translate data-vector-set)
1154 (:policy :fast-safe)
1155 (:args (object :scs (descriptor-reg) :to (:eval 0))
1156 (value :scs (unsigned-reg signed-reg) :target eax))
1158 (:arg-types ,ptype (:constant (signed-byte 30))
1160 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1161 :from (:argument 1) :to (:result 0))
1163 (:results (result :scs (unsigned-reg signed-reg)))
1164 (:result-types positive-fixnum)
1167 (inst mov (make-ea :byte :base object
1168 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1169 other-pointer-lowtag))
1171 (move result eax))))))
1172 (define-data-vector-frobs simple-array-unsigned-byte-7)
1173 (define-data-vector-frobs simple-array-unsigned-byte-8))
1175 ;;; unsigned-byte-16
1176 (macrolet ((define-data-vector-frobs (ptype)
1178 (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
1179 (:translate data-vector-ref)
1180 (:policy :fast-safe)
1181 (:args (object :scs (descriptor-reg))
1182 (index :scs (unsigned-reg)))
1183 (:arg-types ,ptype positive-fixnum)
1184 (:results (value :scs (unsigned-reg signed-reg)))
1185 (:result-types positive-fixnum)
1188 (make-ea :word :base object :index index :scale 2
1189 :disp (- (* vector-data-offset n-word-bytes)
1190 other-pointer-lowtag)))))
1191 (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
1192 (:translate data-vector-ref)
1193 (:policy :fast-safe)
1194 (:args (object :scs (descriptor-reg)))
1196 (:arg-types ,ptype (:constant (signed-byte 30)))
1197 (:results (value :scs (unsigned-reg signed-reg)))
1198 (:result-types positive-fixnum)
1201 (make-ea :word :base object
1202 :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
1203 other-pointer-lowtag)))))
1204 (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
1205 (:translate data-vector-set)
1206 (:policy :fast-safe)
1207 (:args (object :scs (descriptor-reg) :to (:eval 0))
1208 (index :scs (unsigned-reg) :to (:eval 0))
1209 (value :scs (unsigned-reg signed-reg) :target eax))
1210 (:arg-types ,ptype positive-fixnum positive-fixnum)
1211 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1212 :from (:argument 2) :to (:result 0))
1214 (:results (result :scs (unsigned-reg signed-reg)))
1215 (:result-types positive-fixnum)
1218 (inst mov (make-ea :word :base object :index index :scale 2
1219 :disp (- (* vector-data-offset n-word-bytes)
1220 other-pointer-lowtag))
1224 (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
1225 (:translate data-vector-set)
1226 (:policy :fast-safe)
1227 (:args (object :scs (descriptor-reg) :to (:eval 0))
1228 (value :scs (unsigned-reg signed-reg) :target eax))
1230 (:arg-types ,ptype (:constant (signed-byte 30))
1232 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1233 :from (:argument 1) :to (:result 0))
1235 (:results (result :scs (unsigned-reg signed-reg)))
1236 (:result-types positive-fixnum)
1239 (inst mov (make-ea :word :base object
1240 :disp (- (+ (* vector-data-offset n-word-bytes)
1242 other-pointer-lowtag))
1244 (move result eax))))))
1245 (define-data-vector-frobs simple-array-unsigned-byte-15)
1246 (define-data-vector-frobs simple-array-unsigned-byte-16))
1250 (define-vop (data-vector-ref/simple-base-string)
1251 (:translate data-vector-ref)
1252 (:policy :fast-safe)
1253 (:args (object :scs (descriptor-reg))
1254 (index :scs (unsigned-reg)))
1255 (:arg-types simple-base-string positive-fixnum)
1256 (:temporary (:sc unsigned-reg ; byte-reg
1257 :offset eax-offset ; al-offset
1259 :from (:eval 0) :to (:result 0))
1262 (:results (value :scs (base-char-reg)))
1263 (:result-types base-char)
1266 (make-ea :byte :base object :index index :scale 1
1267 :disp (- (* vector-data-offset n-word-bytes)
1268 other-pointer-lowtag)))
1269 (move value al-tn)))
1271 (define-vop (data-vector-ref-c/simple-base-string)
1272 (:translate data-vector-ref)
1273 (:policy :fast-safe)
1274 (:args (object :scs (descriptor-reg)))
1276 (:arg-types simple-base-string (:constant (signed-byte 30)))
1277 (:temporary (:sc unsigned-reg :offset eax-offset :target value
1278 :from (:eval 0) :to (:result 0))
1281 (:results (value :scs (base-char-reg)))
1282 (:result-types base-char)
1285 (make-ea :byte :base object
1286 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1287 other-pointer-lowtag)))
1288 (move value al-tn)))
1290 (define-vop (data-vector-set/simple-base-string)
1291 (:translate data-vector-set)
1292 (:policy :fast-safe)
1293 (:args (object :scs (descriptor-reg) :to (:eval 0))
1294 (index :scs (unsigned-reg) :to (:eval 0))
1295 (value :scs (base-char-reg)))
1296 (:arg-types simple-base-string positive-fixnum base-char)
1297 (:results (result :scs (base-char-reg)))
1298 (:result-types base-char)
1300 (inst mov (make-ea :byte :base object :index index :scale 1
1301 :disp (- (* vector-data-offset n-word-bytes)
1302 other-pointer-lowtag))
1304 (move result value)))
1306 (define-vop (data-vector-set/simple-base-string-c)
1307 (:translate data-vector-set)
1308 (:policy :fast-safe)
1309 (:args (object :scs (descriptor-reg) :to (:eval 0))
1310 (value :scs (base-char-reg)))
1312 (:arg-types simple-base-string (:constant (signed-byte 30)) base-char)
1313 (:results (result :scs (base-char-reg)))
1314 (:result-types base-char)
1316 (inst mov (make-ea :byte :base object
1317 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1318 other-pointer-lowtag))
1320 (move result value)))
1324 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1325 (:translate data-vector-ref)
1326 (:policy :fast-safe)
1327 (:args (object :scs (descriptor-reg))
1328 (index :scs (unsigned-reg)))
1329 (:arg-types simple-array-signed-byte-8 positive-fixnum)
1330 (:results (value :scs (signed-reg)))
1331 (:result-types tagged-num)
1334 (make-ea :byte :base object :index index :scale 1
1335 :disp (- (* vector-data-offset n-word-bytes)
1336 other-pointer-lowtag)))))
1338 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1339 (:translate data-vector-ref)
1340 (:policy :fast-safe)
1341 (:args (object :scs (descriptor-reg)))
1343 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1344 (:results (value :scs (signed-reg)))
1345 (:result-types tagged-num)
1348 (make-ea :byte :base object
1349 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1350 other-pointer-lowtag)))))
1352 (define-vop (data-vector-set/simple-array-signed-byte-8)
1353 (:translate data-vector-set)
1354 (:policy :fast-safe)
1355 (:args (object :scs (descriptor-reg) :to (:eval 0))
1356 (index :scs (unsigned-reg) :to (:eval 0))
1357 (value :scs (signed-reg) :target eax))
1358 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1359 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1360 :from (:argument 2) :to (:result 0))
1362 (:results (result :scs (signed-reg)))
1363 (:result-types tagged-num)
1366 (inst mov (make-ea :byte :base object :index index :scale 1
1367 :disp (- (* vector-data-offset n-word-bytes)
1368 other-pointer-lowtag))
1372 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1373 (:translate data-vector-set)
1374 (:policy :fast-safe)
1375 (:args (object :scs (descriptor-reg) :to (:eval 0))
1376 (value :scs (signed-reg) :target eax))
1378 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1380 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1381 :from (:argument 1) :to (:result 0))
1383 (:results (result :scs (signed-reg)))
1384 (:result-types tagged-num)
1387 (inst mov (make-ea :byte :base object
1388 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1389 other-pointer-lowtag))
1395 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1396 (:translate data-vector-ref)
1397 (:policy :fast-safe)
1398 (:args (object :scs (descriptor-reg))
1399 (index :scs (unsigned-reg)))
1400 (:arg-types simple-array-signed-byte-16 positive-fixnum)
1401 (:results (value :scs (signed-reg)))
1402 (:result-types tagged-num)
1405 (make-ea :word :base object :index index :scale 2
1406 :disp (- (* vector-data-offset n-word-bytes)
1407 other-pointer-lowtag)))))
1409 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1410 (:translate data-vector-ref)
1411 (:policy :fast-safe)
1412 (:args (object :scs (descriptor-reg)))
1414 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1415 (:results (value :scs (signed-reg)))
1416 (:result-types tagged-num)
1419 (make-ea :word :base object
1420 :disp (- (+ (* vector-data-offset n-word-bytes)
1422 other-pointer-lowtag)))))
1424 (define-vop (data-vector-set/simple-array-signed-byte-16)
1425 (:translate data-vector-set)
1426 (:policy :fast-safe)
1427 (:args (object :scs (descriptor-reg) :to (:eval 0))
1428 (index :scs (unsigned-reg) :to (:eval 0))
1429 (value :scs (signed-reg) :target eax))
1430 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1431 (:temporary (:sc signed-reg :offset eax-offset :target result
1432 :from (:argument 2) :to (:result 0))
1434 (:results (result :scs (signed-reg)))
1435 (:result-types tagged-num)
1438 (inst mov (make-ea :word :base object :index index :scale 2
1439 :disp (- (* vector-data-offset n-word-bytes)
1440 other-pointer-lowtag))
1444 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1445 (:translate data-vector-set)
1446 (:policy :fast-safe)
1447 (:args (object :scs (descriptor-reg) :to (:eval 0))
1448 (value :scs (signed-reg) :target eax))
1450 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1451 (:temporary (:sc signed-reg :offset eax-offset :target result
1452 :from (:argument 1) :to (:result 0))
1454 (:results (result :scs (signed-reg)))
1455 (:result-types tagged-num)
1459 (make-ea :word :base object
1460 :disp (- (+ (* vector-data-offset n-word-bytes)
1462 other-pointer-lowtag))
1466 ;;; These VOPs are used for implementing float slots in structures (whose raw
1467 ;;; data is an unsigned-32 vector).
1468 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
1469 (:translate %raw-ref-single)
1470 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1471 (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
1472 (:translate %raw-ref-single)
1473 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1474 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
1475 (:translate %raw-set-single)
1476 (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
1477 (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
1478 (:translate %raw-set-single)
1479 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1481 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
1482 (:translate %raw-ref-double)
1483 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1484 (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
1485 (:translate %raw-ref-double)
1486 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1487 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
1488 (:translate %raw-set-double)
1489 (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
1490 (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
1491 (:translate %raw-set-double)
1492 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1495 (define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
1496 (:translate %raw-ref-long)
1497 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1499 (define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
1500 (:translate %raw-ref-long)
1501 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1503 (define-vop (raw-set-double data-vector-set/simple-array-long-float)
1504 (:translate %raw-set-long)
1505 (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float))
1507 (define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
1508 (:translate %raw-set-long)
1509 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1512 ;;;; complex-float raw structure slot accessors
1514 (define-vop (raw-ref-complex-single
1515 data-vector-ref/simple-array-complex-single-float)
1516 (:translate %raw-ref-complex-single)
1517 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1518 (define-vop (raw-ref-complex-single-c
1519 data-vector-ref-c/simple-array-complex-single-float)
1520 (:translate %raw-ref-complex-single)
1521 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1522 (define-vop (raw-set-complex-single
1523 data-vector-set/simple-array-complex-single-float)
1524 (:translate %raw-set-complex-single)
1525 (:arg-types simple-array-unsigned-byte-32 positive-fixnum complex-single-float))
1526 (define-vop (raw-set-complex-single-c
1527 data-vector-set-c/simple-array-complex-single-float)
1528 (:translate %raw-set-complex-single)
1529 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1530 complex-single-float))
1531 (define-vop (raw-ref-complex-double
1532 data-vector-ref/simple-array-complex-double-float)
1533 (:translate %raw-ref-complex-double)
1534 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1535 (define-vop (raw-ref-complex-double-c
1536 data-vector-ref-c/simple-array-complex-double-float)
1537 (:translate %raw-ref-complex-double)
1538 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1539 (define-vop (raw-set-complex-double
1540 data-vector-set/simple-array-complex-double-float)
1541 (:translate %raw-set-complex-double)
1542 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
1543 complex-double-float))
1544 (define-vop (raw-set-complex-double-c
1545 data-vector-set-c/simple-array-complex-double-float)
1546 (:translate %raw-set-complex-double)
1547 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1548 complex-double-float))
1550 (define-vop (raw-ref-complex-long
1551 data-vector-ref/simple-array-complex-long-float)
1552 (:translate %raw-ref-complex-long)
1553 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1555 (define-vop (raw-ref-complex-long-c
1556 data-vector-ref-c/simple-array-complex-long-float)
1557 (:translate %raw-ref-complex-long)
1558 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1560 (define-vop (raw-set-complex-long
1561 data-vector-set/simple-array-complex-long-float)
1562 (:translate %raw-set-complex-long)
1563 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
1564 complex-long-float))
1566 (define-vop (raw-set-complex-long-c
1567 data-vector-set-c/simple-array-complex-long-float)
1568 (:translate %raw-set-complex-long)
1569 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1570 complex-long-float))
1572 ;;; These vops are useful for accessing the bits of a vector
1573 ;;; irrespective of what type of vector it is.
1574 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1575 unsigned-num %raw-bits)
1576 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1577 unsigned-num %set-raw-bits)
1579 ;;;; miscellaneous array VOPs
1581 (define-vop (get-vector-subtype get-header-data))
1582 (define-vop (set-vector-subtype set-header-data))