1.0.0.32: support for FreeBSD/x86-64
[sbcl.git] / src / compiler / x86 / array.lisp
1 ;;;; array operations for the x86 VM
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; allocator for the array header
15
16 (define-vop (make-array-header)
17   (:translate make-array-header)
18   (:policy :fast-safe)
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))
25   (:node-var node)
26   (:generator 13
27     (inst lea bytes
28           (make-ea :dword :base rank
29                    :disp (+ (* (1+ array-dimensions-offset) n-word-bytes)
30                             lowtag-mask)))
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)
35     (inst or  header type)
36     (inst shr header 2)
37     (pseudo-atomic
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))))
41 \f
42 ;;;; additional accessors and setters for the array header
43 (define-full-reffer %array-dimension *
44   array-dimensions-offset other-pointer-lowtag
45   (any-reg) positive-fixnum sb!kernel:%array-dimension)
46
47 (define-full-setter %set-array-dimension *
48   array-dimensions-offset other-pointer-lowtag
49   (any-reg) positive-fixnum sb!kernel:%set-array-dimension)
50
51 (define-vop (array-rank-vop)
52   (:translate sb!kernel:%array-rank)
53   (:policy :fast-safe)
54   (:args (x :scs (descriptor-reg)))
55   (:results (res :scs (unsigned-reg)))
56   (:result-types positive-fixnum)
57   (:generator 6
58     (loadw res x 0 other-pointer-lowtag)
59     (inst shr res n-widetag-bits)
60     (inst sub res (1- array-dimensions-offset))))
61 \f
62 ;;;; bounds checking routine
63
64 ;;; Note that the immediate SC for the index argument is disabled
65 ;;; because it is not possible to generate a valid error code SC for
66 ;;; an immediate value.
67 ;;;
68 ;;; FIXME: As per the KLUDGE note explaining the :IGNORE-FAILURE-P
69 ;;; flag in build-order.lisp-expr, compiling this file causes warnings
70 ;;;    Argument FOO to VOP CHECK-BOUND has SC restriction
71 ;;;    DESCRIPTOR-REG which is not allowed by the operand type:
72 ;;;      (:OR POSITIVE-FIXNUM)
73 ;;; CSR's message "format ~/ /" on sbcl-devel 2002-03-12 contained
74 ;;; a possible patch, described as
75 ;;;   Another patch is included more for information than anything --
76 ;;;   removing the descriptor-reg SCs from the CHECK-BOUND vop in
77 ;;;   x86/array.lisp seems to allow that file to compile without error[*],
78 ;;;   and build; I haven't tested rebuilding capability, but I'd be
79 ;;;   surprised if there were a problem.  I'm not certain that this is the
80 ;;;   correct fix, though, as the restrictions on the arguments to the VOP
81 ;;;   aren't the same as in the sparc and alpha ports, where, incidentally,
82 ;;;   the corresponding file builds without error currently.
83 ;;; Since neither of us (CSR or WHN) was quite sure that this is the
84 ;;; right thing, I've just recorded the patch here in hopes it might
85 ;;; help when someone attacks this problem again:
86 ;;;   diff -u -r1.7 array.lisp
87 ;;;   --- src/compiler/x86/array.lisp 11 Oct 2001 14:05:26 -0000      1.7
88 ;;;   +++ src/compiler/x86/array.lisp 12 Mar 2002 12:23:37 -0000
89 ;;;   @@ -76,10 +76,10 @@
90 ;;;      (:translate %check-bound)
91 ;;;      (:policy :fast-safe)
92 ;;;      (:args (array :scs (descriptor-reg))
93 ;;;   -        (bound :scs (any-reg descriptor-reg))
94 ;;;   -        (index :scs (any-reg descriptor-reg #+nil immediate) :target result))
95 ;;;   +        (bound :scs (any-reg))
96 ;;;   +        (index :scs (any-reg #+nil immediate) :target result))
97 ;;;      (:arg-types * positive-fixnum tagged-num)
98 ;;;   -  (:results (result :scs (any-reg descriptor-reg)))
99 ;;;   +  (:results (result :scs (any-reg)))
100 ;;;      (:result-types positive-fixnum)
101 ;;;      (:vop-var vop)
102 ;;;      (:save-p :compute-only)
103 (define-vop (check-bound)
104   (:translate %check-bound)
105   (:policy :fast-safe)
106   (:args (array :scs (descriptor-reg))
107          (bound :scs (any-reg))
108          (index :scs (any-reg #+nil immediate) :target result))
109   (:arg-types * positive-fixnum tagged-num)
110   (:results (result :scs (any-reg)))
111   (:result-types positive-fixnum)
112   (:vop-var vop)
113   (:save-p :compute-only)
114   (:generator 5
115     (let ((error (generate-error-code vop invalid-array-index-error
116                                       array bound index))
117           (index (if (sc-is index immediate)
118                    (fixnumize (tn-value index))
119                    index)))
120       (inst cmp bound index)
121       ;; We use below-or-equal even though it's an unsigned test,
122       ;; because negative indexes appear as large unsigned numbers.
123       ;; Therefore, we get the <0 and >=bound test all rolled into one.
124       (inst jmp :be error)
125       (unless (and (tn-p index) (location= result index))
126         (inst mov result index)))))
127 \f
128 ;;;; accessors/setters
129
130 ;;; variants built on top of WORD-INDEX-REF, etc. I.e., those vectors
131 ;;; whose elements are represented in integer registers and are built
132 ;;; out of 8, 16, or 32 bit elements.
133 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
134              `(progn
135                 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
136                   ,type vector-data-offset other-pointer-lowtag ,scs
137                   ,element-type data-vector-ref)
138                 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
139                   ,type vector-data-offset other-pointer-lowtag ,scs
140                   ,element-type data-vector-set))))
141   (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
142   (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
143     unsigned-reg)
144   (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
145   (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg)
146   (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
147     signed-reg)
148   (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
149     unsigned-reg))
150 \f
151 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
152 ;;;; bit, 2-bit, and 4-bit vectors
153
154 (macrolet ((def-small-data-vector-frobs (type bits)
155              (let* ((elements-per-word (floor n-word-bits bits))
156                     (bit-shift (1- (integer-length elements-per-word))))
157     `(progn
158        (define-vop (,(symbolicate 'data-vector-ref/ type))
159          (:note "inline array access")
160          (:translate data-vector-ref)
161          (:policy :fast-safe)
162          (:args (object :scs (descriptor-reg))
163                 (index :scs (unsigned-reg)))
164          (:arg-types ,type positive-fixnum)
165          (:results (result :scs (unsigned-reg) :from (:argument 0)))
166          (:result-types positive-fixnum)
167          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
168          (:generator 20
169            (move ecx index)
170            (inst shr ecx ,bit-shift)
171            (inst mov result
172                  (make-ea :dword :base object :index ecx :scale 4
173                           :disp (- (* vector-data-offset n-word-bytes)
174                                    other-pointer-lowtag)))
175            (move ecx index)
176            ;; We used to mask ECX for all values of ELEMENT-PER-WORD,
177            ;; but since Intel's documentation says that the chip will
178            ;; mask shift and rotate counts by 31 automatically, we can
179            ;; safely move the masking operation under the protection of
180            ;; this UNLESS in the bit-vector case.  --njf, 2006-07-14
181            ,@(unless (= elements-per-word n-word-bits)
182                `((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)
188          (:policy :fast-safe)
189          (:args (object :scs (descriptor-reg)))
190          (:arg-types ,type (:constant index))
191          (:info index)
192          (:results (result :scs (unsigned-reg)))
193          (:result-types positive-fixnum)
194          (:generator 15
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)
205          (:policy :fast-safe)
206          (:args (object :scs (descriptor-reg))
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) old)
214          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
215          (:generator 25
216            (move word-index index)
217            (inst shr word-index ,bit-shift)
218            (inst mov old
219                  (make-ea :dword :base object :index word-index :scale 4
220                           :disp (- (* vector-data-offset n-word-bytes)
221                                    other-pointer-lowtag)))
222            (move ecx index)
223            ;; We used to mask ECX for all values of ELEMENT-PER-WORD,
224            ;; but since Intel's documentation says that the chip will
225            ;; mask shift and rotate counts by 31 automatically, we can
226            ;; safely move the masking operation under the protection of
227            ;; this UNLESS in the bit-vector case.  --njf, 2006-07-14
228            ,@(unless (= elements-per-word n-word-bits)
229                `((inst and ecx ,(1- elements-per-word))
230                  (inst shl ecx ,(1- (integer-length bits)))))
231            (inst ror old :cl)
232            (unless (and (sc-is value immediate)
233                         (= (tn-value value) ,(1- (ash 1 bits))))
234              (inst and old ,(lognot (1- (ash 1 bits)))))
235            (sc-case value
236              (immediate
237               (unless (zerop (tn-value value))
238                 (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
239              (unsigned-reg
240               (inst or old value)))
241            (inst rol old :cl)
242            (inst mov (make-ea :dword :base object :index word-index :scale 4
243                               :disp (- (* vector-data-offset n-word-bytes)
244                                        other-pointer-lowtag))
245                  old)
246            (sc-case value
247              (immediate
248               (inst mov result (tn-value value)))
249              (unsigned-reg
250               (move result value)))))
251        (define-vop (,(symbolicate 'data-vector-set-c/ type))
252          (:translate data-vector-set)
253          (:policy :fast-safe)
254          (:args (object :scs (descriptor-reg))
255                 (value :scs (unsigned-reg immediate) :target result))
256          (:arg-types ,type (:constant index) positive-fixnum)
257          (:info index)
258          (:results (result :scs (unsigned-reg)))
259          (:result-types positive-fixnum)
260          (:temporary (:sc unsigned-reg :to (:result 0)) old)
261          (:generator 20
262            (multiple-value-bind (word extra) (floor index ,elements-per-word)
263              (inst mov old
264                    (make-ea :dword :base object
265                             :disp (- (* (+ word vector-data-offset)
266                                         n-word-bytes)
267                                      other-pointer-lowtag)))
268              (sc-case value
269                (immediate
270                 (let* ((value (tn-value value))
271                        (mask ,(1- (ash 1 bits)))
272                        (shift (* extra ,bits)))
273                   (unless (= value mask)
274                     (inst and old (ldb (byte n-word-bits 0)
275                                        (lognot (ash mask shift)))))
276                   (unless (zerop value)
277                     (inst or old (ash value shift)))))
278                (unsigned-reg
279                 (let ((shift (* extra ,bits)))
280                   (unless (zerop shift)
281                     (inst ror old shift))
282                   (inst and old (lognot ,(1- (ash 1 bits))))
283                   (inst or old value)
284                   (unless (zerop shift)
285                     (inst rol old shift)))))
286              (inst mov (make-ea :dword :base object
287                                 :disp (- (* (+ word vector-data-offset)
288                                             n-word-bytes)
289                                          other-pointer-lowtag))
290                    old)
291              (sc-case value
292                (immediate
293                 (inst mov result (tn-value value)))
294                (unsigned-reg
295                 (move result value))))))))))
296   (def-small-data-vector-frobs simple-bit-vector 1)
297   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
298   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
299
300 ;;; And the float variants.
301
302 (define-vop (data-vector-ref/simple-array-single-float)
303   (:note "inline array access")
304   (:translate data-vector-ref)
305   (:policy :fast-safe)
306   (:args (object :scs (descriptor-reg))
307          (index :scs (any-reg)))
308   (:arg-types simple-array-single-float positive-fixnum)
309   (:results (value :scs (single-reg)))
310   (:result-types single-float)
311   (:generator 5
312    (with-empty-tn@fp-top(value)
313      (inst fld (make-ea :dword :base object :index index :scale 1
314                         :disp (- (* vector-data-offset
315                                     n-word-bytes)
316                                  other-pointer-lowtag))))))
317
318 (define-vop (data-vector-ref-c/simple-array-single-float)
319   (:note "inline array access")
320   (:translate data-vector-ref)
321   (:policy :fast-safe)
322   (:args (object :scs (descriptor-reg)))
323   (:info index)
324   (:arg-types simple-array-single-float (:constant (signed-byte 30)))
325   (:results (value :scs (single-reg)))
326   (:result-types single-float)
327   (:generator 4
328    (with-empty-tn@fp-top(value)
329      (inst fld (make-ea :dword :base object
330                         :disp (- (+ (* vector-data-offset
331                                        n-word-bytes)
332                                     (* 4 index))
333                                  other-pointer-lowtag))))))
334
335 (define-vop (data-vector-set/simple-array-single-float)
336   (:note "inline array store")
337   (:translate data-vector-set)
338   (:policy :fast-safe)
339   (:args (object :scs (descriptor-reg))
340          (index :scs (any-reg))
341          (value :scs (single-reg) :target result))
342   (:arg-types simple-array-single-float positive-fixnum single-float)
343   (:results (result :scs (single-reg)))
344   (:result-types single-float)
345   (:generator 5
346     (cond ((zerop (tn-offset value))
347            ;; Value is in ST0.
348            (inst fst (make-ea :dword :base object :index index :scale 1
349                               :disp (- (* vector-data-offset
350                                           n-word-bytes)
351                                        other-pointer-lowtag)))
352            (unless (zerop (tn-offset result))
353                    ;; Value is in ST0 but not result.
354                    (inst fst result)))
355           (t
356            ;; Value is not in ST0.
357            (inst fxch value)
358            (inst fst (make-ea :dword :base object :index index :scale 1
359                               :disp (- (* vector-data-offset
360                                           n-word-bytes)
361                                        other-pointer-lowtag)))
362            (cond ((zerop (tn-offset result))
363                   ;; The result is in ST0.
364                   (inst fst value))
365                  (t
366                   ;; Neither value or result are in ST0
367                   (unless (location= value result)
368                           (inst fst result))
369                   (inst fxch value)))))))
370
371 (define-vop (data-vector-set-c/simple-array-single-float)
372   (:note "inline array store")
373   (:translate data-vector-set)
374   (:policy :fast-safe)
375   (:args (object :scs (descriptor-reg))
376          (value :scs (single-reg) :target result))
377   (:info index)
378   (:arg-types simple-array-single-float (:constant (signed-byte 30))
379               single-float)
380   (:results (result :scs (single-reg)))
381   (:result-types single-float)
382   (:generator 4
383     (cond ((zerop (tn-offset value))
384            ;; Value is in ST0.
385            (inst fst (make-ea :dword :base object
386                               :disp (- (+ (* vector-data-offset
387                                              n-word-bytes)
388                                           (* 4 index))
389                                        other-pointer-lowtag)))
390            (unless (zerop (tn-offset result))
391                    ;; Value is in ST0 but not result.
392                    (inst fst result)))
393           (t
394            ;; Value is not in ST0.
395            (inst fxch value)
396            (inst fst (make-ea :dword :base object
397                               :disp (- (+ (* vector-data-offset
398                                              n-word-bytes)
399                                           (* 4 index))
400                                        other-pointer-lowtag)))
401            (cond ((zerop (tn-offset result))
402                   ;; The result is in ST0.
403                   (inst fst value))
404                  (t
405                   ;; Neither value or result are in ST0
406                   (unless (location= value result)
407                           (inst fst result))
408                   (inst fxch value)))))))
409
410 (define-vop (data-vector-ref/simple-array-double-float)
411   (:note "inline array access")
412   (:translate data-vector-ref)
413   (:policy :fast-safe)
414   (:args (object :scs (descriptor-reg))
415          (index :scs (any-reg)))
416   (:arg-types simple-array-double-float positive-fixnum)
417   (:results (value :scs (double-reg)))
418   (:result-types double-float)
419   (:generator 7
420    (with-empty-tn@fp-top(value)
421      (inst fldd (make-ea :dword :base object :index index :scale 2
422                          :disp (- (* vector-data-offset
423                                      n-word-bytes)
424                                   other-pointer-lowtag))))))
425
426 (define-vop (data-vector-ref-c/simple-array-double-float)
427   (:note "inline array access")
428   (:translate data-vector-ref)
429   (:policy :fast-safe)
430   (:args (object :scs (descriptor-reg)))
431   (:info index)
432   (:arg-types simple-array-double-float (:constant (signed-byte 30)))
433   (:results (value :scs (double-reg)))
434   (:result-types double-float)
435   (:generator 6
436    (with-empty-tn@fp-top(value)
437      (inst fldd (make-ea :dword :base object
438                          :disp (- (+ (* vector-data-offset
439                                         n-word-bytes)
440                                      (* 8 index))
441                                   other-pointer-lowtag))))))
442
443 (define-vop (data-vector-set/simple-array-double-float)
444   (:note "inline array store")
445   (:translate data-vector-set)
446   (:policy :fast-safe)
447   (:args (object :scs (descriptor-reg))
448          (index :scs (any-reg))
449          (value :scs (double-reg) :target result))
450   (:arg-types simple-array-double-float positive-fixnum double-float)
451   (:results (result :scs (double-reg)))
452   (:result-types double-float)
453   (:generator 20
454     (cond ((zerop (tn-offset value))
455            ;; Value is in ST0.
456            (inst fstd (make-ea :dword :base object :index index :scale 2
457                                :disp (- (* vector-data-offset
458                                            n-word-bytes)
459                                         other-pointer-lowtag)))
460            (unless (zerop (tn-offset result))
461                    ;; Value is in ST0 but not result.
462                    (inst fstd result)))
463           (t
464            ;; Value is not in ST0.
465            (inst fxch value)
466            (inst fstd (make-ea :dword :base object :index index :scale 2
467                                :disp (- (* vector-data-offset
468                                            n-word-bytes)
469                                         other-pointer-lowtag)))
470            (cond ((zerop (tn-offset result))
471                   ;; The result is in ST0.
472                   (inst fstd value))
473                  (t
474                   ;; Neither value or result are in ST0
475                   (unless (location= value result)
476                           (inst fstd result))
477                   (inst fxch value)))))))
478
479 (define-vop (data-vector-set-c/simple-array-double-float)
480   (:note "inline array store")
481   (:translate data-vector-set)
482   (:policy :fast-safe)
483   (:args (object :scs (descriptor-reg))
484          (value :scs (double-reg) :target result))
485   (:info index)
486   (:arg-types simple-array-double-float (:constant (signed-byte 30))
487               double-float)
488   (:results (result :scs (double-reg)))
489   (:result-types double-float)
490   (:generator 19
491     (cond ((zerop (tn-offset value))
492            ;; Value is in ST0.
493            (inst fstd (make-ea :dword :base object
494                                :disp (- (+ (* vector-data-offset
495                                               n-word-bytes)
496                                            (* 8 index))
497                                         other-pointer-lowtag)))
498            (unless (zerop (tn-offset result))
499                    ;; Value is in ST0 but not result.
500                    (inst fstd result)))
501           (t
502            ;; Value is not in ST0.
503            (inst fxch value)
504            (inst fstd (make-ea :dword :base object
505                                :disp (- (+ (* vector-data-offset
506                                               n-word-bytes)
507                                            (* 8 index))
508                                         other-pointer-lowtag)))
509            (cond ((zerop (tn-offset result))
510                   ;; The result is in ST0.
511                   (inst fstd value))
512                  (t
513                   ;; Neither value or result are in ST0
514                   (unless (location= value result)
515                           (inst fstd result))
516                   (inst fxch value)))))))
517
518
519
520 ;;; complex float variants
521
522 (define-vop (data-vector-ref/simple-array-complex-single-float)
523   (:note "inline array access")
524   (:translate data-vector-ref)
525   (:policy :fast-safe)
526   (:args (object :scs (descriptor-reg))
527          (index :scs (any-reg)))
528   (:arg-types simple-array-complex-single-float positive-fixnum)
529   (:results (value :scs (complex-single-reg)))
530   (:result-types complex-single-float)
531   (:generator 5
532     (let ((real-tn (complex-single-reg-real-tn value)))
533       (with-empty-tn@fp-top (real-tn)
534         (inst fld (make-ea :dword :base object :index index :scale 2
535                            :disp (- (* vector-data-offset
536                                        n-word-bytes)
537                                     other-pointer-lowtag)))))
538     (let ((imag-tn (complex-single-reg-imag-tn value)))
539       (with-empty-tn@fp-top (imag-tn)
540         (inst fld (make-ea :dword :base object :index index :scale 2
541                            :disp (- (* (1+ vector-data-offset)
542                                        n-word-bytes)
543                                     other-pointer-lowtag)))))))
544
545 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
546   (:note "inline array access")
547   (:translate data-vector-ref)
548   (:policy :fast-safe)
549   (:args (object :scs (descriptor-reg)))
550   (:info index)
551   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
552   (:results (value :scs (complex-single-reg)))
553   (:result-types complex-single-float)
554   (:generator 4
555     (let ((real-tn (complex-single-reg-real-tn value)))
556       (with-empty-tn@fp-top (real-tn)
557         (inst fld (make-ea :dword :base object
558                            :disp (- (+ (* vector-data-offset
559                                           n-word-bytes)
560                                        (* 8 index))
561                                     other-pointer-lowtag)))))
562     (let ((imag-tn (complex-single-reg-imag-tn value)))
563       (with-empty-tn@fp-top (imag-tn)
564         (inst fld (make-ea :dword :base object
565                            :disp (- (+ (* vector-data-offset
566                                           n-word-bytes)
567                                        (* 8 index) 4)
568                                     other-pointer-lowtag)))))))
569
570 (define-vop (data-vector-set/simple-array-complex-single-float)
571   (:note "inline array store")
572   (:translate data-vector-set)
573   (:policy :fast-safe)
574   (:args (object :scs (descriptor-reg))
575          (index :scs (any-reg))
576          (value :scs (complex-single-reg) :target result))
577   (:arg-types simple-array-complex-single-float positive-fixnum
578               complex-single-float)
579   (:results (result :scs (complex-single-reg)))
580   (:result-types complex-single-float)
581   (:generator 5
582     (let ((value-real (complex-single-reg-real-tn value))
583           (result-real (complex-single-reg-real-tn result)))
584       (cond ((zerop (tn-offset value-real))
585              ;; Value is in ST0.
586              (inst fst (make-ea :dword :base object :index index :scale 2
587                                 :disp (- (* vector-data-offset
588                                             n-word-bytes)
589                                          other-pointer-lowtag)))
590              (unless (zerop (tn-offset result-real))
591                ;; Value is in ST0 but not result.
592                (inst fst result-real)))
593             (t
594              ;; Value is not in ST0.
595              (inst fxch value-real)
596              (inst fst (make-ea :dword :base object :index index :scale 2
597                                 :disp (- (* vector-data-offset
598                                             n-word-bytes)
599                                          other-pointer-lowtag)))
600              (cond ((zerop (tn-offset result-real))
601                     ;; The result is in ST0.
602                     (inst fst value-real))
603                    (t
604                     ;; Neither value or result are in ST0
605                     (unless (location= value-real result-real)
606                       (inst fst result-real))
607                     (inst fxch value-real))))))
608     (let ((value-imag (complex-single-reg-imag-tn value))
609           (result-imag (complex-single-reg-imag-tn result)))
610       (inst fxch value-imag)
611       (inst fst (make-ea :dword :base object :index index :scale 2
612                          :disp (- (+ (* vector-data-offset
613                                         n-word-bytes)
614                                      4)
615                                   other-pointer-lowtag)))
616       (unless (location= value-imag result-imag)
617         (inst fst result-imag))
618       (inst fxch value-imag))))
619
620 (define-vop (data-vector-set-c/simple-array-complex-single-float)
621   (:note "inline array store")
622   (:translate data-vector-set)
623   (:policy :fast-safe)
624   (:args (object :scs (descriptor-reg))
625          (value :scs (complex-single-reg) :target result))
626   (:info index)
627   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
628               complex-single-float)
629   (:results (result :scs (complex-single-reg)))
630   (:result-types complex-single-float)
631   (:generator 4
632     (let ((value-real (complex-single-reg-real-tn value))
633           (result-real (complex-single-reg-real-tn result)))
634       (cond ((zerop (tn-offset value-real))
635              ;; Value is in ST0.
636              (inst fst (make-ea :dword :base object
637                                 :disp (- (+ (* vector-data-offset
638                                                n-word-bytes)
639                                             (* 8 index))
640                                          other-pointer-lowtag)))
641              (unless (zerop (tn-offset result-real))
642                ;; Value is in ST0 but not result.
643                (inst fst result-real)))
644             (t
645              ;; Value is not in ST0.
646              (inst fxch value-real)
647              (inst fst (make-ea :dword :base object
648                                 :disp (- (+ (* vector-data-offset
649                                                n-word-bytes)
650                                             (* 8 index))
651                                          other-pointer-lowtag)))
652              (cond ((zerop (tn-offset result-real))
653                     ;; The result is in ST0.
654                     (inst fst value-real))
655                    (t
656                     ;; Neither value or result are in ST0
657                     (unless (location= value-real result-real)
658                       (inst fst result-real))
659                     (inst fxch value-real))))))
660     (let ((value-imag (complex-single-reg-imag-tn value))
661           (result-imag (complex-single-reg-imag-tn result)))
662       (inst fxch value-imag)
663       (inst fst (make-ea :dword :base object
664                          :disp (- (+ (* vector-data-offset
665                                         n-word-bytes)
666                                      (* 8 index) 4)
667                                   other-pointer-lowtag)))
668       (unless (location= value-imag result-imag)
669         (inst fst result-imag))
670       (inst fxch value-imag))))
671
672
673 (define-vop (data-vector-ref/simple-array-complex-double-float)
674   (:note "inline array access")
675   (:translate data-vector-ref)
676   (:policy :fast-safe)
677   (:args (object :scs (descriptor-reg))
678          (index :scs (any-reg)))
679   (:arg-types simple-array-complex-double-float positive-fixnum)
680   (:results (value :scs (complex-double-reg)))
681   (:result-types complex-double-float)
682   (:generator 7
683     (let ((real-tn (complex-double-reg-real-tn value)))
684       (with-empty-tn@fp-top (real-tn)
685         (inst fldd (make-ea :dword :base object :index index :scale 4
686                             :disp (- (* vector-data-offset
687                                         n-word-bytes)
688                                      other-pointer-lowtag)))))
689     (let ((imag-tn (complex-double-reg-imag-tn value)))
690       (with-empty-tn@fp-top (imag-tn)
691         (inst fldd (make-ea :dword :base object :index index :scale 4
692                             :disp (- (+ (* vector-data-offset
693                                            n-word-bytes)
694                                         8)
695                                      other-pointer-lowtag)))))))
696
697 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
698   (:note "inline array access")
699   (:translate data-vector-ref)
700   (:policy :fast-safe)
701   (:args (object :scs (descriptor-reg)))
702   (:info index)
703   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
704   (:results (value :scs (complex-double-reg)))
705   (:result-types complex-double-float)
706   (:generator 6
707     (let ((real-tn (complex-double-reg-real-tn value)))
708       (with-empty-tn@fp-top (real-tn)
709         (inst fldd (make-ea :dword :base object
710                             :disp (- (+ (* vector-data-offset
711                                            n-word-bytes)
712                                         (* 16 index))
713                                      other-pointer-lowtag)))))
714     (let ((imag-tn (complex-double-reg-imag-tn value)))
715       (with-empty-tn@fp-top (imag-tn)
716         (inst fldd (make-ea :dword :base object
717                             :disp (- (+ (* vector-data-offset
718                                            n-word-bytes)
719                                         (* 16 index) 8)
720                                      other-pointer-lowtag)))))))
721
722 (define-vop (data-vector-set/simple-array-complex-double-float)
723   (:note "inline array store")
724   (:translate data-vector-set)
725   (:policy :fast-safe)
726   (:args (object :scs (descriptor-reg))
727          (index :scs (any-reg))
728          (value :scs (complex-double-reg) :target result))
729   (:arg-types simple-array-complex-double-float positive-fixnum
730               complex-double-float)
731   (:results (result :scs (complex-double-reg)))
732   (:result-types complex-double-float)
733   (:generator 20
734     (let ((value-real (complex-double-reg-real-tn value))
735           (result-real (complex-double-reg-real-tn result)))
736       (cond ((zerop (tn-offset value-real))
737              ;; Value is in ST0.
738              (inst fstd (make-ea :dword :base object :index index :scale 4
739                                  :disp (- (* vector-data-offset
740                                              n-word-bytes)
741                                           other-pointer-lowtag)))
742              (unless (zerop (tn-offset result-real))
743                ;; Value is in ST0 but not result.
744                (inst fstd result-real)))
745             (t
746              ;; Value is not in ST0.
747              (inst fxch value-real)
748              (inst fstd (make-ea :dword :base object :index index :scale 4
749                                  :disp (- (* vector-data-offset
750                                              n-word-bytes)
751                                           other-pointer-lowtag)))
752              (cond ((zerop (tn-offset result-real))
753                     ;; The result is in ST0.
754                     (inst fstd value-real))
755                    (t
756                     ;; Neither value or result are in ST0
757                     (unless (location= value-real result-real)
758                       (inst fstd result-real))
759                     (inst fxch value-real))))))
760     (let ((value-imag (complex-double-reg-imag-tn value))
761           (result-imag (complex-double-reg-imag-tn result)))
762       (inst fxch value-imag)
763       (inst fstd (make-ea :dword :base object :index index :scale 4
764                           :disp (- (+ (* vector-data-offset
765                                          n-word-bytes)
766                                       8)
767                                    other-pointer-lowtag)))
768       (unless (location= value-imag result-imag)
769         (inst fstd result-imag))
770       (inst fxch value-imag))))
771
772 (define-vop (data-vector-set-c/simple-array-complex-double-float)
773   (:note "inline array store")
774   (:translate data-vector-set)
775   (:policy :fast-safe)
776   (:args (object :scs (descriptor-reg))
777          (value :scs (complex-double-reg) :target result))
778   (:info index)
779   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
780               complex-double-float)
781   (:results (result :scs (complex-double-reg)))
782   (:result-types complex-double-float)
783   (:generator 19
784     (let ((value-real (complex-double-reg-real-tn value))
785           (result-real (complex-double-reg-real-tn result)))
786       (cond ((zerop (tn-offset value-real))
787              ;; Value is in ST0.
788              (inst fstd (make-ea :dword :base object
789                                  :disp (- (+ (* vector-data-offset
790                                                 n-word-bytes)
791                                              (* 16 index))
792                                           other-pointer-lowtag)))
793              (unless (zerop (tn-offset result-real))
794                ;; Value is in ST0 but not result.
795                (inst fstd result-real)))
796             (t
797              ;; Value is not in ST0.
798              (inst fxch value-real)
799              (inst fstd (make-ea :dword :base object
800                                  :disp (- (+ (* vector-data-offset
801                                                 n-word-bytes)
802                                              (* 16 index))
803                                           other-pointer-lowtag)))
804              (cond ((zerop (tn-offset result-real))
805                     ;; The result is in ST0.
806                     (inst fstd value-real))
807                    (t
808                     ;; Neither value or result are in ST0
809                     (unless (location= value-real result-real)
810                       (inst fstd result-real))
811                     (inst fxch value-real))))))
812     (let ((value-imag (complex-double-reg-imag-tn value))
813           (result-imag (complex-double-reg-imag-tn result)))
814       (inst fxch value-imag)
815       (inst fstd (make-ea :dword :base object
816                           :disp (- (+ (* vector-data-offset
817                                          n-word-bytes)
818                                       (* 16 index) 8)
819                                    other-pointer-lowtag)))
820       (unless (location= value-imag result-imag)
821         (inst fstd result-imag))
822       (inst fxch value-imag))))
823
824
825
826 \f
827 ;;; unsigned-byte-8
828 (macrolet ((define-data-vector-frobs (ptype)
829   `(progn
830     (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
831       (:translate data-vector-ref)
832       (:policy :fast-safe)
833       (:args (object :scs (descriptor-reg))
834              (index :scs (unsigned-reg)))
835       (:arg-types ,ptype positive-fixnum)
836       (:results (value :scs (unsigned-reg signed-reg)))
837       (:result-types positive-fixnum)
838       (:generator 5
839         (inst movzx value
840               (make-ea :byte :base object :index index :scale 1
841                        :disp (- (* vector-data-offset n-word-bytes)
842                                 other-pointer-lowtag)))))
843     (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
844       (:translate data-vector-ref)
845       (:policy :fast-safe)
846       (:args (object :scs (descriptor-reg)))
847       (:info index)
848       (:arg-types ,ptype (:constant (signed-byte 30)))
849       (:results (value :scs (unsigned-reg signed-reg)))
850       (:result-types positive-fixnum)
851       (:generator 4
852         (inst movzx value
853               (make-ea :byte :base object
854                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
855                                 other-pointer-lowtag)))))
856     (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
857       (:translate data-vector-set)
858       (:policy :fast-safe)
859       (:args (object :scs (descriptor-reg) :to (:eval 0))
860              (index :scs (unsigned-reg) :to (:eval 0))
861              (value :scs (unsigned-reg signed-reg) :target eax))
862       (:arg-types ,ptype positive-fixnum positive-fixnum)
863       (:temporary (:sc unsigned-reg :offset eax-offset :target result
864                        :from (:argument 2) :to (:result 0))
865                   eax)
866       (:results (result :scs (unsigned-reg signed-reg)))
867       (:result-types positive-fixnum)
868       (:generator 5
869         (move eax value)
870         (inst mov (make-ea :byte :base object :index index :scale 1
871                            :disp (- (* vector-data-offset n-word-bytes)
872                                     other-pointer-lowtag))
873               al-tn)
874         (move result eax)))
875     (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
876       (:translate data-vector-set)
877       (:policy :fast-safe)
878       (:args (object :scs (descriptor-reg) :to (:eval 0))
879              (value :scs (unsigned-reg signed-reg) :target eax))
880       (:info index)
881       (:arg-types ,ptype (:constant (signed-byte 30))
882                   positive-fixnum)
883       (:temporary (:sc unsigned-reg :offset eax-offset :target result
884                        :from (:argument 1) :to (:result 0))
885                   eax)
886       (:results (result :scs (unsigned-reg signed-reg)))
887       (:result-types positive-fixnum)
888       (:generator 4
889         (move eax value)
890         (inst mov (make-ea :byte :base object
891                            :disp (- (+ (* vector-data-offset n-word-bytes) index)
892                                     other-pointer-lowtag))
893               al-tn)
894         (move result eax))))))
895   (define-data-vector-frobs simple-array-unsigned-byte-7)
896   (define-data-vector-frobs simple-array-unsigned-byte-8))
897
898 ;;; unsigned-byte-16
899 (macrolet ((define-data-vector-frobs (ptype)
900     `(progn
901       (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
902         (:translate data-vector-ref)
903         (:policy :fast-safe)
904         (:args (object :scs (descriptor-reg))
905                (index :scs (unsigned-reg)))
906         (:arg-types ,ptype positive-fixnum)
907         (:results (value :scs (unsigned-reg signed-reg)))
908         (:result-types positive-fixnum)
909         (:generator 5
910           (inst movzx value
911                 (make-ea :word :base object :index index :scale 2
912                          :disp (- (* vector-data-offset n-word-bytes)
913                                   other-pointer-lowtag)))))
914       (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
915         (:translate data-vector-ref)
916         (:policy :fast-safe)
917         (:args (object :scs (descriptor-reg)))
918         (:info index)
919         (:arg-types ,ptype (:constant (signed-byte 30)))
920         (:results (value :scs (unsigned-reg signed-reg)))
921         (:result-types positive-fixnum)
922         (:generator 4
923           (inst movzx value
924                 (make-ea :word :base object
925                          :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
926                                   other-pointer-lowtag)))))
927       (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
928         (:translate data-vector-set)
929         (:policy :fast-safe)
930         (:args (object :scs (descriptor-reg) :to (:eval 0))
931                (index :scs (unsigned-reg) :to (:eval 0))
932                (value :scs (unsigned-reg signed-reg) :target eax))
933         (:arg-types ,ptype positive-fixnum positive-fixnum)
934         (:temporary (:sc unsigned-reg :offset eax-offset :target result
935                          :from (:argument 2) :to (:result 0))
936                     eax)
937         (:results (result :scs (unsigned-reg signed-reg)))
938         (:result-types positive-fixnum)
939         (:generator 5
940           (move eax value)
941           (inst mov (make-ea :word :base object :index index :scale 2
942                              :disp (- (* vector-data-offset n-word-bytes)
943                                       other-pointer-lowtag))
944                 ax-tn)
945           (move result eax)))
946
947       (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
948         (:translate data-vector-set)
949         (:policy :fast-safe)
950         (:args (object :scs (descriptor-reg) :to (:eval 0))
951                (value :scs (unsigned-reg signed-reg) :target eax))
952         (:info index)
953         (:arg-types ,ptype (:constant (signed-byte 30))
954                     positive-fixnum)
955         (:temporary (:sc unsigned-reg :offset eax-offset :target result
956                          :from (:argument 1) :to (:result 0))
957                     eax)
958         (:results (result :scs (unsigned-reg signed-reg)))
959         (:result-types positive-fixnum)
960         (:generator 4
961           (move eax value)
962           (inst mov (make-ea :word :base object
963                              :disp (- (+ (* vector-data-offset n-word-bytes)
964                                          (* 2 index))
965                                       other-pointer-lowtag))
966                 ax-tn)
967           (move result eax))))))
968   (define-data-vector-frobs simple-array-unsigned-byte-15)
969   (define-data-vector-frobs simple-array-unsigned-byte-16))
970
971 ;;; simple-string
972
973 #!+sb-unicode
974 (progn
975 (define-vop (data-vector-ref/simple-base-string)
976   (:translate data-vector-ref)
977   (:policy :fast-safe)
978   (:args (object :scs (descriptor-reg))
979          (index :scs (unsigned-reg)))
980   (:arg-types simple-base-string positive-fixnum)
981   (:results (value :scs (character-reg)))
982   (:result-types character)
983   (:generator 5
984     (inst movzx value
985           (make-ea :byte :base object :index index :scale 1
986                    :disp (- (* vector-data-offset n-word-bytes)
987                             other-pointer-lowtag)))))
988
989 (define-vop (data-vector-ref-c/simple-base-string)
990   (:translate data-vector-ref)
991   (:policy :fast-safe)
992   (:args (object :scs (descriptor-reg)))
993   (:info index)
994   (:arg-types simple-base-string (:constant (signed-byte 30)))
995   (:results (value :scs (character-reg)))
996   (:result-types character)
997   (:generator 4
998     (inst movzx value
999           (make-ea :byte :base object
1000                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1001                             other-pointer-lowtag)))))
1002
1003 (define-vop (data-vector-set/simple-base-string)
1004   (:translate data-vector-set)
1005   (:policy :fast-safe)
1006   (:args (object :scs (descriptor-reg) :to (:eval 0))
1007          (index :scs (unsigned-reg) :to (:eval 0))
1008          (value :scs (character-reg) :target eax))
1009   (:arg-types simple-base-string positive-fixnum character)
1010   (:temporary (:sc character-reg :offset eax-offset :target result
1011                    :from (:argument 2) :to (:result 0))
1012               eax)
1013   (:results (result :scs (character-reg)))
1014   (:result-types character)
1015   (:generator 5
1016     (move eax value)
1017     (inst mov (make-ea :byte :base object :index index :scale 1
1018                        :disp (- (* vector-data-offset n-word-bytes)
1019                                 other-pointer-lowtag))
1020           al-tn)
1021     (move result eax)))
1022
1023 (define-vop (data-vector-set-c/simple-base-string)
1024   (:translate data-vector-set)
1025   (:policy :fast-safe)
1026   (:args (object :scs (descriptor-reg) :to (:eval 0))
1027          (value :scs (character-reg)))
1028   (:info index)
1029   (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1030   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1031                    :from (:argument 1) :to (:result 0))
1032               eax)
1033   (:results (result :scs (character-reg)))
1034   (:result-types character)
1035   (:generator 4
1036     (move eax value)
1037     (inst mov (make-ea :byte :base object
1038                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
1039                                 other-pointer-lowtag))
1040           al-tn)
1041     (move result eax)))
1042 ) ; PROGN
1043
1044 #!-sb-unicode
1045 (progn
1046 (define-vop (data-vector-ref/simple-base-string)
1047   (:translate data-vector-ref)
1048   (:policy :fast-safe)
1049   (:args (object :scs (descriptor-reg))
1050          (index :scs (unsigned-reg)))
1051   (:arg-types simple-base-string positive-fixnum)
1052   (:results (value :scs (character-reg)))
1053   (:result-types character)
1054   (:generator 5
1055     (inst mov value
1056           (make-ea :byte :base object :index index :scale 1
1057                    :disp (- (* vector-data-offset n-word-bytes)
1058                             other-pointer-lowtag)))))
1059
1060 (define-vop (data-vector-ref-c/simple-base-string)
1061   (:translate data-vector-ref)
1062   (:policy :fast-safe)
1063   (:args (object :scs (descriptor-reg)))
1064   (:info index)
1065   (:arg-types simple-base-string (:constant (signed-byte 30)))
1066   (:results (value :scs (character-reg)))
1067   (:result-types character)
1068   (:generator 4
1069     (inst mov value
1070           (make-ea :byte :base object
1071                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1072                             other-pointer-lowtag)))))
1073
1074 (define-vop (data-vector-set/simple-base-string)
1075   (:translate data-vector-set)
1076   (:policy :fast-safe)
1077   (:args (object :scs (descriptor-reg) :to (:eval 0))
1078          (index :scs (unsigned-reg) :to (:eval 0))
1079          (value :scs (character-reg) :target result))
1080   (:arg-types simple-base-string positive-fixnum character)
1081   (:results (result :scs (character-reg)))
1082   (:result-types character)
1083   (:generator 5
1084     (inst mov (make-ea :byte :base object :index index :scale 1
1085                        :disp (- (* vector-data-offset n-word-bytes)
1086                                 other-pointer-lowtag))
1087           value)
1088     (move result value)))
1089
1090 (define-vop (data-vector-set-c/simple-base-string)
1091   (:translate data-vector-set)
1092   (:policy :fast-safe)
1093   (:args (object :scs (descriptor-reg) :to (:eval 0))
1094          (value :scs (character-reg)))
1095   (:info index)
1096   (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1097   (:results (result :scs (character-reg)))
1098   (:result-types character)
1099   (:generator 4
1100    (inst mov (make-ea :byte :base object
1101                       :disp (- (+ (* vector-data-offset n-word-bytes) index)
1102                                other-pointer-lowtag))
1103          value)
1104    (move result value)))
1105 ) ; PROGN
1106
1107 #!+sb-unicode
1108 (define-full-reffer data-vector-ref/simple-character-string
1109     simple-character-string vector-data-offset other-pointer-lowtag
1110     (character-reg) character data-vector-ref)
1111 #!+sb-unicode
1112 (define-full-setter data-vector-set/simple-character-string
1113     simple-character-string vector-data-offset other-pointer-lowtag
1114     (character-reg) character data-vector-set)
1115
1116 ;;; signed-byte-8
1117
1118 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1119   (:translate data-vector-ref)
1120   (:policy :fast-safe)
1121   (:args (object :scs (descriptor-reg))
1122          (index :scs (unsigned-reg)))
1123   (:arg-types simple-array-signed-byte-8 positive-fixnum)
1124   (:results (value :scs (signed-reg)))
1125   (:result-types tagged-num)
1126   (:generator 5
1127     (inst movsx value
1128           (make-ea :byte :base object :index index :scale 1
1129                    :disp (- (* vector-data-offset n-word-bytes)
1130                             other-pointer-lowtag)))))
1131
1132 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1133   (:translate data-vector-ref)
1134   (:policy :fast-safe)
1135   (:args (object :scs (descriptor-reg)))
1136   (:info index)
1137   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1138   (:results (value :scs (signed-reg)))
1139   (:result-types tagged-num)
1140   (:generator 4
1141     (inst movsx value
1142           (make-ea :byte :base object
1143                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1144                             other-pointer-lowtag)))))
1145
1146 (define-vop (data-vector-set/simple-array-signed-byte-8)
1147   (:translate data-vector-set)
1148   (:policy :fast-safe)
1149   (:args (object :scs (descriptor-reg) :to (:eval 0))
1150          (index :scs (unsigned-reg) :to (:eval 0))
1151          (value :scs (signed-reg) :target eax))
1152   (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1153   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1154                    :from (:argument 2) :to (:result 0))
1155               eax)
1156   (:results (result :scs (signed-reg)))
1157   (:result-types tagged-num)
1158   (:generator 5
1159     (move eax value)
1160     (inst mov (make-ea :byte :base object :index index :scale 1
1161                        :disp (- (* vector-data-offset n-word-bytes)
1162                                 other-pointer-lowtag))
1163           al-tn)
1164     (move result eax)))
1165
1166 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1167   (:translate data-vector-set)
1168   (:policy :fast-safe)
1169   (:args (object :scs (descriptor-reg) :to (:eval 0))
1170          (value :scs (signed-reg) :target eax))
1171   (:info index)
1172   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1173               tagged-num)
1174   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1175                    :from (:argument 1) :to (:result 0))
1176               eax)
1177   (:results (result :scs (signed-reg)))
1178   (:result-types tagged-num)
1179   (:generator 4
1180     (move eax value)
1181     (inst mov (make-ea :byte :base object
1182                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
1183                                 other-pointer-lowtag))
1184           al-tn)
1185     (move result eax)))
1186
1187 ;;; signed-byte-16
1188
1189 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1190   (:translate data-vector-ref)
1191   (:policy :fast-safe)
1192   (:args (object :scs (descriptor-reg))
1193          (index :scs (unsigned-reg)))
1194   (:arg-types simple-array-signed-byte-16 positive-fixnum)
1195   (:results (value :scs (signed-reg)))
1196   (:result-types tagged-num)
1197   (:generator 5
1198     (inst movsx value
1199           (make-ea :word :base object :index index :scale 2
1200                    :disp (- (* vector-data-offset n-word-bytes)
1201                             other-pointer-lowtag)))))
1202
1203 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1204   (:translate data-vector-ref)
1205   (:policy :fast-safe)
1206   (:args (object :scs (descriptor-reg)))
1207   (:info index)
1208   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1209   (:results (value :scs (signed-reg)))
1210   (:result-types tagged-num)
1211   (:generator 4
1212     (inst movsx value
1213           (make-ea :word :base object
1214                    :disp (- (+ (* vector-data-offset n-word-bytes)
1215                                (* 2 index))
1216                             other-pointer-lowtag)))))
1217
1218 (define-vop (data-vector-set/simple-array-signed-byte-16)
1219   (:translate data-vector-set)
1220   (:policy :fast-safe)
1221   (:args (object :scs (descriptor-reg) :to (:eval 0))
1222          (index :scs (unsigned-reg) :to (:eval 0))
1223          (value :scs (signed-reg) :target eax))
1224   (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1225   (:temporary (:sc signed-reg :offset eax-offset :target result
1226                    :from (:argument 2) :to (:result 0))
1227               eax)
1228   (:results (result :scs (signed-reg)))
1229   (:result-types tagged-num)
1230   (:generator 5
1231     (move eax value)
1232     (inst mov (make-ea :word :base object :index index :scale 2
1233                        :disp (- (* vector-data-offset n-word-bytes)
1234                                 other-pointer-lowtag))
1235           ax-tn)
1236     (move result eax)))
1237
1238 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1239   (:translate data-vector-set)
1240   (:policy :fast-safe)
1241   (:args (object :scs (descriptor-reg) :to (:eval 0))
1242          (value :scs (signed-reg) :target eax))
1243   (:info index)
1244   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1245   (:temporary (:sc signed-reg :offset eax-offset :target result
1246                    :from (:argument 1) :to (:result 0))
1247               eax)
1248   (:results (result :scs (signed-reg)))
1249   (:result-types tagged-num)
1250   (:generator 4
1251     (move eax value)
1252     (inst mov
1253           (make-ea :word :base object
1254                    :disp (- (+ (* vector-data-offset n-word-bytes)
1255                                (* 2 index))
1256                             other-pointer-lowtag))
1257           ax-tn)
1258     (move result eax)))
1259 \f
1260 ;;; These vops are useful for accessing the bits of a vector
1261 ;;; irrespective of what type of vector it is.
1262 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1263   unsigned-num %raw-bits)
1264 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1265   unsigned-num %set-raw-bits)
1266 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
1267   (unsigned-reg) unsigned-num %vector-raw-bits)
1268 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
1269   (unsigned-reg) unsigned-num %set-vector-raw-bits)
1270 \f
1271 ;;;; miscellaneous array VOPs
1272
1273 (define-vop (get-vector-subtype get-header-data))
1274 (define-vop (set-vector-subtype set-header-data))