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-signed-byte-32 signed-num
156 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
157 ;;;; bit, 2-bit, and 4-bit vectors
159 (macrolet ((def-small-data-vector-frobs (type bits)
160 (let* ((elements-per-word (floor sb!vm:n-word-bits bits))
161 (bit-shift (1- (integer-length elements-per-word))))
163 (define-vop (,(symbolicate 'data-vector-ref/ type))
164 (:note "inline array access")
165 (:translate data-vector-ref)
167 (:args (object :scs (descriptor-reg))
168 (index :scs (unsigned-reg)))
169 (:arg-types ,type positive-fixnum)
170 (:results (result :scs (unsigned-reg) :from (:argument 0)))
171 (:result-types positive-fixnum)
172 (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
175 (inst shr ecx ,bit-shift)
177 (make-ea :dword :base object :index ecx :scale 4
178 :disp (- (* vector-data-offset n-word-bytes)
179 other-pointer-lowtag)))
181 (inst and ecx ,(1- elements-per-word))
183 `((inst shl ecx ,(1- (integer-length bits)))))
184 (inst shr result :cl)
185 (inst and result ,(1- (ash 1 bits)))))
186 (define-vop (,(symbolicate 'data-vector-ref-c/ type))
187 (:translate data-vector-ref)
189 (:args (object :scs (descriptor-reg)))
190 (:arg-types ,type (:constant index))
192 (:results (result :scs (unsigned-reg)))
193 (:result-types positive-fixnum)
195 (multiple-value-bind (word extra) (floor index ,elements-per-word)
196 (loadw result object (+ word vector-data-offset)
197 other-pointer-lowtag)
198 (unless (zerop extra)
199 (inst shr result (* extra ,bits)))
200 (unless (= extra ,(1- elements-per-word))
201 (inst and result ,(1- (ash 1 bits)))))))
202 (define-vop (,(symbolicate 'data-vector-set/ type))
203 (:note "inline array store")
204 (:translate data-vector-set)
206 (:args (object :scs (descriptor-reg) :target ptr)
207 (index :scs (unsigned-reg) :target ecx)
208 (value :scs (unsigned-reg immediate) :target result))
209 (:arg-types ,type positive-fixnum positive-fixnum)
210 (:results (result :scs (unsigned-reg)))
211 (:result-types positive-fixnum)
212 (:temporary (:sc unsigned-reg) word-index)
213 (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old)
214 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1))
217 (move word-index index)
218 (inst shr word-index ,bit-shift)
220 (make-ea :dword :base object :index word-index :scale 4
221 :disp (- (* vector-data-offset n-word-bytes)
222 other-pointer-lowtag)))
225 (inst and ecx ,(1- elements-per-word))
227 `((inst shl ecx ,(1- (integer-length bits)))))
229 (unless (and (sc-is value immediate)
230 (= (tn-value value) ,(1- (ash 1 bits))))
231 (inst and old ,(lognot (1- (ash 1 bits)))))
234 (unless (zerop (tn-value value))
235 (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
237 (inst or old value)))
242 (inst mov result (tn-value value)))
244 (move result value)))))
245 (define-vop (,(symbolicate 'data-vector-set-c/ type))
246 (:translate data-vector-set)
248 (:args (object :scs (descriptor-reg))
249 (value :scs (unsigned-reg immediate) :target result))
250 (:arg-types ,type (:constant index) positive-fixnum)
252 (:results (result :scs (unsigned-reg)))
253 (:result-types positive-fixnum)
254 (:temporary (:sc unsigned-reg :to (:result 0)) old)
256 (multiple-value-bind (word extra) (floor index ,elements-per-word)
258 (make-ea :dword :base object
259 :disp (- (* (+ word vector-data-offset)
261 other-pointer-lowtag)))
264 (let* ((value (tn-value value))
265 (mask ,(1- (ash 1 bits)))
266 (shift (* extra ,bits)))
267 (unless (= value mask)
268 (inst and old (lognot (ash mask shift))))
269 (unless (zerop value)
270 (inst or old (ash value shift)))))
272 (let ((shift (* extra ,bits)))
273 (unless (zerop shift)
275 (inst and old (lognot ,(1- (ash 1 bits))))
277 (inst rol old shift)))))
278 (inst mov (make-ea :dword :base object
279 :disp (- (* (+ word vector-data-offset)
281 other-pointer-lowtag))
285 (inst mov result (tn-value value)))
287 (move result value))))))))))
288 (def-small-data-vector-frobs simple-bit-vector 1)
289 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
290 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
292 ;;; And the float variants.
294 (define-vop (data-vector-ref/simple-array-single-float)
295 (:note "inline array access")
296 (:translate data-vector-ref)
298 (:args (object :scs (descriptor-reg))
299 (index :scs (any-reg)))
300 (:arg-types simple-array-single-float positive-fixnum)
301 (:results (value :scs (single-reg)))
302 (:result-types single-float)
304 (with-empty-tn@fp-top(value)
305 (inst fld (make-ea :dword :base object :index index :scale 1
306 :disp (- (* sb!vm:vector-data-offset
308 sb!vm:other-pointer-lowtag))))))
310 (define-vop (data-vector-ref-c/simple-array-single-float)
311 (:note "inline array access")
312 (:translate data-vector-ref)
314 (:args (object :scs (descriptor-reg)))
316 (:arg-types simple-array-single-float (:constant (signed-byte 30)))
317 (:results (value :scs (single-reg)))
318 (:result-types single-float)
320 (with-empty-tn@fp-top(value)
321 (inst fld (make-ea :dword :base object
322 :disp (- (+ (* sb!vm:vector-data-offset
325 sb!vm:other-pointer-lowtag))))))
327 (define-vop (data-vector-set/simple-array-single-float)
328 (:note "inline array store")
329 (:translate data-vector-set)
331 (:args (object :scs (descriptor-reg))
332 (index :scs (any-reg))
333 (value :scs (single-reg) :target result))
334 (:arg-types simple-array-single-float positive-fixnum single-float)
335 (:results (result :scs (single-reg)))
336 (:result-types single-float)
338 (cond ((zerop (tn-offset value))
340 (inst fst (make-ea :dword :base object :index index :scale 1
341 :disp (- (* sb!vm:vector-data-offset
343 sb!vm:other-pointer-lowtag)))
344 (unless (zerop (tn-offset result))
345 ;; Value is in ST0 but not result.
348 ;; Value is not in ST0.
350 (inst fst (make-ea :dword :base object :index index :scale 1
351 :disp (- (* sb!vm:vector-data-offset
353 sb!vm:other-pointer-lowtag)))
354 (cond ((zerop (tn-offset result))
355 ;; The result is in ST0.
358 ;; Neither value or result are in ST0
359 (unless (location= value result)
361 (inst fxch value)))))))
363 (define-vop (data-vector-set-c/simple-array-single-float)
364 (:note "inline array store")
365 (:translate data-vector-set)
367 (:args (object :scs (descriptor-reg))
368 (value :scs (single-reg) :target result))
370 (:arg-types simple-array-single-float (:constant (signed-byte 30))
372 (:results (result :scs (single-reg)))
373 (:result-types single-float)
375 (cond ((zerop (tn-offset value))
377 (inst fst (make-ea :dword :base object
378 :disp (- (+ (* sb!vm:vector-data-offset
381 sb!vm:other-pointer-lowtag)))
382 (unless (zerop (tn-offset result))
383 ;; Value is in ST0 but not result.
386 ;; Value is not in ST0.
388 (inst fst (make-ea :dword :base object
389 :disp (- (+ (* sb!vm:vector-data-offset
392 sb!vm:other-pointer-lowtag)))
393 (cond ((zerop (tn-offset result))
394 ;; The result is in ST0.
397 ;; Neither value or result are in ST0
398 (unless (location= value result)
400 (inst fxch value)))))))
402 (define-vop (data-vector-ref/simple-array-double-float)
403 (:note "inline array access")
404 (:translate data-vector-ref)
406 (:args (object :scs (descriptor-reg))
407 (index :scs (any-reg)))
408 (:arg-types simple-array-double-float positive-fixnum)
409 (:results (value :scs (double-reg)))
410 (:result-types double-float)
412 (with-empty-tn@fp-top(value)
413 (inst fldd (make-ea :dword :base object :index index :scale 2
414 :disp (- (* sb!vm:vector-data-offset
416 sb!vm:other-pointer-lowtag))))))
418 (define-vop (data-vector-ref-c/simple-array-double-float)
419 (:note "inline array access")
420 (:translate data-vector-ref)
422 (:args (object :scs (descriptor-reg)))
424 (:arg-types simple-array-double-float (:constant (signed-byte 30)))
425 (:results (value :scs (double-reg)))
426 (:result-types double-float)
428 (with-empty-tn@fp-top(value)
429 (inst fldd (make-ea :dword :base object
430 :disp (- (+ (* sb!vm:vector-data-offset
433 sb!vm:other-pointer-lowtag))))))
435 (define-vop (data-vector-set/simple-array-double-float)
436 (:note "inline array store")
437 (:translate data-vector-set)
439 (:args (object :scs (descriptor-reg))
440 (index :scs (any-reg))
441 (value :scs (double-reg) :target result))
442 (:arg-types simple-array-double-float positive-fixnum double-float)
443 (:results (result :scs (double-reg)))
444 (:result-types double-float)
446 (cond ((zerop (tn-offset value))
448 (inst fstd (make-ea :dword :base object :index index :scale 2
449 :disp (- (* sb!vm:vector-data-offset
451 sb!vm:other-pointer-lowtag)))
452 (unless (zerop (tn-offset result))
453 ;; Value is in ST0 but not result.
456 ;; Value is not in ST0.
458 (inst fstd (make-ea :dword :base object :index index :scale 2
459 :disp (- (* sb!vm:vector-data-offset
461 sb!vm:other-pointer-lowtag)))
462 (cond ((zerop (tn-offset result))
463 ;; The result is in ST0.
466 ;; Neither value or result are in ST0
467 (unless (location= value result)
469 (inst fxch value)))))))
471 (define-vop (data-vector-set-c/simple-array-double-float)
472 (:note "inline array store")
473 (:translate data-vector-set)
475 (:args (object :scs (descriptor-reg))
476 (value :scs (double-reg) :target result))
478 (:arg-types simple-array-double-float (:constant (signed-byte 30))
480 (:results (result :scs (double-reg)))
481 (:result-types double-float)
483 (cond ((zerop (tn-offset value))
485 (inst fstd (make-ea :dword :base object
486 :disp (- (+ (* sb!vm:vector-data-offset
489 sb!vm:other-pointer-lowtag)))
490 (unless (zerop (tn-offset result))
491 ;; Value is in ST0 but not result.
494 ;; Value is not in ST0.
496 (inst fstd (make-ea :dword :base object
497 :disp (- (+ (* sb!vm:vector-data-offset
500 sb!vm:other-pointer-lowtag)))
501 (cond ((zerop (tn-offset result))
502 ;; The result is in ST0.
505 ;; Neither value or result are in ST0
506 (unless (location= value result)
508 (inst fxch value)))))))
511 (define-vop (data-vector-ref/simple-array-long-float)
512 (:note "inline array access")
513 (:translate data-vector-ref)
515 (:args (object :scs (descriptor-reg) :to :result)
516 (index :scs (any-reg)))
517 (:arg-types simple-array-long-float positive-fixnum)
518 (:temporary (:sc any-reg :from :eval :to :result) temp)
519 (:results (value :scs (long-reg)))
520 (:result-types long-float)
523 (inst lea temp (make-ea :dword :base index :index index :scale 2))
524 (with-empty-tn@fp-top(value)
525 (inst fldl (make-ea :dword :base object :index temp :scale 1
526 :disp (- (* sb!vm:vector-data-offset
528 sb!vm:other-pointer-lowtag))))))
531 (define-vop (data-vector-ref-c/simple-array-long-float)
532 (:note "inline array access")
533 (:translate data-vector-ref)
535 (:args (object :scs (descriptor-reg)))
537 (:arg-types simple-array-long-float (:constant (signed-byte 30)))
538 (:results (value :scs (long-reg)))
539 (:result-types long-float)
541 (with-empty-tn@fp-top(value)
542 (inst fldl (make-ea :dword :base object
543 :disp (- (+ (* sb!vm:vector-data-offset
546 sb!vm:other-pointer-lowtag))))))
549 (define-vop (data-vector-set/simple-array-long-float)
550 (:note "inline array store")
551 (:translate data-vector-set)
553 (:args (object :scs (descriptor-reg) :to :result)
554 (index :scs (any-reg))
555 (value :scs (long-reg) :target result))
556 (:arg-types simple-array-long-float positive-fixnum long-float)
557 (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
558 (:results (result :scs (long-reg)))
559 (:result-types long-float)
562 (inst lea temp (make-ea :dword :base index :index index :scale 2))
563 (cond ((zerop (tn-offset value))
566 (make-ea :dword :base object :index temp :scale 1
567 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
568 sb!vm:other-pointer-lowtag)))
569 (unless (zerop (tn-offset result))
570 ;; Value is in ST0 but not result.
573 ;; Value is not in ST0.
576 (make-ea :dword :base object :index temp :scale 1
577 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
578 sb!vm:other-pointer-lowtag)))
579 (cond ((zerop (tn-offset result))
580 ;; The result is in ST0.
583 ;; Neither value or result are in ST0
584 (unless (location= value result)
586 (inst fxch value)))))))
589 (define-vop (data-vector-set-c/simple-array-long-float)
590 (:note "inline array store")
591 (:translate data-vector-set)
593 (:args (object :scs (descriptor-reg))
594 (value :scs (long-reg) :target result))
596 (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
597 (:results (result :scs (long-reg)))
598 (:result-types long-float)
600 (cond ((zerop (tn-offset value))
602 (store-long-float (make-ea :dword :base object
603 :disp (- (+ (* sb!vm:vector-data-offset
606 sb!vm:other-pointer-lowtag)))
607 (unless (zerop (tn-offset result))
608 ;; Value is in ST0 but not result.
611 ;; Value is not in ST0.
613 (store-long-float (make-ea :dword :base object
614 :disp (- (+ (* sb!vm:vector-data-offset
617 sb!vm:other-pointer-lowtag)))
618 (cond ((zerop (tn-offset result))
619 ;; The result is in ST0.
622 ;; Neither value or result are in ST0
623 (unless (location= value result)
625 (inst fxch value)))))))
627 ;;; complex float variants
629 (define-vop (data-vector-ref/simple-array-complex-single-float)
630 (:note "inline array access")
631 (:translate data-vector-ref)
633 (:args (object :scs (descriptor-reg))
634 (index :scs (any-reg)))
635 (:arg-types simple-array-complex-single-float positive-fixnum)
636 (:results (value :scs (complex-single-reg)))
637 (:result-types complex-single-float)
639 (let ((real-tn (complex-single-reg-real-tn value)))
640 (with-empty-tn@fp-top (real-tn)
641 (inst fld (make-ea :dword :base object :index index :scale 2
642 :disp (- (* sb!vm:vector-data-offset
644 sb!vm:other-pointer-lowtag)))))
645 (let ((imag-tn (complex-single-reg-imag-tn value)))
646 (with-empty-tn@fp-top (imag-tn)
647 (inst fld (make-ea :dword :base object :index index :scale 2
648 :disp (- (* (1+ sb!vm:vector-data-offset)
650 sb!vm:other-pointer-lowtag)))))))
652 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
653 (:note "inline array access")
654 (:translate data-vector-ref)
656 (:args (object :scs (descriptor-reg)))
658 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
659 (:results (value :scs (complex-single-reg)))
660 (:result-types complex-single-float)
662 (let ((real-tn (complex-single-reg-real-tn value)))
663 (with-empty-tn@fp-top (real-tn)
664 (inst fld (make-ea :dword :base object
665 :disp (- (+ (* sb!vm:vector-data-offset
668 sb!vm:other-pointer-lowtag)))))
669 (let ((imag-tn (complex-single-reg-imag-tn value)))
670 (with-empty-tn@fp-top (imag-tn)
671 (inst fld (make-ea :dword :base object
672 :disp (- (+ (* sb!vm:vector-data-offset
675 sb!vm:other-pointer-lowtag)))))))
677 (define-vop (data-vector-set/simple-array-complex-single-float)
678 (:note "inline array store")
679 (:translate data-vector-set)
681 (:args (object :scs (descriptor-reg))
682 (index :scs (any-reg))
683 (value :scs (complex-single-reg) :target result))
684 (:arg-types simple-array-complex-single-float positive-fixnum
685 complex-single-float)
686 (:results (result :scs (complex-single-reg)))
687 (:result-types complex-single-float)
689 (let ((value-real (complex-single-reg-real-tn value))
690 (result-real (complex-single-reg-real-tn result)))
691 (cond ((zerop (tn-offset value-real))
693 (inst fst (make-ea :dword :base object :index index :scale 2
694 :disp (- (* sb!vm:vector-data-offset
696 sb!vm:other-pointer-lowtag)))
697 (unless (zerop (tn-offset result-real))
698 ;; Value is in ST0 but not result.
699 (inst fst result-real)))
701 ;; Value is not in ST0.
702 (inst fxch value-real)
703 (inst fst (make-ea :dword :base object :index index :scale 2
704 :disp (- (* sb!vm:vector-data-offset
706 sb!vm:other-pointer-lowtag)))
707 (cond ((zerop (tn-offset result-real))
708 ;; The result is in ST0.
709 (inst fst value-real))
711 ;; Neither value or result are in ST0
712 (unless (location= value-real result-real)
713 (inst fst result-real))
714 (inst fxch value-real))))))
715 (let ((value-imag (complex-single-reg-imag-tn value))
716 (result-imag (complex-single-reg-imag-tn result)))
717 (inst fxch value-imag)
718 (inst fst (make-ea :dword :base object :index index :scale 2
719 :disp (- (+ (* sb!vm:vector-data-offset
722 sb!vm:other-pointer-lowtag)))
723 (unless (location= value-imag result-imag)
724 (inst fst result-imag))
725 (inst fxch value-imag))))
727 (define-vop (data-vector-set-c/simple-array-complex-single-float)
728 (:note "inline array store")
729 (:translate data-vector-set)
731 (:args (object :scs (descriptor-reg))
732 (value :scs (complex-single-reg) :target result))
734 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
735 complex-single-float)
736 (:results (result :scs (complex-single-reg)))
737 (:result-types complex-single-float)
739 (let ((value-real (complex-single-reg-real-tn value))
740 (result-real (complex-single-reg-real-tn result)))
741 (cond ((zerop (tn-offset value-real))
743 (inst fst (make-ea :dword :base object
744 :disp (- (+ (* sb!vm:vector-data-offset
747 sb!vm:other-pointer-lowtag)))
748 (unless (zerop (tn-offset result-real))
749 ;; Value is in ST0 but not result.
750 (inst fst result-real)))
752 ;; Value is not in ST0.
753 (inst fxch value-real)
754 (inst fst (make-ea :dword :base object
755 :disp (- (+ (* sb!vm:vector-data-offset
758 sb!vm:other-pointer-lowtag)))
759 (cond ((zerop (tn-offset result-real))
760 ;; The result is in ST0.
761 (inst fst value-real))
763 ;; Neither value or result are in ST0
764 (unless (location= value-real result-real)
765 (inst fst result-real))
766 (inst fxch value-real))))))
767 (let ((value-imag (complex-single-reg-imag-tn value))
768 (result-imag (complex-single-reg-imag-tn result)))
769 (inst fxch value-imag)
770 (inst fst (make-ea :dword :base object
771 :disp (- (+ (* sb!vm:vector-data-offset
774 sb!vm:other-pointer-lowtag)))
775 (unless (location= value-imag result-imag)
776 (inst fst result-imag))
777 (inst fxch value-imag))))
780 (define-vop (data-vector-ref/simple-array-complex-double-float)
781 (:note "inline array access")
782 (:translate data-vector-ref)
784 (:args (object :scs (descriptor-reg))
785 (index :scs (any-reg)))
786 (:arg-types simple-array-complex-double-float positive-fixnum)
787 (:results (value :scs (complex-double-reg)))
788 (:result-types complex-double-float)
790 (let ((real-tn (complex-double-reg-real-tn value)))
791 (with-empty-tn@fp-top (real-tn)
792 (inst fldd (make-ea :dword :base object :index index :scale 4
793 :disp (- (* sb!vm:vector-data-offset
795 sb!vm:other-pointer-lowtag)))))
796 (let ((imag-tn (complex-double-reg-imag-tn value)))
797 (with-empty-tn@fp-top (imag-tn)
798 (inst fldd (make-ea :dword :base object :index index :scale 4
799 :disp (- (+ (* sb!vm:vector-data-offset
802 sb!vm:other-pointer-lowtag)))))))
804 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
805 (:note "inline array access")
806 (:translate data-vector-ref)
808 (:args (object :scs (descriptor-reg)))
810 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
811 (:results (value :scs (complex-double-reg)))
812 (:result-types complex-double-float)
814 (let ((real-tn (complex-double-reg-real-tn value)))
815 (with-empty-tn@fp-top (real-tn)
816 (inst fldd (make-ea :dword :base object
817 :disp (- (+ (* sb!vm:vector-data-offset
820 sb!vm:other-pointer-lowtag)))))
821 (let ((imag-tn (complex-double-reg-imag-tn value)))
822 (with-empty-tn@fp-top (imag-tn)
823 (inst fldd (make-ea :dword :base object
824 :disp (- (+ (* sb!vm:vector-data-offset
827 sb!vm:other-pointer-lowtag)))))))
829 (define-vop (data-vector-set/simple-array-complex-double-float)
830 (:note "inline array store")
831 (:translate data-vector-set)
833 (:args (object :scs (descriptor-reg))
834 (index :scs (any-reg))
835 (value :scs (complex-double-reg) :target result))
836 (:arg-types simple-array-complex-double-float positive-fixnum
837 complex-double-float)
838 (:results (result :scs (complex-double-reg)))
839 (:result-types complex-double-float)
841 (let ((value-real (complex-double-reg-real-tn value))
842 (result-real (complex-double-reg-real-tn result)))
843 (cond ((zerop (tn-offset value-real))
845 (inst fstd (make-ea :dword :base object :index index :scale 4
846 :disp (- (* sb!vm:vector-data-offset
848 sb!vm:other-pointer-lowtag)))
849 (unless (zerop (tn-offset result-real))
850 ;; Value is in ST0 but not result.
851 (inst fstd result-real)))
853 ;; Value is not in ST0.
854 (inst fxch value-real)
855 (inst fstd (make-ea :dword :base object :index index :scale 4
856 :disp (- (* sb!vm:vector-data-offset
858 sb!vm:other-pointer-lowtag)))
859 (cond ((zerop (tn-offset result-real))
860 ;; The result is in ST0.
861 (inst fstd value-real))
863 ;; Neither value or result are in ST0
864 (unless (location= value-real result-real)
865 (inst fstd result-real))
866 (inst fxch value-real))))))
867 (let ((value-imag (complex-double-reg-imag-tn value))
868 (result-imag (complex-double-reg-imag-tn result)))
869 (inst fxch value-imag)
870 (inst fstd (make-ea :dword :base object :index index :scale 4
871 :disp (- (+ (* sb!vm:vector-data-offset
874 sb!vm:other-pointer-lowtag)))
875 (unless (location= value-imag result-imag)
876 (inst fstd result-imag))
877 (inst fxch value-imag))))
879 (define-vop (data-vector-set-c/simple-array-complex-double-float)
880 (:note "inline array store")
881 (:translate data-vector-set)
883 (:args (object :scs (descriptor-reg))
884 (value :scs (complex-double-reg) :target result))
886 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
887 complex-double-float)
888 (:results (result :scs (complex-double-reg)))
889 (:result-types complex-double-float)
891 (let ((value-real (complex-double-reg-real-tn value))
892 (result-real (complex-double-reg-real-tn result)))
893 (cond ((zerop (tn-offset value-real))
895 (inst fstd (make-ea :dword :base object
896 :disp (- (+ (* sb!vm:vector-data-offset
899 sb!vm:other-pointer-lowtag)))
900 (unless (zerop (tn-offset result-real))
901 ;; Value is in ST0 but not result.
902 (inst fstd result-real)))
904 ;; Value is not in ST0.
905 (inst fxch value-real)
906 (inst fstd (make-ea :dword :base object
907 :disp (- (+ (* sb!vm:vector-data-offset
910 sb!vm:other-pointer-lowtag)))
911 (cond ((zerop (tn-offset result-real))
912 ;; The result is in ST0.
913 (inst fstd value-real))
915 ;; Neither value or result are in ST0
916 (unless (location= value-real result-real)
917 (inst fstd result-real))
918 (inst fxch value-real))))))
919 (let ((value-imag (complex-double-reg-imag-tn value))
920 (result-imag (complex-double-reg-imag-tn result)))
921 (inst fxch value-imag)
922 (inst fstd (make-ea :dword :base object
923 :disp (- (+ (* sb!vm:vector-data-offset
926 sb!vm:other-pointer-lowtag)))
927 (unless (location= value-imag result-imag)
928 (inst fstd result-imag))
929 (inst fxch value-imag))))
933 (define-vop (data-vector-ref/simple-array-complex-long-float)
934 (:note "inline array access")
935 (:translate data-vector-ref)
937 (:args (object :scs (descriptor-reg) :to :result)
938 (index :scs (any-reg)))
939 (:arg-types simple-array-complex-long-float positive-fixnum)
940 (:temporary (:sc any-reg :from :eval :to :result) temp)
941 (:results (value :scs (complex-long-reg)))
942 (:result-types complex-long-float)
945 (inst lea temp (make-ea :dword :base index :index index :scale 2))
946 (let ((real-tn (complex-long-reg-real-tn value)))
947 (with-empty-tn@fp-top (real-tn)
948 (inst fldl (make-ea :dword :base object :index temp :scale 2
949 :disp (- (* sb!vm:vector-data-offset
951 sb!vm:other-pointer-lowtag)))))
952 (let ((imag-tn (complex-long-reg-imag-tn value)))
953 (with-empty-tn@fp-top (imag-tn)
954 (inst fldl (make-ea :dword :base object :index temp :scale 2
955 :disp (- (+ (* sb!vm:vector-data-offset
958 sb!vm:other-pointer-lowtag)))))))
961 (define-vop (data-vector-ref-c/simple-array-complex-long-float)
962 (:note "inline array access")
963 (:translate data-vector-ref)
965 (:args (object :scs (descriptor-reg)))
967 (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
968 (:results (value :scs (complex-long-reg)))
969 (:result-types complex-long-float)
971 (let ((real-tn (complex-long-reg-real-tn value)))
972 (with-empty-tn@fp-top (real-tn)
973 (inst fldl (make-ea :dword :base object
974 :disp (- (+ (* sb!vm:vector-data-offset
977 sb!vm:other-pointer-lowtag)))))
978 (let ((imag-tn (complex-long-reg-imag-tn value)))
979 (with-empty-tn@fp-top (imag-tn)
980 (inst fldl (make-ea :dword :base object
981 :disp (- (+ (* sb!vm:vector-data-offset
984 sb!vm:other-pointer-lowtag)))))))
987 (define-vop (data-vector-set/simple-array-complex-long-float)
988 (:note "inline array store")
989 (:translate data-vector-set)
991 (:args (object :scs (descriptor-reg) :to :result)
992 (index :scs (any-reg))
993 (value :scs (complex-long-reg) :target result))
994 (:arg-types simple-array-complex-long-float positive-fixnum
996 (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
997 (:results (result :scs (complex-long-reg)))
998 (:result-types complex-long-float)
1001 (inst lea temp (make-ea :dword :base index :index index :scale 2))
1002 (let ((value-real (complex-long-reg-real-tn value))
1003 (result-real (complex-long-reg-real-tn result)))
1004 (cond ((zerop (tn-offset value-real))
1007 (make-ea :dword :base object :index temp :scale 2
1008 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
1009 sb!vm:other-pointer-lowtag)))
1010 (unless (zerop (tn-offset result-real))
1011 ;; Value is in ST0 but not result.
1012 (inst fstd result-real)))
1014 ;; Value is not in ST0.
1015 (inst fxch value-real)
1017 (make-ea :dword :base object :index temp :scale 2
1018 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
1019 sb!vm:other-pointer-lowtag)))
1020 (cond ((zerop (tn-offset result-real))
1021 ;; The result is in ST0.
1022 (inst fstd value-real))
1024 ;; Neither value or result are in ST0
1025 (unless (location= value-real result-real)
1026 (inst fstd result-real))
1027 (inst fxch value-real))))))
1028 (let ((value-imag (complex-long-reg-imag-tn value))
1029 (result-imag (complex-long-reg-imag-tn result)))
1030 (inst fxch value-imag)
1032 (make-ea :dword :base object :index temp :scale 2
1033 :disp (- (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes) 12)
1034 sb!vm:other-pointer-lowtag)))
1035 (unless (location= value-imag result-imag)
1036 (inst fstd result-imag))
1037 (inst fxch value-imag))))
1040 (define-vop (data-vector-set-c/simple-array-complex-long-float)
1041 (:note "inline array store")
1042 (:translate data-vector-set)
1043 (:policy :fast-safe)
1044 (:args (object :scs (descriptor-reg))
1045 (value :scs (complex-long-reg) :target result))
1047 (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
1049 (:results (result :scs (complex-long-reg)))
1050 (:result-types complex-long-float)
1052 (let ((value-real (complex-long-reg-real-tn value))
1053 (result-real (complex-long-reg-real-tn result)))
1054 (cond ((zerop (tn-offset value-real))
1057 (make-ea :dword :base object
1058 :disp (- (+ (* sb!vm:vector-data-offset
1061 sb!vm:other-pointer-lowtag)))
1062 (unless (zerop (tn-offset result-real))
1063 ;; Value is in ST0 but not result.
1064 (inst fstd result-real)))
1066 ;; Value is not in ST0.
1067 (inst fxch value-real)
1069 (make-ea :dword :base object
1070 :disp (- (+ (* sb!vm:vector-data-offset
1073 sb!vm:other-pointer-lowtag)))
1074 (cond ((zerop (tn-offset result-real))
1075 ;; The result is in ST0.
1076 (inst fstd value-real))
1078 ;; Neither value or result are in ST0
1079 (unless (location= value-real result-real)
1080 (inst fstd result-real))
1081 (inst fxch value-real))))))
1082 (let ((value-imag (complex-long-reg-imag-tn value))
1083 (result-imag (complex-long-reg-imag-tn result)))
1084 (inst fxch value-imag)
1086 (make-ea :dword :base object
1087 :disp (- (+ (* sb!vm:vector-data-offset
1089 ;; FIXME: There are so many of these bare constants
1090 ;; (24, 12..) in the LONG-FLOAT code that it's
1091 ;; ridiculous. I should probably just delete it all
1092 ;; instead of appearing to flirt with supporting
1093 ;; this maintenance nightmare.
1095 sb!vm:other-pointer-lowtag)))
1096 (unless (location= value-imag result-imag)
1097 (inst fstd result-imag))
1098 (inst fxch value-imag))))
1102 (define-vop (data-vector-ref/simple-array-unsigned-byte-8)
1103 (:translate data-vector-ref)
1104 (:policy :fast-safe)
1105 (:args (object :scs (descriptor-reg))
1106 (index :scs (unsigned-reg)))
1107 (:arg-types simple-array-unsigned-byte-8 positive-fixnum)
1108 (:results (value :scs (unsigned-reg signed-reg)))
1109 (:result-types positive-fixnum)
1112 (make-ea :byte :base object :index index :scale 1
1113 :disp (- (* vector-data-offset n-word-bytes)
1114 other-pointer-lowtag)))))
1116 (define-vop (data-vector-ref-c/simple-array-unsigned-byte-8)
1117 (:translate data-vector-ref)
1118 (:policy :fast-safe)
1119 (:args (object :scs (descriptor-reg)))
1121 (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)))
1122 (:results (value :scs (unsigned-reg signed-reg)))
1123 (:result-types positive-fixnum)
1126 (make-ea :byte :base object
1127 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1128 other-pointer-lowtag)))))
1130 (define-vop (data-vector-set/simple-array-unsigned-byte-8)
1131 (:translate data-vector-set)
1132 (:policy :fast-safe)
1133 (:args (object :scs (descriptor-reg) :to (:eval 0))
1134 (index :scs (unsigned-reg) :to (:eval 0))
1135 (value :scs (unsigned-reg signed-reg) :target eax))
1136 (:arg-types simple-array-unsigned-byte-8 positive-fixnum positive-fixnum)
1137 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1138 :from (:argument 2) :to (:result 0))
1140 (:results (result :scs (unsigned-reg signed-reg)))
1141 (:result-types positive-fixnum)
1144 (inst mov (make-ea :byte :base object :index index :scale 1
1145 :disp (- (* vector-data-offset n-word-bytes)
1146 other-pointer-lowtag))
1150 (define-vop (data-vector-set-c/simple-array-unsigned-byte-8)
1151 (:translate data-vector-set)
1152 (:policy :fast-safe)
1153 (:args (object :scs (descriptor-reg) :to (:eval 0))
1154 (value :scs (unsigned-reg signed-reg) :target eax))
1156 (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30))
1158 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1159 :from (:argument 1) :to (:result 0))
1161 (:results (result :scs (unsigned-reg signed-reg)))
1162 (:result-types positive-fixnum)
1165 (inst mov (make-ea :byte :base object
1166 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1167 other-pointer-lowtag))
1171 ;;; unsigned-byte-16
1173 (define-vop (data-vector-ref/simple-array-unsigned-byte-16)
1174 (:translate data-vector-ref)
1175 (:policy :fast-safe)
1176 (:args (object :scs (descriptor-reg))
1177 (index :scs (unsigned-reg)))
1178 (:arg-types simple-array-unsigned-byte-16 positive-fixnum)
1179 (:results (value :scs (unsigned-reg signed-reg)))
1180 (:result-types positive-fixnum)
1183 (make-ea :word :base object :index index :scale 2
1184 :disp (- (* vector-data-offset n-word-bytes)
1185 other-pointer-lowtag)))))
1187 (define-vop (data-vector-ref-c/simple-array-unsigned-byte-16)
1188 (:translate data-vector-ref)
1189 (:policy :fast-safe)
1190 (:args (object :scs (descriptor-reg)))
1192 (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30)))
1193 (:results (value :scs (unsigned-reg signed-reg)))
1194 (:result-types positive-fixnum)
1197 (make-ea :word :base object
1198 :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
1199 other-pointer-lowtag)))))
1201 (define-vop (data-vector-set/simple-array-unsigned-byte-16)
1202 (:translate data-vector-set)
1203 (:policy :fast-safe)
1204 (:args (object :scs (descriptor-reg) :to (:eval 0))
1205 (index :scs (unsigned-reg) :to (:eval 0))
1206 (value :scs (unsigned-reg signed-reg) :target eax))
1207 (:arg-types simple-array-unsigned-byte-16 positive-fixnum positive-fixnum)
1208 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1209 :from (:argument 2) :to (:result 0))
1211 (:results (result :scs (unsigned-reg signed-reg)))
1212 (:result-types positive-fixnum)
1215 (inst mov (make-ea :word :base object :index index :scale 2
1216 :disp (- (* vector-data-offset n-word-bytes)
1217 other-pointer-lowtag))
1221 (define-vop (data-vector-set-c/simple-array-unsigned-byte-16)
1222 (:translate data-vector-set)
1223 (:policy :fast-safe)
1224 (:args (object :scs (descriptor-reg) :to (:eval 0))
1225 (value :scs (unsigned-reg signed-reg) :target eax))
1227 (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30))
1229 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1230 :from (:argument 1) :to (:result 0))
1232 (:results (result :scs (unsigned-reg signed-reg)))
1233 (:result-types positive-fixnum)
1236 (inst mov (make-ea :word :base object
1237 :disp (- (+ (* vector-data-offset n-word-bytes)
1239 other-pointer-lowtag))
1245 (define-vop (data-vector-ref/simple-string)
1246 (:translate data-vector-ref)
1247 (:policy :fast-safe)
1248 (:args (object :scs (descriptor-reg))
1249 (index :scs (unsigned-reg)))
1250 (:arg-types simple-string positive-fixnum)
1251 (:temporary (:sc unsigned-reg ; byte-reg
1252 :offset eax-offset ; al-offset
1254 :from (:eval 0) :to (:result 0))
1257 (:results (value :scs (base-char-reg)))
1258 (:result-types base-char)
1261 (make-ea :byte :base object :index index :scale 1
1262 :disp (- (* vector-data-offset n-word-bytes)
1263 other-pointer-lowtag)))
1264 (move value al-tn)))
1266 (define-vop (data-vector-ref-c/simple-string)
1267 (:translate data-vector-ref)
1268 (:policy :fast-safe)
1269 (:args (object :scs (descriptor-reg)))
1271 (:arg-types simple-string (:constant (signed-byte 30)))
1272 (:temporary (:sc unsigned-reg :offset eax-offset :target value
1273 :from (:eval 0) :to (:result 0))
1276 (:results (value :scs (base-char-reg)))
1277 (:result-types base-char)
1280 (make-ea :byte :base object
1281 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1282 other-pointer-lowtag)))
1283 (move value al-tn)))
1285 (define-vop (data-vector-set/simple-string)
1286 (:translate data-vector-set)
1287 (:policy :fast-safe)
1288 (:args (object :scs (descriptor-reg) :to (:eval 0))
1289 (index :scs (unsigned-reg) :to (:eval 0))
1290 (value :scs (base-char-reg)))
1291 (:arg-types simple-string positive-fixnum base-char)
1292 (:results (result :scs (base-char-reg)))
1293 (:result-types base-char)
1295 (inst mov (make-ea :byte :base object :index index :scale 1
1296 :disp (- (* vector-data-offset n-word-bytes)
1297 other-pointer-lowtag))
1299 (move result value)))
1301 (define-vop (data-vector-set/simple-string-c)
1302 (:translate data-vector-set)
1303 (:policy :fast-safe)
1304 (:args (object :scs (descriptor-reg) :to (:eval 0))
1305 (value :scs (base-char-reg)))
1307 (:arg-types simple-string (:constant (signed-byte 30)) base-char)
1308 (:results (result :scs (base-char-reg)))
1309 (:result-types base-char)
1311 (inst mov (make-ea :byte :base object
1312 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1313 other-pointer-lowtag))
1315 (move result value)))
1319 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1320 (:translate data-vector-ref)
1321 (:policy :fast-safe)
1322 (:args (object :scs (descriptor-reg))
1323 (index :scs (unsigned-reg)))
1324 (:arg-types simple-array-signed-byte-8 positive-fixnum)
1325 (:results (value :scs (signed-reg)))
1326 (:result-types tagged-num)
1329 (make-ea :byte :base object :index index :scale 1
1330 :disp (- (* vector-data-offset n-word-bytes)
1331 other-pointer-lowtag)))))
1333 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1334 (:translate data-vector-ref)
1335 (:policy :fast-safe)
1336 (:args (object :scs (descriptor-reg)))
1338 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1339 (:results (value :scs (signed-reg)))
1340 (:result-types tagged-num)
1343 (make-ea :byte :base object
1344 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1345 other-pointer-lowtag)))))
1347 (define-vop (data-vector-set/simple-array-signed-byte-8)
1348 (:translate data-vector-set)
1349 (:policy :fast-safe)
1350 (:args (object :scs (descriptor-reg) :to (:eval 0))
1351 (index :scs (unsigned-reg) :to (:eval 0))
1352 (value :scs (signed-reg) :target eax))
1353 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1354 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1355 :from (:argument 2) :to (:result 0))
1357 (:results (result :scs (signed-reg)))
1358 (:result-types tagged-num)
1361 (inst mov (make-ea :byte :base object :index index :scale 1
1362 :disp (- (* vector-data-offset n-word-bytes)
1363 other-pointer-lowtag))
1367 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1368 (:translate data-vector-set)
1369 (:policy :fast-safe)
1370 (:args (object :scs (descriptor-reg) :to (:eval 0))
1371 (value :scs (signed-reg) :target eax))
1373 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1375 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1376 :from (:argument 1) :to (:result 0))
1378 (:results (result :scs (signed-reg)))
1379 (:result-types tagged-num)
1382 (inst mov (make-ea :byte :base object
1383 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1384 other-pointer-lowtag))
1390 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1391 (:translate data-vector-ref)
1392 (:policy :fast-safe)
1393 (:args (object :scs (descriptor-reg))
1394 (index :scs (unsigned-reg)))
1395 (:arg-types simple-array-signed-byte-16 positive-fixnum)
1396 (:results (value :scs (signed-reg)))
1397 (:result-types tagged-num)
1400 (make-ea :word :base object :index index :scale 2
1401 :disp (- (* vector-data-offset n-word-bytes)
1402 other-pointer-lowtag)))))
1404 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1405 (:translate data-vector-ref)
1406 (:policy :fast-safe)
1407 (:args (object :scs (descriptor-reg)))
1409 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1410 (:results (value :scs (signed-reg)))
1411 (:result-types tagged-num)
1414 (make-ea :word :base object
1415 :disp (- (+ (* vector-data-offset n-word-bytes)
1417 other-pointer-lowtag)))))
1419 (define-vop (data-vector-set/simple-array-signed-byte-16)
1420 (:translate data-vector-set)
1421 (:policy :fast-safe)
1422 (:args (object :scs (descriptor-reg) :to (:eval 0))
1423 (index :scs (unsigned-reg) :to (:eval 0))
1424 (value :scs (signed-reg) :target eax))
1425 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1426 (:temporary (:sc signed-reg :offset eax-offset :target result
1427 :from (:argument 2) :to (:result 0))
1429 (:results (result :scs (signed-reg)))
1430 (:result-types tagged-num)
1433 (inst mov (make-ea :word :base object :index index :scale 2
1434 :disp (- (* vector-data-offset n-word-bytes)
1435 other-pointer-lowtag))
1439 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1440 (:translate data-vector-set)
1441 (:policy :fast-safe)
1442 (:args (object :scs (descriptor-reg) :to (:eval 0))
1443 (value :scs (signed-reg) :target eax))
1445 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1446 (:temporary (:sc signed-reg :offset eax-offset :target result
1447 :from (:argument 1) :to (:result 0))
1449 (:results (result :scs (signed-reg)))
1450 (:result-types tagged-num)
1454 (make-ea :word :base object
1455 :disp (- (+ (* vector-data-offset n-word-bytes)
1457 other-pointer-lowtag))
1461 ;;; These VOPs are used for implementing float slots in structures (whose raw
1462 ;;; data is an unsigned-32 vector).
1463 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
1464 (:translate %raw-ref-single)
1465 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1466 (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
1467 (:translate %raw-ref-single)
1468 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1469 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
1470 (:translate %raw-set-single)
1471 (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
1472 (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
1473 (:translate %raw-set-single)
1474 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1476 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
1477 (:translate %raw-ref-double)
1478 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1479 (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
1480 (:translate %raw-ref-double)
1481 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1482 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
1483 (:translate %raw-set-double)
1484 (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
1485 (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
1486 (:translate %raw-set-double)
1487 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1490 (define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
1491 (:translate %raw-ref-long)
1492 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1494 (define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
1495 (:translate %raw-ref-long)
1496 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1498 (define-vop (raw-set-double data-vector-set/simple-array-long-float)
1499 (:translate %raw-set-long)
1500 (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float))
1502 (define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
1503 (:translate %raw-set-long)
1504 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1507 ;;;; complex-float raw structure slot accessors
1509 (define-vop (raw-ref-complex-single
1510 data-vector-ref/simple-array-complex-single-float)
1511 (:translate %raw-ref-complex-single)
1512 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1513 (define-vop (raw-ref-complex-single-c
1514 data-vector-ref-c/simple-array-complex-single-float)
1515 (:translate %raw-ref-complex-single)
1516 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1517 (define-vop (raw-set-complex-single
1518 data-vector-set/simple-array-complex-single-float)
1519 (:translate %raw-set-complex-single)
1520 (:arg-types simple-array-unsigned-byte-32 positive-fixnum complex-single-float))
1521 (define-vop (raw-set-complex-single-c
1522 data-vector-set-c/simple-array-complex-single-float)
1523 (:translate %raw-set-complex-single)
1524 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1525 complex-single-float))
1526 (define-vop (raw-ref-complex-double
1527 data-vector-ref/simple-array-complex-double-float)
1528 (:translate %raw-ref-complex-double)
1529 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1530 (define-vop (raw-ref-complex-double-c
1531 data-vector-ref-c/simple-array-complex-double-float)
1532 (:translate %raw-ref-complex-double)
1533 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1534 (define-vop (raw-set-complex-double
1535 data-vector-set/simple-array-complex-double-float)
1536 (:translate %raw-set-complex-double)
1537 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
1538 complex-double-float))
1539 (define-vop (raw-set-complex-double-c
1540 data-vector-set-c/simple-array-complex-double-float)
1541 (:translate %raw-set-complex-double)
1542 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1543 complex-double-float))
1545 (define-vop (raw-ref-complex-long
1546 data-vector-ref/simple-array-complex-long-float)
1547 (:translate %raw-ref-complex-long)
1548 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1550 (define-vop (raw-ref-complex-long-c
1551 data-vector-ref-c/simple-array-complex-long-float)
1552 (:translate %raw-ref-complex-long)
1553 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1555 (define-vop (raw-set-complex-long
1556 data-vector-set/simple-array-complex-long-float)
1557 (:translate %raw-set-complex-long)
1558 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
1559 complex-long-float))
1561 (define-vop (raw-set-complex-long-c
1562 data-vector-set-c/simple-array-complex-long-float)
1563 (:translate %raw-set-complex-long)
1564 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1565 complex-long-float))
1567 ;;; These vops are useful for accessing the bits of a vector
1568 ;;; irrespective of what type of vector it is.
1569 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1570 unsigned-num %raw-bits)
1571 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1572 unsigned-num %set-raw-bits)
1574 ;;;; miscellaneous array VOPs
1576 (define-vop (get-vector-subtype get-header-data))
1577 (define-vop (set-vector-subtype set-header-data))