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)
274 (inst ror old shift))
275 (inst and old (lognot ,(1- (ash 1 bits))))
277 (unless (zerop shift)
278 (inst rol old shift)))))
279 (inst mov (make-ea :dword :base object
280 :disp (- (* (+ word vector-data-offset)
282 other-pointer-lowtag))
286 (inst mov result (tn-value value)))
288 (move result value))))))))))
289 (def-small-data-vector-frobs simple-bit-vector 1)
290 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
291 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
293 ;;; And the float variants.
295 (define-vop (data-vector-ref/simple-array-single-float)
296 (:note "inline array access")
297 (:translate data-vector-ref)
299 (:args (object :scs (descriptor-reg))
300 (index :scs (any-reg)))
301 (:arg-types simple-array-single-float positive-fixnum)
302 (:results (value :scs (single-reg)))
303 (:result-types single-float)
305 (with-empty-tn@fp-top(value)
306 (inst fld (make-ea :dword :base object :index index :scale 1
307 :disp (- (* sb!vm:vector-data-offset
309 sb!vm:other-pointer-lowtag))))))
311 (define-vop (data-vector-ref-c/simple-array-single-float)
312 (:note "inline array access")
313 (:translate data-vector-ref)
315 (:args (object :scs (descriptor-reg)))
317 (:arg-types simple-array-single-float (:constant (signed-byte 30)))
318 (:results (value :scs (single-reg)))
319 (:result-types single-float)
321 (with-empty-tn@fp-top(value)
322 (inst fld (make-ea :dword :base object
323 :disp (- (+ (* sb!vm:vector-data-offset
326 sb!vm:other-pointer-lowtag))))))
328 (define-vop (data-vector-set/simple-array-single-float)
329 (:note "inline array store")
330 (:translate data-vector-set)
332 (:args (object :scs (descriptor-reg))
333 (index :scs (any-reg))
334 (value :scs (single-reg) :target result))
335 (:arg-types simple-array-single-float positive-fixnum single-float)
336 (:results (result :scs (single-reg)))
337 (:result-types single-float)
339 (cond ((zerop (tn-offset value))
341 (inst fst (make-ea :dword :base object :index index :scale 1
342 :disp (- (* sb!vm:vector-data-offset
344 sb!vm:other-pointer-lowtag)))
345 (unless (zerop (tn-offset result))
346 ;; Value is in ST0 but not result.
349 ;; Value is not in ST0.
351 (inst fst (make-ea :dword :base object :index index :scale 1
352 :disp (- (* sb!vm:vector-data-offset
354 sb!vm:other-pointer-lowtag)))
355 (cond ((zerop (tn-offset result))
356 ;; The result is in ST0.
359 ;; Neither value or result are in ST0
360 (unless (location= value result)
362 (inst fxch value)))))))
364 (define-vop (data-vector-set-c/simple-array-single-float)
365 (:note "inline array store")
366 (:translate data-vector-set)
368 (:args (object :scs (descriptor-reg))
369 (value :scs (single-reg) :target result))
371 (:arg-types simple-array-single-float (:constant (signed-byte 30))
373 (:results (result :scs (single-reg)))
374 (:result-types single-float)
376 (cond ((zerop (tn-offset value))
378 (inst fst (make-ea :dword :base object
379 :disp (- (+ (* sb!vm:vector-data-offset
382 sb!vm:other-pointer-lowtag)))
383 (unless (zerop (tn-offset result))
384 ;; Value is in ST0 but not result.
387 ;; Value is not in ST0.
389 (inst fst (make-ea :dword :base object
390 :disp (- (+ (* sb!vm:vector-data-offset
393 sb!vm:other-pointer-lowtag)))
394 (cond ((zerop (tn-offset result))
395 ;; The result is in ST0.
398 ;; Neither value or result are in ST0
399 (unless (location= value result)
401 (inst fxch value)))))))
403 (define-vop (data-vector-ref/simple-array-double-float)
404 (:note "inline array access")
405 (:translate data-vector-ref)
407 (:args (object :scs (descriptor-reg))
408 (index :scs (any-reg)))
409 (:arg-types simple-array-double-float positive-fixnum)
410 (:results (value :scs (double-reg)))
411 (:result-types double-float)
413 (with-empty-tn@fp-top(value)
414 (inst fldd (make-ea :dword :base object :index index :scale 2
415 :disp (- (* sb!vm:vector-data-offset
417 sb!vm:other-pointer-lowtag))))))
419 (define-vop (data-vector-ref-c/simple-array-double-float)
420 (:note "inline array access")
421 (:translate data-vector-ref)
423 (:args (object :scs (descriptor-reg)))
425 (:arg-types simple-array-double-float (:constant (signed-byte 30)))
426 (:results (value :scs (double-reg)))
427 (:result-types double-float)
429 (with-empty-tn@fp-top(value)
430 (inst fldd (make-ea :dword :base object
431 :disp (- (+ (* sb!vm:vector-data-offset
434 sb!vm:other-pointer-lowtag))))))
436 (define-vop (data-vector-set/simple-array-double-float)
437 (:note "inline array store")
438 (:translate data-vector-set)
440 (:args (object :scs (descriptor-reg))
441 (index :scs (any-reg))
442 (value :scs (double-reg) :target result))
443 (:arg-types simple-array-double-float positive-fixnum double-float)
444 (:results (result :scs (double-reg)))
445 (:result-types double-float)
447 (cond ((zerop (tn-offset value))
449 (inst fstd (make-ea :dword :base object :index index :scale 2
450 :disp (- (* sb!vm:vector-data-offset
452 sb!vm:other-pointer-lowtag)))
453 (unless (zerop (tn-offset result))
454 ;; Value is in ST0 but not result.
457 ;; Value is not in ST0.
459 (inst fstd (make-ea :dword :base object :index index :scale 2
460 :disp (- (* sb!vm:vector-data-offset
462 sb!vm:other-pointer-lowtag)))
463 (cond ((zerop (tn-offset result))
464 ;; The result is in ST0.
467 ;; Neither value or result are in ST0
468 (unless (location= value result)
470 (inst fxch value)))))))
472 (define-vop (data-vector-set-c/simple-array-double-float)
473 (:note "inline array store")
474 (:translate data-vector-set)
476 (:args (object :scs (descriptor-reg))
477 (value :scs (double-reg) :target result))
479 (:arg-types simple-array-double-float (:constant (signed-byte 30))
481 (:results (result :scs (double-reg)))
482 (:result-types double-float)
484 (cond ((zerop (tn-offset value))
486 (inst fstd (make-ea :dword :base object
487 :disp (- (+ (* sb!vm:vector-data-offset
490 sb!vm:other-pointer-lowtag)))
491 (unless (zerop (tn-offset result))
492 ;; Value is in ST0 but not result.
495 ;; Value is not in ST0.
497 (inst fstd (make-ea :dword :base object
498 :disp (- (+ (* sb!vm:vector-data-offset
501 sb!vm:other-pointer-lowtag)))
502 (cond ((zerop (tn-offset result))
503 ;; The result is in ST0.
506 ;; Neither value or result are in ST0
507 (unless (location= value result)
509 (inst fxch value)))))))
512 (define-vop (data-vector-ref/simple-array-long-float)
513 (:note "inline array access")
514 (:translate data-vector-ref)
516 (:args (object :scs (descriptor-reg) :to :result)
517 (index :scs (any-reg)))
518 (:arg-types simple-array-long-float positive-fixnum)
519 (:temporary (:sc any-reg :from :eval :to :result) temp)
520 (:results (value :scs (long-reg)))
521 (:result-types long-float)
524 (inst lea temp (make-ea :dword :base index :index index :scale 2))
525 (with-empty-tn@fp-top(value)
526 (inst fldl (make-ea :dword :base object :index temp :scale 1
527 :disp (- (* sb!vm:vector-data-offset
529 sb!vm:other-pointer-lowtag))))))
532 (define-vop (data-vector-ref-c/simple-array-long-float)
533 (:note "inline array access")
534 (:translate data-vector-ref)
536 (:args (object :scs (descriptor-reg)))
538 (:arg-types simple-array-long-float (:constant (signed-byte 30)))
539 (:results (value :scs (long-reg)))
540 (:result-types long-float)
542 (with-empty-tn@fp-top(value)
543 (inst fldl (make-ea :dword :base object
544 :disp (- (+ (* sb!vm:vector-data-offset
547 sb!vm:other-pointer-lowtag))))))
550 (define-vop (data-vector-set/simple-array-long-float)
551 (:note "inline array store")
552 (:translate data-vector-set)
554 (:args (object :scs (descriptor-reg) :to :result)
555 (index :scs (any-reg))
556 (value :scs (long-reg) :target result))
557 (:arg-types simple-array-long-float positive-fixnum long-float)
558 (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
559 (:results (result :scs (long-reg)))
560 (:result-types long-float)
563 (inst lea temp (make-ea :dword :base index :index index :scale 2))
564 (cond ((zerop (tn-offset value))
567 (make-ea :dword :base object :index temp :scale 1
568 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
569 sb!vm:other-pointer-lowtag)))
570 (unless (zerop (tn-offset result))
571 ;; Value is in ST0 but not result.
574 ;; Value is not in ST0.
577 (make-ea :dword :base object :index temp :scale 1
578 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
579 sb!vm:other-pointer-lowtag)))
580 (cond ((zerop (tn-offset result))
581 ;; The result is in ST0.
584 ;; Neither value or result are in ST0
585 (unless (location= value result)
587 (inst fxch value)))))))
590 (define-vop (data-vector-set-c/simple-array-long-float)
591 (:note "inline array store")
592 (:translate data-vector-set)
594 (:args (object :scs (descriptor-reg))
595 (value :scs (long-reg) :target result))
597 (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
598 (:results (result :scs (long-reg)))
599 (:result-types long-float)
601 (cond ((zerop (tn-offset value))
603 (store-long-float (make-ea :dword :base object
604 :disp (- (+ (* sb!vm:vector-data-offset
607 sb!vm:other-pointer-lowtag)))
608 (unless (zerop (tn-offset result))
609 ;; Value is in ST0 but not result.
612 ;; Value is not in ST0.
614 (store-long-float (make-ea :dword :base object
615 :disp (- (+ (* sb!vm:vector-data-offset
618 sb!vm:other-pointer-lowtag)))
619 (cond ((zerop (tn-offset result))
620 ;; The result is in ST0.
623 ;; Neither value or result are in ST0
624 (unless (location= value result)
626 (inst fxch value)))))))
628 ;;; complex float variants
630 (define-vop (data-vector-ref/simple-array-complex-single-float)
631 (:note "inline array access")
632 (:translate data-vector-ref)
634 (:args (object :scs (descriptor-reg))
635 (index :scs (any-reg)))
636 (:arg-types simple-array-complex-single-float positive-fixnum)
637 (:results (value :scs (complex-single-reg)))
638 (:result-types complex-single-float)
640 (let ((real-tn (complex-single-reg-real-tn value)))
641 (with-empty-tn@fp-top (real-tn)
642 (inst fld (make-ea :dword :base object :index index :scale 2
643 :disp (- (* sb!vm:vector-data-offset
645 sb!vm:other-pointer-lowtag)))))
646 (let ((imag-tn (complex-single-reg-imag-tn value)))
647 (with-empty-tn@fp-top (imag-tn)
648 (inst fld (make-ea :dword :base object :index index :scale 2
649 :disp (- (* (1+ sb!vm:vector-data-offset)
651 sb!vm:other-pointer-lowtag)))))))
653 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
654 (:note "inline array access")
655 (:translate data-vector-ref)
657 (:args (object :scs (descriptor-reg)))
659 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
660 (:results (value :scs (complex-single-reg)))
661 (:result-types complex-single-float)
663 (let ((real-tn (complex-single-reg-real-tn value)))
664 (with-empty-tn@fp-top (real-tn)
665 (inst fld (make-ea :dword :base object
666 :disp (- (+ (* sb!vm:vector-data-offset
669 sb!vm:other-pointer-lowtag)))))
670 (let ((imag-tn (complex-single-reg-imag-tn value)))
671 (with-empty-tn@fp-top (imag-tn)
672 (inst fld (make-ea :dword :base object
673 :disp (- (+ (* sb!vm:vector-data-offset
676 sb!vm:other-pointer-lowtag)))))))
678 (define-vop (data-vector-set/simple-array-complex-single-float)
679 (:note "inline array store")
680 (:translate data-vector-set)
682 (:args (object :scs (descriptor-reg))
683 (index :scs (any-reg))
684 (value :scs (complex-single-reg) :target result))
685 (:arg-types simple-array-complex-single-float positive-fixnum
686 complex-single-float)
687 (:results (result :scs (complex-single-reg)))
688 (:result-types complex-single-float)
690 (let ((value-real (complex-single-reg-real-tn value))
691 (result-real (complex-single-reg-real-tn result)))
692 (cond ((zerop (tn-offset value-real))
694 (inst fst (make-ea :dword :base object :index index :scale 2
695 :disp (- (* sb!vm:vector-data-offset
697 sb!vm:other-pointer-lowtag)))
698 (unless (zerop (tn-offset result-real))
699 ;; Value is in ST0 but not result.
700 (inst fst result-real)))
702 ;; Value is not in ST0.
703 (inst fxch value-real)
704 (inst fst (make-ea :dword :base object :index index :scale 2
705 :disp (- (* sb!vm:vector-data-offset
707 sb!vm:other-pointer-lowtag)))
708 (cond ((zerop (tn-offset result-real))
709 ;; The result is in ST0.
710 (inst fst value-real))
712 ;; Neither value or result are in ST0
713 (unless (location= value-real result-real)
714 (inst fst result-real))
715 (inst fxch value-real))))))
716 (let ((value-imag (complex-single-reg-imag-tn value))
717 (result-imag (complex-single-reg-imag-tn result)))
718 (inst fxch value-imag)
719 (inst fst (make-ea :dword :base object :index index :scale 2
720 :disp (- (+ (* sb!vm:vector-data-offset
723 sb!vm:other-pointer-lowtag)))
724 (unless (location= value-imag result-imag)
725 (inst fst result-imag))
726 (inst fxch value-imag))))
728 (define-vop (data-vector-set-c/simple-array-complex-single-float)
729 (:note "inline array store")
730 (:translate data-vector-set)
732 (:args (object :scs (descriptor-reg))
733 (value :scs (complex-single-reg) :target result))
735 (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
736 complex-single-float)
737 (:results (result :scs (complex-single-reg)))
738 (:result-types complex-single-float)
740 (let ((value-real (complex-single-reg-real-tn value))
741 (result-real (complex-single-reg-real-tn result)))
742 (cond ((zerop (tn-offset value-real))
744 (inst fst (make-ea :dword :base object
745 :disp (- (+ (* sb!vm:vector-data-offset
748 sb!vm:other-pointer-lowtag)))
749 (unless (zerop (tn-offset result-real))
750 ;; Value is in ST0 but not result.
751 (inst fst result-real)))
753 ;; Value is not in ST0.
754 (inst fxch value-real)
755 (inst fst (make-ea :dword :base object
756 :disp (- (+ (* sb!vm:vector-data-offset
759 sb!vm:other-pointer-lowtag)))
760 (cond ((zerop (tn-offset result-real))
761 ;; The result is in ST0.
762 (inst fst value-real))
764 ;; Neither value or result are in ST0
765 (unless (location= value-real result-real)
766 (inst fst result-real))
767 (inst fxch value-real))))))
768 (let ((value-imag (complex-single-reg-imag-tn value))
769 (result-imag (complex-single-reg-imag-tn result)))
770 (inst fxch value-imag)
771 (inst fst (make-ea :dword :base object
772 :disp (- (+ (* sb!vm:vector-data-offset
775 sb!vm:other-pointer-lowtag)))
776 (unless (location= value-imag result-imag)
777 (inst fst result-imag))
778 (inst fxch value-imag))))
781 (define-vop (data-vector-ref/simple-array-complex-double-float)
782 (:note "inline array access")
783 (:translate data-vector-ref)
785 (:args (object :scs (descriptor-reg))
786 (index :scs (any-reg)))
787 (:arg-types simple-array-complex-double-float positive-fixnum)
788 (:results (value :scs (complex-double-reg)))
789 (:result-types complex-double-float)
791 (let ((real-tn (complex-double-reg-real-tn value)))
792 (with-empty-tn@fp-top (real-tn)
793 (inst fldd (make-ea :dword :base object :index index :scale 4
794 :disp (- (* sb!vm:vector-data-offset
796 sb!vm:other-pointer-lowtag)))))
797 (let ((imag-tn (complex-double-reg-imag-tn value)))
798 (with-empty-tn@fp-top (imag-tn)
799 (inst fldd (make-ea :dword :base object :index index :scale 4
800 :disp (- (+ (* sb!vm:vector-data-offset
803 sb!vm:other-pointer-lowtag)))))))
805 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
806 (:note "inline array access")
807 (:translate data-vector-ref)
809 (:args (object :scs (descriptor-reg)))
811 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
812 (:results (value :scs (complex-double-reg)))
813 (:result-types complex-double-float)
815 (let ((real-tn (complex-double-reg-real-tn value)))
816 (with-empty-tn@fp-top (real-tn)
817 (inst fldd (make-ea :dword :base object
818 :disp (- (+ (* sb!vm:vector-data-offset
821 sb!vm:other-pointer-lowtag)))))
822 (let ((imag-tn (complex-double-reg-imag-tn value)))
823 (with-empty-tn@fp-top (imag-tn)
824 (inst fldd (make-ea :dword :base object
825 :disp (- (+ (* sb!vm:vector-data-offset
828 sb!vm:other-pointer-lowtag)))))))
830 (define-vop (data-vector-set/simple-array-complex-double-float)
831 (:note "inline array store")
832 (:translate data-vector-set)
834 (:args (object :scs (descriptor-reg))
835 (index :scs (any-reg))
836 (value :scs (complex-double-reg) :target result))
837 (:arg-types simple-array-complex-double-float positive-fixnum
838 complex-double-float)
839 (:results (result :scs (complex-double-reg)))
840 (:result-types complex-double-float)
842 (let ((value-real (complex-double-reg-real-tn value))
843 (result-real (complex-double-reg-real-tn result)))
844 (cond ((zerop (tn-offset value-real))
846 (inst fstd (make-ea :dword :base object :index index :scale 4
847 :disp (- (* sb!vm:vector-data-offset
849 sb!vm:other-pointer-lowtag)))
850 (unless (zerop (tn-offset result-real))
851 ;; Value is in ST0 but not result.
852 (inst fstd result-real)))
854 ;; Value is not in ST0.
855 (inst fxch value-real)
856 (inst fstd (make-ea :dword :base object :index index :scale 4
857 :disp (- (* sb!vm:vector-data-offset
859 sb!vm:other-pointer-lowtag)))
860 (cond ((zerop (tn-offset result-real))
861 ;; The result is in ST0.
862 (inst fstd value-real))
864 ;; Neither value or result are in ST0
865 (unless (location= value-real result-real)
866 (inst fstd result-real))
867 (inst fxch value-real))))))
868 (let ((value-imag (complex-double-reg-imag-tn value))
869 (result-imag (complex-double-reg-imag-tn result)))
870 (inst fxch value-imag)
871 (inst fstd (make-ea :dword :base object :index index :scale 4
872 :disp (- (+ (* sb!vm:vector-data-offset
875 sb!vm:other-pointer-lowtag)))
876 (unless (location= value-imag result-imag)
877 (inst fstd result-imag))
878 (inst fxch value-imag))))
880 (define-vop (data-vector-set-c/simple-array-complex-double-float)
881 (:note "inline array store")
882 (:translate data-vector-set)
884 (:args (object :scs (descriptor-reg))
885 (value :scs (complex-double-reg) :target result))
887 (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
888 complex-double-float)
889 (:results (result :scs (complex-double-reg)))
890 (:result-types complex-double-float)
892 (let ((value-real (complex-double-reg-real-tn value))
893 (result-real (complex-double-reg-real-tn result)))
894 (cond ((zerop (tn-offset value-real))
896 (inst fstd (make-ea :dword :base object
897 :disp (- (+ (* sb!vm:vector-data-offset
900 sb!vm:other-pointer-lowtag)))
901 (unless (zerop (tn-offset result-real))
902 ;; Value is in ST0 but not result.
903 (inst fstd result-real)))
905 ;; Value is not in ST0.
906 (inst fxch value-real)
907 (inst fstd (make-ea :dword :base object
908 :disp (- (+ (* sb!vm:vector-data-offset
911 sb!vm:other-pointer-lowtag)))
912 (cond ((zerop (tn-offset result-real))
913 ;; The result is in ST0.
914 (inst fstd value-real))
916 ;; Neither value or result are in ST0
917 (unless (location= value-real result-real)
918 (inst fstd result-real))
919 (inst fxch value-real))))))
920 (let ((value-imag (complex-double-reg-imag-tn value))
921 (result-imag (complex-double-reg-imag-tn result)))
922 (inst fxch value-imag)
923 (inst fstd (make-ea :dword :base object
924 :disp (- (+ (* sb!vm:vector-data-offset
927 sb!vm:other-pointer-lowtag)))
928 (unless (location= value-imag result-imag)
929 (inst fstd result-imag))
930 (inst fxch value-imag))))
934 (define-vop (data-vector-ref/simple-array-complex-long-float)
935 (:note "inline array access")
936 (:translate data-vector-ref)
938 (:args (object :scs (descriptor-reg) :to :result)
939 (index :scs (any-reg)))
940 (:arg-types simple-array-complex-long-float positive-fixnum)
941 (:temporary (:sc any-reg :from :eval :to :result) temp)
942 (:results (value :scs (complex-long-reg)))
943 (:result-types complex-long-float)
946 (inst lea temp (make-ea :dword :base index :index index :scale 2))
947 (let ((real-tn (complex-long-reg-real-tn value)))
948 (with-empty-tn@fp-top (real-tn)
949 (inst fldl (make-ea :dword :base object :index temp :scale 2
950 :disp (- (* sb!vm:vector-data-offset
952 sb!vm:other-pointer-lowtag)))))
953 (let ((imag-tn (complex-long-reg-imag-tn value)))
954 (with-empty-tn@fp-top (imag-tn)
955 (inst fldl (make-ea :dword :base object :index temp :scale 2
956 :disp (- (+ (* sb!vm:vector-data-offset
959 sb!vm:other-pointer-lowtag)))))))
962 (define-vop (data-vector-ref-c/simple-array-complex-long-float)
963 (:note "inline array access")
964 (:translate data-vector-ref)
966 (:args (object :scs (descriptor-reg)))
968 (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
969 (:results (value :scs (complex-long-reg)))
970 (:result-types complex-long-float)
972 (let ((real-tn (complex-long-reg-real-tn value)))
973 (with-empty-tn@fp-top (real-tn)
974 (inst fldl (make-ea :dword :base object
975 :disp (- (+ (* sb!vm:vector-data-offset
978 sb!vm:other-pointer-lowtag)))))
979 (let ((imag-tn (complex-long-reg-imag-tn value)))
980 (with-empty-tn@fp-top (imag-tn)
981 (inst fldl (make-ea :dword :base object
982 :disp (- (+ (* sb!vm:vector-data-offset
985 sb!vm:other-pointer-lowtag)))))))
988 (define-vop (data-vector-set/simple-array-complex-long-float)
989 (:note "inline array store")
990 (:translate data-vector-set)
992 (:args (object :scs (descriptor-reg) :to :result)
993 (index :scs (any-reg))
994 (value :scs (complex-long-reg) :target result))
995 (:arg-types simple-array-complex-long-float positive-fixnum
997 (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
998 (:results (result :scs (complex-long-reg)))
999 (:result-types complex-long-float)
1002 (inst lea temp (make-ea :dword :base index :index index :scale 2))
1003 (let ((value-real (complex-long-reg-real-tn value))
1004 (result-real (complex-long-reg-real-tn result)))
1005 (cond ((zerop (tn-offset value-real))
1008 (make-ea :dword :base object :index temp :scale 2
1009 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
1010 sb!vm:other-pointer-lowtag)))
1011 (unless (zerop (tn-offset result-real))
1012 ;; Value is in ST0 but not result.
1013 (inst fstd result-real)))
1015 ;; Value is not in ST0.
1016 (inst fxch value-real)
1018 (make-ea :dword :base object :index temp :scale 2
1019 :disp (- (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
1020 sb!vm:other-pointer-lowtag)))
1021 (cond ((zerop (tn-offset result-real))
1022 ;; The result is in ST0.
1023 (inst fstd value-real))
1025 ;; Neither value or result are in ST0
1026 (unless (location= value-real result-real)
1027 (inst fstd result-real))
1028 (inst fxch value-real))))))
1029 (let ((value-imag (complex-long-reg-imag-tn value))
1030 (result-imag (complex-long-reg-imag-tn result)))
1031 (inst fxch value-imag)
1033 (make-ea :dword :base object :index temp :scale 2
1034 :disp (- (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes) 12)
1035 sb!vm:other-pointer-lowtag)))
1036 (unless (location= value-imag result-imag)
1037 (inst fstd result-imag))
1038 (inst fxch value-imag))))
1041 (define-vop (data-vector-set-c/simple-array-complex-long-float)
1042 (:note "inline array store")
1043 (:translate data-vector-set)
1044 (:policy :fast-safe)
1045 (:args (object :scs (descriptor-reg))
1046 (value :scs (complex-long-reg) :target result))
1048 (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
1050 (:results (result :scs (complex-long-reg)))
1051 (:result-types complex-long-float)
1053 (let ((value-real (complex-long-reg-real-tn value))
1054 (result-real (complex-long-reg-real-tn result)))
1055 (cond ((zerop (tn-offset value-real))
1058 (make-ea :dword :base object
1059 :disp (- (+ (* sb!vm:vector-data-offset
1062 sb!vm:other-pointer-lowtag)))
1063 (unless (zerop (tn-offset result-real))
1064 ;; Value is in ST0 but not result.
1065 (inst fstd result-real)))
1067 ;; Value is not in ST0.
1068 (inst fxch value-real)
1070 (make-ea :dword :base object
1071 :disp (- (+ (* sb!vm:vector-data-offset
1074 sb!vm:other-pointer-lowtag)))
1075 (cond ((zerop (tn-offset result-real))
1076 ;; The result is in ST0.
1077 (inst fstd value-real))
1079 ;; Neither value or result are in ST0
1080 (unless (location= value-real result-real)
1081 (inst fstd result-real))
1082 (inst fxch value-real))))))
1083 (let ((value-imag (complex-long-reg-imag-tn value))
1084 (result-imag (complex-long-reg-imag-tn result)))
1085 (inst fxch value-imag)
1087 (make-ea :dword :base object
1088 :disp (- (+ (* sb!vm:vector-data-offset
1090 ;; FIXME: There are so many of these bare constants
1091 ;; (24, 12..) in the LONG-FLOAT code that it's
1092 ;; ridiculous. I should probably just delete it all
1093 ;; instead of appearing to flirt with supporting
1094 ;; this maintenance nightmare.
1096 sb!vm:other-pointer-lowtag)))
1097 (unless (location= value-imag result-imag)
1098 (inst fstd result-imag))
1099 (inst fxch value-imag))))
1103 (define-vop (data-vector-ref/simple-array-unsigned-byte-8)
1104 (:translate data-vector-ref)
1105 (:policy :fast-safe)
1106 (:args (object :scs (descriptor-reg))
1107 (index :scs (unsigned-reg)))
1108 (:arg-types simple-array-unsigned-byte-8 positive-fixnum)
1109 (:results (value :scs (unsigned-reg signed-reg)))
1110 (:result-types positive-fixnum)
1113 (make-ea :byte :base object :index index :scale 1
1114 :disp (- (* vector-data-offset n-word-bytes)
1115 other-pointer-lowtag)))))
1117 (define-vop (data-vector-ref-c/simple-array-unsigned-byte-8)
1118 (:translate data-vector-ref)
1119 (:policy :fast-safe)
1120 (:args (object :scs (descriptor-reg)))
1122 (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)))
1123 (:results (value :scs (unsigned-reg signed-reg)))
1124 (:result-types positive-fixnum)
1127 (make-ea :byte :base object
1128 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1129 other-pointer-lowtag)))))
1131 (define-vop (data-vector-set/simple-array-unsigned-byte-8)
1132 (:translate data-vector-set)
1133 (:policy :fast-safe)
1134 (:args (object :scs (descriptor-reg) :to (:eval 0))
1135 (index :scs (unsigned-reg) :to (:eval 0))
1136 (value :scs (unsigned-reg signed-reg) :target eax))
1137 (:arg-types simple-array-unsigned-byte-8 positive-fixnum positive-fixnum)
1138 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1139 :from (:argument 2) :to (:result 0))
1141 (:results (result :scs (unsigned-reg signed-reg)))
1142 (:result-types positive-fixnum)
1145 (inst mov (make-ea :byte :base object :index index :scale 1
1146 :disp (- (* vector-data-offset n-word-bytes)
1147 other-pointer-lowtag))
1151 (define-vop (data-vector-set-c/simple-array-unsigned-byte-8)
1152 (:translate data-vector-set)
1153 (:policy :fast-safe)
1154 (:args (object :scs (descriptor-reg) :to (:eval 0))
1155 (value :scs (unsigned-reg signed-reg) :target eax))
1157 (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30))
1159 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1160 :from (:argument 1) :to (:result 0))
1162 (:results (result :scs (unsigned-reg signed-reg)))
1163 (:result-types positive-fixnum)
1166 (inst mov (make-ea :byte :base object
1167 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1168 other-pointer-lowtag))
1172 ;;; unsigned-byte-16
1174 (define-vop (data-vector-ref/simple-array-unsigned-byte-16)
1175 (:translate data-vector-ref)
1176 (:policy :fast-safe)
1177 (:args (object :scs (descriptor-reg))
1178 (index :scs (unsigned-reg)))
1179 (:arg-types simple-array-unsigned-byte-16 positive-fixnum)
1180 (:results (value :scs (unsigned-reg signed-reg)))
1181 (:result-types positive-fixnum)
1184 (make-ea :word :base object :index index :scale 2
1185 :disp (- (* vector-data-offset n-word-bytes)
1186 other-pointer-lowtag)))))
1188 (define-vop (data-vector-ref-c/simple-array-unsigned-byte-16)
1189 (:translate data-vector-ref)
1190 (:policy :fast-safe)
1191 (:args (object :scs (descriptor-reg)))
1193 (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30)))
1194 (:results (value :scs (unsigned-reg signed-reg)))
1195 (:result-types positive-fixnum)
1198 (make-ea :word :base object
1199 :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
1200 other-pointer-lowtag)))))
1202 (define-vop (data-vector-set/simple-array-unsigned-byte-16)
1203 (:translate data-vector-set)
1204 (:policy :fast-safe)
1205 (:args (object :scs (descriptor-reg) :to (:eval 0))
1206 (index :scs (unsigned-reg) :to (:eval 0))
1207 (value :scs (unsigned-reg signed-reg) :target eax))
1208 (:arg-types simple-array-unsigned-byte-16 positive-fixnum positive-fixnum)
1209 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1210 :from (:argument 2) :to (:result 0))
1212 (:results (result :scs (unsigned-reg signed-reg)))
1213 (:result-types positive-fixnum)
1216 (inst mov (make-ea :word :base object :index index :scale 2
1217 :disp (- (* vector-data-offset n-word-bytes)
1218 other-pointer-lowtag))
1222 (define-vop (data-vector-set-c/simple-array-unsigned-byte-16)
1223 (:translate data-vector-set)
1224 (:policy :fast-safe)
1225 (:args (object :scs (descriptor-reg) :to (:eval 0))
1226 (value :scs (unsigned-reg signed-reg) :target eax))
1228 (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30))
1230 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1231 :from (:argument 1) :to (:result 0))
1233 (:results (result :scs (unsigned-reg signed-reg)))
1234 (:result-types positive-fixnum)
1237 (inst mov (make-ea :word :base object
1238 :disp (- (+ (* vector-data-offset n-word-bytes)
1240 other-pointer-lowtag))
1246 (define-vop (data-vector-ref/simple-base-string)
1247 (:translate data-vector-ref)
1248 (:policy :fast-safe)
1249 (:args (object :scs (descriptor-reg))
1250 (index :scs (unsigned-reg)))
1251 (:arg-types simple-base-string positive-fixnum)
1252 (:temporary (:sc unsigned-reg ; byte-reg
1253 :offset eax-offset ; al-offset
1255 :from (:eval 0) :to (:result 0))
1258 (:results (value :scs (base-char-reg)))
1259 (:result-types base-char)
1262 (make-ea :byte :base object :index index :scale 1
1263 :disp (- (* vector-data-offset n-word-bytes)
1264 other-pointer-lowtag)))
1265 (move value al-tn)))
1267 (define-vop (data-vector-ref-c/simple-base-string)
1268 (:translate data-vector-ref)
1269 (:policy :fast-safe)
1270 (:args (object :scs (descriptor-reg)))
1272 (:arg-types simple-base-string (:constant (signed-byte 30)))
1273 (:temporary (:sc unsigned-reg :offset eax-offset :target value
1274 :from (:eval 0) :to (:result 0))
1277 (:results (value :scs (base-char-reg)))
1278 (:result-types base-char)
1281 (make-ea :byte :base object
1282 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1283 other-pointer-lowtag)))
1284 (move value al-tn)))
1286 (define-vop (data-vector-set/simple-base-string)
1287 (:translate data-vector-set)
1288 (:policy :fast-safe)
1289 (:args (object :scs (descriptor-reg) :to (:eval 0))
1290 (index :scs (unsigned-reg) :to (:eval 0))
1291 (value :scs (base-char-reg)))
1292 (:arg-types simple-base-string positive-fixnum base-char)
1293 (:results (result :scs (base-char-reg)))
1294 (:result-types base-char)
1296 (inst mov (make-ea :byte :base object :index index :scale 1
1297 :disp (- (* vector-data-offset n-word-bytes)
1298 other-pointer-lowtag))
1300 (move result value)))
1302 (define-vop (data-vector-set/simple-base-string-c)
1303 (:translate data-vector-set)
1304 (:policy :fast-safe)
1305 (:args (object :scs (descriptor-reg) :to (:eval 0))
1306 (value :scs (base-char-reg)))
1308 (:arg-types simple-base-string (:constant (signed-byte 30)) base-char)
1309 (:results (result :scs (base-char-reg)))
1310 (:result-types base-char)
1312 (inst mov (make-ea :byte :base object
1313 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1314 other-pointer-lowtag))
1316 (move result value)))
1320 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1321 (:translate data-vector-ref)
1322 (:policy :fast-safe)
1323 (:args (object :scs (descriptor-reg))
1324 (index :scs (unsigned-reg)))
1325 (:arg-types simple-array-signed-byte-8 positive-fixnum)
1326 (:results (value :scs (signed-reg)))
1327 (:result-types tagged-num)
1330 (make-ea :byte :base object :index index :scale 1
1331 :disp (- (* vector-data-offset n-word-bytes)
1332 other-pointer-lowtag)))))
1334 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1335 (:translate data-vector-ref)
1336 (:policy :fast-safe)
1337 (:args (object :scs (descriptor-reg)))
1339 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1340 (:results (value :scs (signed-reg)))
1341 (:result-types tagged-num)
1344 (make-ea :byte :base object
1345 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1346 other-pointer-lowtag)))))
1348 (define-vop (data-vector-set/simple-array-signed-byte-8)
1349 (:translate data-vector-set)
1350 (:policy :fast-safe)
1351 (:args (object :scs (descriptor-reg) :to (:eval 0))
1352 (index :scs (unsigned-reg) :to (:eval 0))
1353 (value :scs (signed-reg) :target eax))
1354 (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1355 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1356 :from (:argument 2) :to (:result 0))
1358 (:results (result :scs (signed-reg)))
1359 (:result-types tagged-num)
1362 (inst mov (make-ea :byte :base object :index index :scale 1
1363 :disp (- (* vector-data-offset n-word-bytes)
1364 other-pointer-lowtag))
1368 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1369 (:translate data-vector-set)
1370 (:policy :fast-safe)
1371 (:args (object :scs (descriptor-reg) :to (:eval 0))
1372 (value :scs (signed-reg) :target eax))
1374 (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1376 (:temporary (:sc unsigned-reg :offset eax-offset :target result
1377 :from (:argument 1) :to (:result 0))
1379 (:results (result :scs (signed-reg)))
1380 (:result-types tagged-num)
1383 (inst mov (make-ea :byte :base object
1384 :disp (- (+ (* vector-data-offset n-word-bytes) index)
1385 other-pointer-lowtag))
1391 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1392 (:translate data-vector-ref)
1393 (:policy :fast-safe)
1394 (:args (object :scs (descriptor-reg))
1395 (index :scs (unsigned-reg)))
1396 (:arg-types simple-array-signed-byte-16 positive-fixnum)
1397 (:results (value :scs (signed-reg)))
1398 (:result-types tagged-num)
1401 (make-ea :word :base object :index index :scale 2
1402 :disp (- (* vector-data-offset n-word-bytes)
1403 other-pointer-lowtag)))))
1405 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1406 (:translate data-vector-ref)
1407 (:policy :fast-safe)
1408 (:args (object :scs (descriptor-reg)))
1410 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1411 (:results (value :scs (signed-reg)))
1412 (:result-types tagged-num)
1415 (make-ea :word :base object
1416 :disp (- (+ (* vector-data-offset n-word-bytes)
1418 other-pointer-lowtag)))))
1420 (define-vop (data-vector-set/simple-array-signed-byte-16)
1421 (:translate data-vector-set)
1422 (:policy :fast-safe)
1423 (:args (object :scs (descriptor-reg) :to (:eval 0))
1424 (index :scs (unsigned-reg) :to (:eval 0))
1425 (value :scs (signed-reg) :target eax))
1426 (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1427 (:temporary (:sc signed-reg :offset eax-offset :target result
1428 :from (:argument 2) :to (:result 0))
1430 (:results (result :scs (signed-reg)))
1431 (:result-types tagged-num)
1434 (inst mov (make-ea :word :base object :index index :scale 2
1435 :disp (- (* vector-data-offset n-word-bytes)
1436 other-pointer-lowtag))
1440 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1441 (:translate data-vector-set)
1442 (:policy :fast-safe)
1443 (:args (object :scs (descriptor-reg) :to (:eval 0))
1444 (value :scs (signed-reg) :target eax))
1446 (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1447 (:temporary (:sc signed-reg :offset eax-offset :target result
1448 :from (:argument 1) :to (:result 0))
1450 (:results (result :scs (signed-reg)))
1451 (:result-types tagged-num)
1455 (make-ea :word :base object
1456 :disp (- (+ (* vector-data-offset n-word-bytes)
1458 other-pointer-lowtag))
1462 ;;; These VOPs are used for implementing float slots in structures (whose raw
1463 ;;; data is an unsigned-32 vector).
1464 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
1465 (:translate %raw-ref-single)
1466 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1467 (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
1468 (:translate %raw-ref-single)
1469 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1470 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
1471 (:translate %raw-set-single)
1472 (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
1473 (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
1474 (:translate %raw-set-single)
1475 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1477 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
1478 (:translate %raw-ref-double)
1479 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1480 (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
1481 (:translate %raw-ref-double)
1482 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1483 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
1484 (:translate %raw-set-double)
1485 (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
1486 (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
1487 (:translate %raw-set-double)
1488 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1491 (define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
1492 (:translate %raw-ref-long)
1493 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1495 (define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
1496 (:translate %raw-ref-long)
1497 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1499 (define-vop (raw-set-double data-vector-set/simple-array-long-float)
1500 (:translate %raw-set-long)
1501 (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float))
1503 (define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
1504 (:translate %raw-set-long)
1505 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1508 ;;;; complex-float raw structure slot accessors
1510 (define-vop (raw-ref-complex-single
1511 data-vector-ref/simple-array-complex-single-float)
1512 (:translate %raw-ref-complex-single)
1513 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1514 (define-vop (raw-ref-complex-single-c
1515 data-vector-ref-c/simple-array-complex-single-float)
1516 (:translate %raw-ref-complex-single)
1517 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1518 (define-vop (raw-set-complex-single
1519 data-vector-set/simple-array-complex-single-float)
1520 (:translate %raw-set-complex-single)
1521 (:arg-types simple-array-unsigned-byte-32 positive-fixnum complex-single-float))
1522 (define-vop (raw-set-complex-single-c
1523 data-vector-set-c/simple-array-complex-single-float)
1524 (:translate %raw-set-complex-single)
1525 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1526 complex-single-float))
1527 (define-vop (raw-ref-complex-double
1528 data-vector-ref/simple-array-complex-double-float)
1529 (:translate %raw-ref-complex-double)
1530 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1531 (define-vop (raw-ref-complex-double-c
1532 data-vector-ref-c/simple-array-complex-double-float)
1533 (:translate %raw-ref-complex-double)
1534 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1535 (define-vop (raw-set-complex-double
1536 data-vector-set/simple-array-complex-double-float)
1537 (:translate %raw-set-complex-double)
1538 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
1539 complex-double-float))
1540 (define-vop (raw-set-complex-double-c
1541 data-vector-set-c/simple-array-complex-double-float)
1542 (:translate %raw-set-complex-double)
1543 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1544 complex-double-float))
1546 (define-vop (raw-ref-complex-long
1547 data-vector-ref/simple-array-complex-long-float)
1548 (:translate %raw-ref-complex-long)
1549 (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1551 (define-vop (raw-ref-complex-long-c
1552 data-vector-ref-c/simple-array-complex-long-float)
1553 (:translate %raw-ref-complex-long)
1554 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1556 (define-vop (raw-set-complex-long
1557 data-vector-set/simple-array-complex-long-float)
1558 (:translate %raw-set-complex-long)
1559 (:arg-types simple-array-unsigned-byte-32 positive-fixnum
1560 complex-long-float))
1562 (define-vop (raw-set-complex-long-c
1563 data-vector-set-c/simple-array-complex-long-float)
1564 (:translate %raw-set-complex-long)
1565 (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1566 complex-long-float))
1568 ;;; These vops are useful for accessing the bits of a vector
1569 ;;; irrespective of what type of vector it is.
1570 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1571 unsigned-num %raw-bits)
1572 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1573 unsigned-num %set-raw-bits)
1575 ;;;; miscellaneous array VOPs
1577 (define-vop (get-vector-subtype get-header-data))
1578 (define-vop (set-vector-subtype set-header-data))