a9b7b7977111e950c8cce434b0bf06bd4a0dfcdb
[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) 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 type-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-type))
40      (storew header result 0 other-pointer-type))))
41 \f
42 ;;;; additional accessors and setters for the array header
43
44 (defknown sb!impl::%array-dimension (t index) index
45   (flushable))
46 (defknown sb!impl::%set-array-dimension (t index index) index
47   ())
48
49 (define-full-reffer %array-dimension *
50   array-dimensions-offset other-pointer-type
51   (any-reg) positive-fixnum sb!impl::%array-dimension)
52
53 (define-full-setter %set-array-dimension *
54   array-dimensions-offset other-pointer-type
55   (any-reg) positive-fixnum sb!impl::%set-array-dimension)
56
57 (defknown sb!impl::%array-rank (t) index (flushable))
58
59 (define-vop (array-rank-vop)
60   (:translate sb!impl::%array-rank)
61   (:policy :fast-safe)
62   (:args (x :scs (descriptor-reg)))
63   (:results (res :scs (unsigned-reg)))
64   (:result-types positive-fixnum)
65   (:generator 6
66     (loadw res x 0 other-pointer-type)
67     (inst shr res type-bits)
68     (inst sub res (1- array-dimensions-offset))))
69 \f
70 ;;;; bounds checking routine
71
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.
75 (define-vop (check-bound)
76   (:translate %check-bound)
77   (:policy :fast-safe)
78   (:args (array :scs (descriptor-reg))
79          (bound :scs (any-reg descriptor-reg))
80          (index :scs (any-reg descriptor-reg #+nil immediate) :target result))
81   (:arg-types * positive-fixnum tagged-num)
82   (:results (result :scs (any-reg descriptor-reg)))
83   (:result-types positive-fixnum)
84   (:vop-var vop)
85   (:save-p :compute-only)
86   (:generator 5
87     (let ((error (generate-error-code vop invalid-array-index-error
88                                       array bound index))
89           (index (if (sc-is index immediate)
90                    (fixnumize (tn-value index))
91                    index)))
92       (inst cmp bound index)
93       ;; We use below-or-equal even though it's an unsigned test,
94       ;; because negative indexes appear as large unsigned numbers.
95       ;; Therefore, we get the <0 and >=bound test all rolled into one.
96       (inst jmp :be error)
97       (unless (and (tn-p index) (location= result index))
98         (inst mov result index)))))
99 \f
100 ;;;; accessors/setters
101
102 ;;; variants built on top of WORD-INDEX-REF, etc. I.e., those vectors
103 ;;; whose elements are represented in integer registers and are built
104 ;;; out of 8, 16, or 32 bit elements.
105 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
106              `(progn
107                 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
108                   ,type vector-data-offset other-pointer-type ,scs
109                   ,element-type data-vector-ref)
110                 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
111                   ,type vector-data-offset other-pointer-type ,scs
112                   ,element-type data-vector-set))))
113   (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
114   (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
115     unsigned-reg)
116   (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
117   (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
118     signed-reg))
119 \f
120 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
121 ;;;; bit, 2-bit, and 4-bit vectors
122
123 (macrolet ((def-small-data-vector-frobs (type bits)
124              (let* ((elements-per-word (floor sb!vm:word-bits bits))
125                     (bit-shift (1- (integer-length elements-per-word))))
126     `(progn
127        (define-vop (,(symbolicate 'data-vector-ref/ type))
128          (:note "inline array access")
129          (:translate data-vector-ref)
130          (:policy :fast-safe)
131          (:args (object :scs (descriptor-reg))
132                 (index :scs (unsigned-reg)))
133          (:arg-types ,type positive-fixnum)
134          (:results (result :scs (unsigned-reg) :from (:argument 0)))
135          (:result-types positive-fixnum)
136          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
137          (:generator 20
138            (move ecx index)
139            (inst shr ecx ,bit-shift)
140            (inst mov result
141                  (make-ea :dword :base object :index ecx :scale 4
142                           :disp (- (* vector-data-offset word-bytes)
143                                    other-pointer-type)))
144            (move ecx index)
145            (inst and ecx ,(1- elements-per-word))
146            ,@(unless (= bits 1)
147                `((inst shl ecx ,(1- (integer-length bits)))))
148            (inst shr result :cl)
149            (inst and result ,(1- (ash 1 bits)))))
150        (define-vop (,(symbolicate 'data-vector-ref-c/ type))
151          (:translate data-vector-ref)
152          (:policy :fast-safe)
153          (:args (object :scs (descriptor-reg)))
154          (:arg-types ,type (:constant index))
155          (:info index)
156          (:results (result :scs (unsigned-reg)))
157          (:result-types positive-fixnum)
158          (:generator 15
159            (multiple-value-bind (word extra) (floor index ,elements-per-word)
160              (loadw result object (+ word vector-data-offset)
161                     other-pointer-type)
162              (unless (zerop extra)
163                (inst shr result (* extra ,bits)))
164              (unless (= extra ,(1- elements-per-word))
165                (inst and result ,(1- (ash 1 bits)))))))
166        (define-vop (,(symbolicate 'data-vector-set/ type))
167          (:note "inline array store")
168          (:translate data-vector-set)
169          (:policy :fast-safe)
170          (:args (object :scs (descriptor-reg) :target ptr)
171                 (index :scs (unsigned-reg) :target ecx)
172                 (value :scs (unsigned-reg immediate) :target result))
173          (:arg-types ,type positive-fixnum positive-fixnum)
174          (:results (result :scs (unsigned-reg)))
175          (:result-types positive-fixnum)
176          (:temporary (:sc unsigned-reg) word-index)
177          (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old)
178          (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1))
179                      ecx)
180          (:generator 25
181            (move word-index index)
182            (inst shr word-index ,bit-shift)
183            (inst lea ptr
184                  (make-ea :dword :base object :index word-index :scale 4
185                           :disp (- (* vector-data-offset word-bytes)
186                                    other-pointer-type)))
187            (loadw old ptr)
188            (move ecx index)
189            (inst and ecx ,(1- elements-per-word))
190            ,@(unless (= bits 1)
191                `((inst shl ecx ,(1- (integer-length bits)))))
192            (inst ror old :cl)
193            (unless (and (sc-is value immediate)
194                         (= (tn-value value) ,(1- (ash 1 bits))))
195              (inst and old ,(lognot (1- (ash 1 bits)))))
196            (sc-case value
197              (immediate
198               (unless (zerop (tn-value value))
199                 (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
200              (unsigned-reg
201               (inst or old value)))
202            (inst rol old :cl)
203            (storew old ptr)
204            (sc-case value
205              (immediate
206               (inst mov result (tn-value value)))
207              (unsigned-reg
208               (move result value)))))
209        (define-vop (,(symbolicate 'data-vector-set-c/ type))
210          (:translate data-vector-set)
211          (:policy :fast-safe)
212          (:args (object :scs (descriptor-reg))
213                 (value :scs (unsigned-reg immediate) :target result))
214          (:arg-types ,type (:constant index) positive-fixnum)
215          (:info index)
216          (:results (result :scs (unsigned-reg)))
217          (:result-types positive-fixnum)
218          (:temporary (:sc unsigned-reg :to (:result 0)) old)
219          (:generator 20
220            (multiple-value-bind (word extra) (floor index ,elements-per-word)
221              (inst mov old
222                    (make-ea :dword :base object
223                             :disp (- (* (+ word vector-data-offset) word-bytes)
224                                      other-pointer-type)))
225              (sc-case value
226                (immediate
227                 (let* ((value (tn-value value))
228                        (mask ,(1- (ash 1 bits)))
229                        (shift (* extra ,bits)))
230                   (unless (= value mask)
231                     (inst and old (lognot (ash mask shift))))
232                   (unless (zerop value)
233                     (inst or old (ash value shift)))))
234                (unsigned-reg
235                 (let ((shift (* extra ,bits)))
236                   (unless (zerop shift)
237                     (inst ror old shift)
238                     (inst and old (lognot ,(1- (ash 1 bits))))
239                     (inst or old value)
240                     (inst rol old shift)))))
241              (inst mov (make-ea :dword :base object
242                                 :disp (- (* (+ word vector-data-offset)
243                                             word-bytes)
244                                          other-pointer-type))
245                    old)
246              (sc-case value
247                (immediate
248                 (inst mov result (tn-value value)))
249                (unsigned-reg
250                 (move result value))))))))))
251   (def-small-data-vector-frobs simple-bit-vector 1)
252   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
253   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
254
255 ;;; And the float variants.
256
257 (define-vop (data-vector-ref/simple-array-single-float)
258   (:note "inline array access")
259   (:translate data-vector-ref)
260   (:policy :fast-safe)
261   (:args (object :scs (descriptor-reg))
262          (index :scs (any-reg)))
263   (:arg-types simple-array-single-float positive-fixnum)
264   (:results (value :scs (single-reg)))
265   (:result-types single-float)
266   (:generator 5
267    (with-empty-tn@fp-top(value)
268      (inst fld (make-ea :dword :base object :index index :scale 1
269                         :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
270                                  sb!vm:other-pointer-type))))))
271
272 (define-vop (data-vector-ref-c/simple-array-single-float)
273   (:note "inline array access")
274   (:translate data-vector-ref)
275   (:policy :fast-safe)
276   (:args (object :scs (descriptor-reg)))
277   (:info index)
278   (:arg-types simple-array-single-float (:constant (signed-byte 30)))
279   (:results (value :scs (single-reg)))
280   (:result-types single-float)
281   (:generator 4
282    (with-empty-tn@fp-top(value)
283      (inst fld (make-ea :dword :base object
284                         :disp (- (+ (* sb!vm:vector-data-offset
285                                        sb!vm:word-bytes)
286                                     (* 4 index))
287                                  sb!vm:other-pointer-type))))))
288
289 (define-vop (data-vector-set/simple-array-single-float)
290   (:note "inline array store")
291   (:translate data-vector-set)
292   (:policy :fast-safe)
293   (:args (object :scs (descriptor-reg))
294          (index :scs (any-reg))
295          (value :scs (single-reg) :target result))
296   (:arg-types simple-array-single-float positive-fixnum single-float)
297   (:results (result :scs (single-reg)))
298   (:result-types single-float)
299   (:generator 5
300     (cond ((zerop (tn-offset value))
301            ;; Value is in ST0
302            (inst fst (make-ea :dword :base object :index index :scale 1
303                               :disp (- (* sb!vm:vector-data-offset
304                                           sb!vm:word-bytes)
305                                        sb!vm:other-pointer-type)))
306            (unless (zerop (tn-offset result))
307                    ;; Value is in ST0 but not result.
308                    (inst fst result)))
309           (t
310            ;; Value is not in ST0.
311            (inst fxch value)
312            (inst fst (make-ea :dword :base object :index index :scale 1
313                               :disp (- (* sb!vm:vector-data-offset
314                                           sb!vm:word-bytes)
315                                        sb!vm:other-pointer-type)))
316            (cond ((zerop (tn-offset result))
317                   ;; The result is in ST0.
318                   (inst fst value))
319                  (t
320                   ;; Neither value or result are in ST0
321                   (unless (location= value result)
322                           (inst fst result))
323                   (inst fxch value)))))))
324
325 (define-vop (data-vector-set-c/simple-array-single-float)
326   (:note "inline array store")
327   (:translate data-vector-set)
328   (:policy :fast-safe)
329   (:args (object :scs (descriptor-reg))
330          (value :scs (single-reg) :target result))
331   (:info index)
332   (:arg-types simple-array-single-float (:constant (signed-byte 30))
333               single-float)
334   (:results (result :scs (single-reg)))
335   (:result-types single-float)
336   (:generator 4
337     (cond ((zerop (tn-offset value))
338            ;; Value is in ST0
339            (inst fst (make-ea :dword :base object
340                               :disp (- (+ (* sb!vm:vector-data-offset
341                                              sb!vm:word-bytes)
342                                           (* 4 index))
343                                        sb!vm:other-pointer-type)))
344            (unless (zerop (tn-offset result))
345                    ;; Value is in ST0 but not result.
346                    (inst fst result)))
347           (t
348            ;; Value is not in ST0.
349            (inst fxch value)
350            (inst fst (make-ea :dword :base object
351                               :disp (- (+ (* sb!vm:vector-data-offset
352                                              sb!vm:word-bytes)
353                                           (* 4 index))
354                                        sb!vm:other-pointer-type)))
355            (cond ((zerop (tn-offset result))
356                   ;; The result is in ST0.
357                   (inst fst value))
358                  (t
359                   ;; Neither value or result are in ST0
360                   (unless (location= value result)
361                           (inst fst result))
362                   (inst fxch value)))))))
363
364 (define-vop (data-vector-ref/simple-array-double-float)
365   (:note "inline array access")
366   (:translate data-vector-ref)
367   (:policy :fast-safe)
368   (:args (object :scs (descriptor-reg))
369          (index :scs (any-reg)))
370   (:arg-types simple-array-double-float positive-fixnum)
371   (:results (value :scs (double-reg)))
372   (:result-types double-float)
373   (:generator 7
374    (with-empty-tn@fp-top(value)
375      (inst fldd (make-ea :dword :base object :index index :scale 2
376                          :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
377                                   sb!vm:other-pointer-type))))))
378
379 (define-vop (data-vector-ref-c/simple-array-double-float)
380   (:note "inline array access")
381   (:translate data-vector-ref)
382   (:policy :fast-safe)
383   (:args (object :scs (descriptor-reg)))
384   (:info index)
385   (:arg-types simple-array-double-float (:constant (signed-byte 30)))
386   (:results (value :scs (double-reg)))
387   (:result-types double-float)
388   (:generator 6
389    (with-empty-tn@fp-top(value)
390      (inst fldd (make-ea :dword :base object
391                          :disp (- (+ (* sb!vm:vector-data-offset
392                                         sb!vm:word-bytes)
393                                      (* 8 index))
394                                   sb!vm:other-pointer-type))))))
395
396 (define-vop (data-vector-set/simple-array-double-float)
397   (:note "inline array store")
398   (:translate data-vector-set)
399   (:policy :fast-safe)
400   (:args (object :scs (descriptor-reg))
401          (index :scs (any-reg))
402          (value :scs (double-reg) :target result))
403   (:arg-types simple-array-double-float positive-fixnum double-float)
404   (:results (result :scs (double-reg)))
405   (:result-types double-float)
406   (:generator 20
407     (cond ((zerop (tn-offset value))
408            ;; Value is in ST0
409            (inst fstd (make-ea :dword :base object :index index :scale 2
410                                :disp (- (* sb!vm:vector-data-offset
411                                            sb!vm:word-bytes)
412                                         sb!vm:other-pointer-type)))
413            (unless (zerop (tn-offset result))
414                    ;; Value is in ST0 but not result.
415                    (inst fstd result)))
416           (t
417            ;; Value is not in ST0.
418            (inst fxch value)
419            (inst fstd (make-ea :dword :base object :index index :scale 2
420                                :disp (- (* sb!vm:vector-data-offset
421                                            sb!vm:word-bytes)
422                                         sb!vm:other-pointer-type)))
423            (cond ((zerop (tn-offset result))
424                   ;; The result is in ST0.
425                   (inst fstd value))
426                  (t
427                   ;; Neither value or result are in ST0
428                   (unless (location= value result)
429                           (inst fstd result))
430                   (inst fxch value)))))))
431
432 (define-vop (data-vector-set-c/simple-array-double-float)
433   (:note "inline array store")
434   (:translate data-vector-set)
435   (:policy :fast-safe)
436   (:args (object :scs (descriptor-reg))
437          (value :scs (double-reg) :target result))
438   (:info index)
439   (:arg-types simple-array-double-float (:constant (signed-byte 30))
440               double-float)
441   (:results (result :scs (double-reg)))
442   (:result-types double-float)
443   (:generator 19
444     (cond ((zerop (tn-offset value))
445            ;; Value is in ST0
446            (inst fstd (make-ea :dword :base object
447                                :disp (- (+ (* sb!vm:vector-data-offset
448                                               sb!vm:word-bytes)
449                                            (* 8 index))
450                                         sb!vm:other-pointer-type)))
451            (unless (zerop (tn-offset result))
452                    ;; Value is in ST0 but not result.
453                    (inst fstd result)))
454           (t
455            ;; Value is not in ST0.
456            (inst fxch value)
457            (inst fstd (make-ea :dword :base object
458                                :disp (- (+ (* sb!vm:vector-data-offset
459                                               sb!vm:word-bytes)
460                                            (* 8 index))
461                                         sb!vm:other-pointer-type)))
462            (cond ((zerop (tn-offset result))
463                   ;; The result is in ST0.
464                   (inst fstd value))
465                  (t
466                   ;; Neither value or result are in ST0
467                   (unless (location= value result)
468                           (inst fstd result))
469                   (inst fxch value)))))))
470
471 #!+long-float
472 (define-vop (data-vector-ref/simple-array-long-float)
473   (:note "inline array access")
474   (:translate data-vector-ref)
475   (:policy :fast-safe)
476   (:args (object :scs (descriptor-reg) :to :result)
477          (index :scs (any-reg)))
478   (:arg-types simple-array-long-float positive-fixnum)
479   (:temporary (:sc any-reg :from :eval :to :result) temp)
480   (:results (value :scs (long-reg)))
481   (:result-types long-float)
482   (:generator 7
483     ;; temp = 3 * index
484     (inst lea temp (make-ea :dword :base index :index index :scale 2))
485     (with-empty-tn@fp-top(value)
486       (inst fldl (make-ea :dword :base object :index temp :scale 1
487                           :disp (- (* sb!vm:vector-data-offset
488                                       sb!vm:word-bytes)
489                                    sb!vm:other-pointer-type))))))
490
491 #!+long-float
492 (define-vop (data-vector-ref-c/simple-array-long-float)
493   (:note "inline array access")
494   (:translate data-vector-ref)
495   (:policy :fast-safe)
496   (:args (object :scs (descriptor-reg)))
497   (:info index)
498   (:arg-types simple-array-long-float (:constant (signed-byte 30)))
499   (:results (value :scs (long-reg)))
500   (:result-types long-float)
501   (:generator 6
502    (with-empty-tn@fp-top(value)
503      (inst fldl (make-ea :dword :base object
504                          :disp (- (+ (* sb!vm:vector-data-offset
505                                         sb!vm:word-bytes)
506                                      (* 12 index))
507                                   sb!vm:other-pointer-type))))))
508
509 #!+long-float
510 (define-vop (data-vector-set/simple-array-long-float)
511   (:note "inline array store")
512   (:translate data-vector-set)
513   (:policy :fast-safe)
514   (:args (object :scs (descriptor-reg) :to :result)
515          (index :scs (any-reg))
516          (value :scs (long-reg) :target result))
517   (:arg-types simple-array-long-float positive-fixnum long-float)
518   (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
519   (:results (result :scs (long-reg)))
520   (:result-types long-float)
521   (:generator 20
522     ;; temp = 3 * index
523     (inst lea temp (make-ea :dword :base index :index index :scale 2))
524     (cond ((zerop (tn-offset value))
525            ;; Value is in ST0
526            (store-long-float
527             (make-ea :dword :base object :index temp :scale 1
528                      :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
529                               sb!vm:other-pointer-type)))
530            (unless (zerop (tn-offset result))
531                    ;; Value is in ST0 but not result.
532                    (inst fstd result)))
533           (t
534            ;; Value is not in ST0.
535            (inst fxch value)
536            (store-long-float
537             (make-ea :dword :base object :index temp :scale 1
538                      :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
539                               sb!vm:other-pointer-type)))
540            (cond ((zerop (tn-offset result))
541                   ;; The result is in ST0.
542                   (inst fstd value))
543                  (t
544                   ;; Neither value or result are in ST0
545                   (unless (location= value result)
546                     (inst fstd result))
547                   (inst fxch value)))))))
548
549 #!+long-float
550 (define-vop (data-vector-set-c/simple-array-long-float)
551   (:note "inline array store")
552   (:translate data-vector-set)
553   (:policy :fast-safe)
554   (:args (object :scs (descriptor-reg))
555          (value :scs (long-reg) :target result))
556   (:info index)
557   (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
558   (:results (result :scs (long-reg)))
559   (:result-types long-float)
560   (:generator 19
561     (cond ((zerop (tn-offset value))
562            ;; Value is in ST0
563            (store-long-float (make-ea :dword :base object
564                                       :disp (- (+ (* sb!vm:vector-data-offset
565                                                      sb!vm:word-bytes)
566                                                   (* 12 index))
567                                                sb!vm:other-pointer-type)))
568            (unless (zerop (tn-offset result))
569              ;; Value is in ST0 but not result.
570              (inst fstd result)))
571           (t
572            ;; Value is not in ST0.
573            (inst fxch value)
574            (store-long-float (make-ea :dword :base object
575                                       :disp (- (+ (* sb!vm:vector-data-offset
576                                                      sb!vm:word-bytes)
577                                                   (* 12 index))
578                                                sb!vm:other-pointer-type)))
579            (cond ((zerop (tn-offset result))
580                   ;; The result is in ST0.
581                   (inst fstd value))
582                  (t
583                   ;; Neither value or result are in ST0
584                   (unless (location= value result)
585                     (inst fstd result))
586                   (inst fxch value)))))))
587
588 ;;; complex float variants
589
590 (define-vop (data-vector-ref/simple-array-complex-single-float)
591   (:note "inline array access")
592   (:translate data-vector-ref)
593   (:policy :fast-safe)
594   (:args (object :scs (descriptor-reg))
595          (index :scs (any-reg)))
596   (:arg-types simple-array-complex-single-float positive-fixnum)
597   (:results (value :scs (complex-single-reg)))
598   (:result-types complex-single-float)
599   (:generator 5
600     (let ((real-tn (complex-single-reg-real-tn value)))
601       (with-empty-tn@fp-top (real-tn)
602         (inst fld (make-ea :dword :base object :index index :scale 2
603                            :disp (- (* sb!vm:vector-data-offset
604                                        sb!vm:word-bytes)
605                                     sb!vm:other-pointer-type)))))
606     (let ((imag-tn (complex-single-reg-imag-tn value)))
607       (with-empty-tn@fp-top (imag-tn)
608         (inst fld (make-ea :dword :base object :index index :scale 2
609                            :disp (- (* (1+ sb!vm:vector-data-offset)
610                                        sb!vm:word-bytes)
611                                     sb!vm:other-pointer-type)))))))
612
613 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
614   (:note "inline array access")
615   (:translate data-vector-ref)
616   (:policy :fast-safe)
617   (:args (object :scs (descriptor-reg)))
618   (:info index)
619   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
620   (:results (value :scs (complex-single-reg)))
621   (:result-types complex-single-float)
622   (:generator 4
623     (let ((real-tn (complex-single-reg-real-tn value)))
624       (with-empty-tn@fp-top (real-tn)
625         (inst fld (make-ea :dword :base object
626                            :disp (- (+ (* sb!vm:vector-data-offset
627                                           sb!vm:word-bytes)
628                                        (* 8 index))
629                                     sb!vm:other-pointer-type)))))
630     (let ((imag-tn (complex-single-reg-imag-tn value)))
631       (with-empty-tn@fp-top (imag-tn)
632         (inst fld (make-ea :dword :base object
633                            :disp (- (+ (* sb!vm:vector-data-offset
634                                           sb!vm:word-bytes)
635                                        (* 8 index) 4)
636                                     sb!vm:other-pointer-type)))))))
637
638 (define-vop (data-vector-set/simple-array-complex-single-float)
639   (:note "inline array store")
640   (:translate data-vector-set)
641   (:policy :fast-safe)
642   (:args (object :scs (descriptor-reg))
643          (index :scs (any-reg))
644          (value :scs (complex-single-reg) :target result))
645   (:arg-types simple-array-complex-single-float positive-fixnum
646               complex-single-float)
647   (:results (result :scs (complex-single-reg)))
648   (:result-types complex-single-float)
649   (:generator 5
650     (let ((value-real (complex-single-reg-real-tn value))
651           (result-real (complex-single-reg-real-tn result)))
652       (cond ((zerop (tn-offset value-real))
653              ;; Value is in ST0.
654              (inst fst (make-ea :dword :base object :index index :scale 2
655                                 :disp (- (* sb!vm:vector-data-offset
656                                             sb!vm:word-bytes)
657                                          sb!vm:other-pointer-type)))
658              (unless (zerop (tn-offset result-real))
659                ;; Value is in ST0 but not result.
660                (inst fst result-real)))
661             (t
662              ;; Value is not in ST0.
663              (inst fxch value-real)
664              (inst fst (make-ea :dword :base object :index index :scale 2
665                                 :disp (- (* sb!vm:vector-data-offset
666                                             sb!vm:word-bytes)
667                                          sb!vm:other-pointer-type)))
668              (cond ((zerop (tn-offset result-real))
669                     ;; The result is in ST0.
670                     (inst fst value-real))
671                    (t
672                     ;; Neither value or result are in ST0
673                     (unless (location= value-real result-real)
674                       (inst fst result-real))
675                     (inst fxch value-real))))))
676     (let ((value-imag (complex-single-reg-imag-tn value))
677           (result-imag (complex-single-reg-imag-tn result)))
678       (inst fxch value-imag)
679       (inst fst (make-ea :dword :base object :index index :scale 2
680                          :disp (- (+ (* sb!vm:vector-data-offset
681                                         sb!vm:word-bytes)
682                                      4)
683                                   sb!vm:other-pointer-type)))
684       (unless (location= value-imag result-imag)
685         (inst fst result-imag))
686       (inst fxch value-imag))))
687
688 (define-vop (data-vector-set-c/simple-array-complex-single-float)
689   (:note "inline array store")
690   (:translate data-vector-set)
691   (:policy :fast-safe)
692   (:args (object :scs (descriptor-reg))
693          (value :scs (complex-single-reg) :target result))
694   (:info index)
695   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
696               complex-single-float)
697   (:results (result :scs (complex-single-reg)))
698   (:result-types complex-single-float)
699   (:generator 4
700     (let ((value-real (complex-single-reg-real-tn value))
701           (result-real (complex-single-reg-real-tn result)))
702       (cond ((zerop (tn-offset value-real))
703              ;; Value is in ST0
704              (inst fst (make-ea :dword :base object
705                                 :disp (- (+ (* sb!vm:vector-data-offset
706                                                sb!vm:word-bytes)
707                                             (* 8 index))
708                                          sb!vm:other-pointer-type)))
709              (unless (zerop (tn-offset result-real))
710                ;; Value is in ST0 but not result.
711                (inst fst result-real)))
712             (t
713              ;; Value is not in ST0.
714              (inst fxch value-real)
715              (inst fst (make-ea :dword :base object
716                                 :disp (- (+ (* sb!vm:vector-data-offset
717                                                sb!vm:word-bytes)
718                                             (* 8 index))
719                                          sb!vm:other-pointer-type)))
720              (cond ((zerop (tn-offset result-real))
721                     ;; The result is in ST0.
722                     (inst fst value-real))
723                    (t
724                     ;; Neither value or result are in ST0
725                     (unless (location= value-real result-real)
726                       (inst fst result-real))
727                     (inst fxch value-real))))))
728     (let ((value-imag (complex-single-reg-imag-tn value))
729           (result-imag (complex-single-reg-imag-tn result)))
730       (inst fxch value-imag)
731       (inst fst (make-ea :dword :base object
732                          :disp (- (+ (* sb!vm:vector-data-offset
733                                         sb!vm:word-bytes)
734                                      (* 8 index) 4)
735                                   sb!vm:other-pointer-type)))
736       (unless (location= value-imag result-imag)
737         (inst fst result-imag))
738       (inst fxch value-imag))))
739
740
741 (define-vop (data-vector-ref/simple-array-complex-double-float)
742   (:note "inline array access")
743   (:translate data-vector-ref)
744   (:policy :fast-safe)
745   (:args (object :scs (descriptor-reg))
746          (index :scs (any-reg)))
747   (:arg-types simple-array-complex-double-float positive-fixnum)
748   (:results (value :scs (complex-double-reg)))
749   (:result-types complex-double-float)
750   (:generator 7
751     (let ((real-tn (complex-double-reg-real-tn value)))
752       (with-empty-tn@fp-top (real-tn)
753         (inst fldd (make-ea :dword :base object :index index :scale 4
754                             :disp (- (* sb!vm:vector-data-offset
755                                         sb!vm:word-bytes)
756                                      sb!vm:other-pointer-type)))))
757     (let ((imag-tn (complex-double-reg-imag-tn value)))
758       (with-empty-tn@fp-top (imag-tn)
759         (inst fldd (make-ea :dword :base object :index index :scale 4
760                             :disp (- (+ (* sb!vm:vector-data-offset
761                                            sb!vm:word-bytes)
762                                         8)
763                                      sb!vm:other-pointer-type)))))))
764
765 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
766   (:note "inline array access")
767   (:translate data-vector-ref)
768   (:policy :fast-safe)
769   (:args (object :scs (descriptor-reg)))
770   (:info index)
771   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
772   (:results (value :scs (complex-double-reg)))
773   (:result-types complex-double-float)
774   (:generator 6
775     (let ((real-tn (complex-double-reg-real-tn value)))
776       (with-empty-tn@fp-top (real-tn)
777         (inst fldd (make-ea :dword :base object
778                             :disp (- (+ (* sb!vm:vector-data-offset
779                                            sb!vm:word-bytes)
780                                         (* 16 index))
781                                      sb!vm:other-pointer-type)))))
782     (let ((imag-tn (complex-double-reg-imag-tn value)))
783       (with-empty-tn@fp-top (imag-tn)
784         (inst fldd (make-ea :dword :base object
785                             :disp (- (+ (* sb!vm:vector-data-offset
786                                            sb!vm:word-bytes)
787                                         (* 16 index) 8)
788                                      sb!vm:other-pointer-type)))))))
789
790 (define-vop (data-vector-set/simple-array-complex-double-float)
791   (:note "inline array store")
792   (:translate data-vector-set)
793   (:policy :fast-safe)
794   (:args (object :scs (descriptor-reg))
795          (index :scs (any-reg))
796          (value :scs (complex-double-reg) :target result))
797   (:arg-types simple-array-complex-double-float positive-fixnum
798               complex-double-float)
799   (:results (result :scs (complex-double-reg)))
800   (:result-types complex-double-float)
801   (:generator 20
802     (let ((value-real (complex-double-reg-real-tn value))
803           (result-real (complex-double-reg-real-tn result)))
804       (cond ((zerop (tn-offset value-real))
805              ;; Value is in ST0
806              (inst fstd (make-ea :dword :base object :index index :scale 4
807                                  :disp (- (* sb!vm:vector-data-offset
808                                              sb!vm:word-bytes)
809                                           sb!vm:other-pointer-type)))
810              (unless (zerop (tn-offset result-real))
811                ;; Value is in ST0 but not result.
812                (inst fstd result-real)))
813             (t
814              ;; Value is not in ST0.
815              (inst fxch value-real)
816              (inst fstd (make-ea :dword :base object :index index :scale 4
817                                  :disp (- (* sb!vm:vector-data-offset
818                                              sb!vm:word-bytes)
819                                           sb!vm:other-pointer-type)))
820              (cond ((zerop (tn-offset result-real))
821                     ;; The result is in ST0.
822                     (inst fstd value-real))
823                    (t
824                     ;; Neither value or result are in ST0
825                     (unless (location= value-real result-real)
826                       (inst fstd result-real))
827                     (inst fxch value-real))))))
828     (let ((value-imag (complex-double-reg-imag-tn value))
829           (result-imag (complex-double-reg-imag-tn result)))
830       (inst fxch value-imag)
831       (inst fstd (make-ea :dword :base object :index index :scale 4
832                           :disp (- (+ (* sb!vm:vector-data-offset
833                                          sb!vm:word-bytes)
834                                       8)
835                                    sb!vm:other-pointer-type)))
836       (unless (location= value-imag result-imag)
837         (inst fstd result-imag))
838       (inst fxch value-imag))))
839
840 (define-vop (data-vector-set-c/simple-array-complex-double-float)
841   (:note "inline array store")
842   (:translate data-vector-set)
843   (:policy :fast-safe)
844   (:args (object :scs (descriptor-reg))
845          (value :scs (complex-double-reg) :target result))
846   (:info index)
847   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
848               complex-double-float)
849   (:results (result :scs (complex-double-reg)))
850   (:result-types complex-double-float)
851   (:generator 19
852     (let ((value-real (complex-double-reg-real-tn value))
853           (result-real (complex-double-reg-real-tn result)))
854       (cond ((zerop (tn-offset value-real))
855              ;; Value is in ST0
856              (inst fstd (make-ea :dword :base object
857                                  :disp (- (+ (* sb!vm:vector-data-offset
858                                                 sb!vm:word-bytes)
859                                              (* 16 index))
860                                           sb!vm:other-pointer-type)))
861              (unless (zerop (tn-offset result-real))
862                ;; Value is in ST0 but not result.
863                (inst fstd result-real)))
864             (t
865              ;; Value is not in ST0.
866              (inst fxch value-real)
867              (inst fstd (make-ea :dword :base object
868                                  :disp (- (+ (* sb!vm:vector-data-offset
869                                                 sb!vm:word-bytes)
870                                              (* 16 index))
871                                           sb!vm:other-pointer-type)))
872              (cond ((zerop (tn-offset result-real))
873                     ;; The result is in ST0.
874                     (inst fstd value-real))
875                    (t
876                     ;; Neither value or result are in ST0
877                     (unless (location= value-real result-real)
878                       (inst fstd result-real))
879                     (inst fxch value-real))))))
880     (let ((value-imag (complex-double-reg-imag-tn value))
881           (result-imag (complex-double-reg-imag-tn result)))
882       (inst fxch value-imag)
883       (inst fstd (make-ea :dword :base object
884                           :disp (- (+ (* sb!vm:vector-data-offset
885                                          sb!vm:word-bytes)
886                                       (* 16 index) 8)
887                                    sb!vm:other-pointer-type)))
888       (unless (location= value-imag result-imag)
889         (inst fstd result-imag))
890       (inst fxch value-imag))))
891
892
893 #!+long-float
894 (define-vop (data-vector-ref/simple-array-complex-long-float)
895   (:note "inline array access")
896   (:translate data-vector-ref)
897   (:policy :fast-safe)
898   (:args (object :scs (descriptor-reg) :to :result)
899          (index :scs (any-reg)))
900   (:arg-types simple-array-complex-long-float positive-fixnum)
901   (:temporary (:sc any-reg :from :eval :to :result) temp)
902   (:results (value :scs (complex-long-reg)))
903   (:result-types complex-long-float)
904   (:generator 7
905     ;; temp = 3 * index
906     (inst lea temp (make-ea :dword :base index :index index :scale 2))
907     (let ((real-tn (complex-long-reg-real-tn value)))
908       (with-empty-tn@fp-top (real-tn)
909         (inst fldl (make-ea :dword :base object :index temp :scale 2
910                             :disp (- (* sb!vm:vector-data-offset
911                                         sb!vm:word-bytes)
912                                      sb!vm:other-pointer-type)))))
913     (let ((imag-tn (complex-long-reg-imag-tn value)))
914       (with-empty-tn@fp-top (imag-tn)
915         (inst fldl (make-ea :dword :base object :index temp :scale 2
916                             :disp (- (+ (* sb!vm:vector-data-offset
917                                            sb!vm:word-bytes)
918                                         12)
919                                      sb!vm:other-pointer-type)))))))
920
921 #!+long-float
922 (define-vop (data-vector-ref-c/simple-array-complex-long-float)
923   (:note "inline array access")
924   (:translate data-vector-ref)
925   (:policy :fast-safe)
926   (:args (object :scs (descriptor-reg)))
927   (:info index)
928   (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
929   (:results (value :scs (complex-long-reg)))
930   (:result-types complex-long-float)
931   (:generator 6
932     (let ((real-tn (complex-long-reg-real-tn value)))
933       (with-empty-tn@fp-top (real-tn)
934         (inst fldl (make-ea :dword :base object
935                             :disp (- (+ (* sb!vm:vector-data-offset
936                                            sb!vm:word-bytes)
937                                         (* 24 index))
938                                      sb!vm:other-pointer-type)))))
939     (let ((imag-tn (complex-long-reg-imag-tn value)))
940       (with-empty-tn@fp-top (imag-tn)
941         (inst fldl (make-ea :dword :base object
942                             :disp (- (+ (* sb!vm:vector-data-offset
943                                            sb!vm:word-bytes)
944                                         (* 24 index) 12)
945                                      sb!vm:other-pointer-type)))))))
946
947 #!+long-float
948 (define-vop (data-vector-set/simple-array-complex-long-float)
949   (:note "inline array store")
950   (:translate data-vector-set)
951   (:policy :fast-safe)
952   (:args (object :scs (descriptor-reg) :to :result)
953          (index :scs (any-reg))
954          (value :scs (complex-long-reg) :target result))
955   (:arg-types simple-array-complex-long-float positive-fixnum
956               complex-long-float)
957   (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
958   (:results (result :scs (complex-long-reg)))
959   (:result-types complex-long-float)
960   (:generator 20
961     ;; temp = 3 * index
962     (inst lea temp (make-ea :dword :base index :index index :scale 2))
963     (let ((value-real (complex-long-reg-real-tn value))
964           (result-real (complex-long-reg-real-tn result)))
965       (cond ((zerop (tn-offset value-real))
966              ;; Value is in ST0
967              (store-long-float
968               (make-ea :dword :base object :index temp :scale 2
969                        :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
970                                 sb!vm:other-pointer-type)))
971              (unless (zerop (tn-offset result-real))
972                ;; Value is in ST0 but not result.
973                (inst fstd result-real)))
974             (t
975              ;; Value is not in ST0.
976              (inst fxch value-real)
977              (store-long-float
978               (make-ea :dword :base object :index temp :scale 2
979                        :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
980                                 sb!vm:other-pointer-type)))
981              (cond ((zerop (tn-offset result-real))
982                     ;; The result is in ST0.
983                     (inst fstd value-real))
984                    (t
985                     ;; Neither value or result are in ST0
986                     (unless (location= value-real result-real)
987                       (inst fstd result-real))
988                     (inst fxch value-real))))))
989     (let ((value-imag (complex-long-reg-imag-tn value))
990           (result-imag (complex-long-reg-imag-tn result)))
991       (inst fxch value-imag)
992       (store-long-float
993        (make-ea :dword :base object :index temp :scale 2
994                 :disp (- (+ (* sb!vm:vector-data-offset sb!vm:word-bytes) 12)
995                          sb!vm:other-pointer-type)))
996       (unless (location= value-imag result-imag)
997         (inst fstd result-imag))
998       (inst fxch value-imag))))
999
1000 #!+long-float
1001 (define-vop (data-vector-set-c/simple-array-complex-long-float)
1002   (:note "inline array store")
1003   (:translate data-vector-set)
1004   (:policy :fast-safe)
1005   (:args (object :scs (descriptor-reg))
1006          (value :scs (complex-long-reg) :target result))
1007   (:info index)
1008   (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
1009               complex-long-float)
1010   (:results (result :scs (complex-long-reg)))
1011   (:result-types complex-long-float)
1012   (:generator 19
1013     (let ((value-real (complex-long-reg-real-tn value))
1014           (result-real (complex-long-reg-real-tn result)))
1015       (cond ((zerop (tn-offset value-real))
1016              ;; Value is in ST0
1017              (store-long-float
1018               (make-ea :dword :base object
1019                        :disp (- (+ (* sb!vm:vector-data-offset
1020                                       sb!vm:word-bytes)
1021                                    (* 24 index))
1022                                 sb!vm:other-pointer-type)))
1023              (unless (zerop (tn-offset result-real))
1024                ;; Value is in ST0 but not result.
1025                (inst fstd result-real)))
1026             (t
1027              ;; Value is not in ST0.
1028              (inst fxch value-real)
1029              (store-long-float
1030               (make-ea :dword :base object
1031                        :disp (- (+ (* sb!vm:vector-data-offset
1032                                       sb!vm:word-bytes)
1033                                    (* 24 index))
1034                                 sb!vm:other-pointer-type)))
1035              (cond ((zerop (tn-offset result-real))
1036                     ;; The result is in ST0.
1037                     (inst fstd value-real))
1038                    (t
1039                     ;; Neither value or result are in ST0
1040                     (unless (location= value-real result-real)
1041                       (inst fstd result-real))
1042                     (inst fxch value-real))))))
1043     (let ((value-imag (complex-long-reg-imag-tn value))
1044           (result-imag (complex-long-reg-imag-tn result)))
1045       (inst fxch value-imag)
1046       (store-long-float
1047        (make-ea :dword :base object
1048                 :disp (- (+ (* sb!vm:vector-data-offset
1049                                sb!vm:word-bytes)
1050                             ;; FIXME: There are so many of these bare constants
1051                             ;; (24, 12..) in the LONG-FLOAT code that it's
1052                             ;; ridiculous. I should probably just delete it all
1053                             ;; instead of appearing to flirt with supporting
1054                             ;; this maintenance nightmare.
1055                             (* 24 index) 12)
1056                          sb!vm:other-pointer-type)))
1057       (unless (location= value-imag result-imag)
1058         (inst fstd result-imag))
1059       (inst fxch value-imag))))
1060
1061 \f
1062 ;;;; dtc expanded and fixed the following:
1063
1064 ;;; unsigned-byte-8
1065
1066 (define-vop (data-vector-ref/simple-array-unsigned-byte-8)
1067   (:translate data-vector-ref)
1068   (:policy :fast-safe)
1069   (:args (object :scs (descriptor-reg))
1070          (index :scs (unsigned-reg)))
1071   (:arg-types simple-array-unsigned-byte-8 positive-fixnum)
1072   (:results (value :scs (unsigned-reg signed-reg)))
1073   (:result-types positive-fixnum)
1074   (:generator 5
1075     (inst movzx value
1076           (make-ea :byte :base object :index index :scale 1
1077                    :disp (- (* vector-data-offset word-bytes)
1078                             other-pointer-type)))))
1079
1080 (define-vop (data-vector-ref-c/simple-array-unsigned-byte-8)
1081   (:translate data-vector-ref)
1082   (:policy :fast-safe)
1083   (:args (object :scs (descriptor-reg)))
1084   (:info index)
1085   (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)))
1086   (:results (value :scs (unsigned-reg signed-reg)))
1087   (:result-types positive-fixnum)
1088   (:generator 4
1089     (inst movzx value
1090           (make-ea :byte :base object
1091                    :disp (- (+ (* vector-data-offset word-bytes) index)
1092                             other-pointer-type)))))
1093
1094 (define-vop (data-vector-set/simple-array-unsigned-byte-8)
1095   (:translate data-vector-set)
1096   (:policy :fast-safe)
1097   (:args (object :scs (descriptor-reg) :to (:eval 0))
1098          (index :scs (unsigned-reg) :to (:eval 0))
1099          (value :scs (unsigned-reg signed-reg) :target eax))
1100   (:arg-types simple-array-unsigned-byte-8 positive-fixnum positive-fixnum)
1101   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1102                    :from (:argument 2) :to (:result 0))
1103               eax)
1104   (:results (result :scs (unsigned-reg signed-reg)))
1105   (:result-types positive-fixnum)
1106   (:generator 5
1107     (move eax value)
1108     (inst mov (make-ea :byte :base object :index index :scale 1
1109                        :disp (- (* vector-data-offset word-bytes)
1110                                 other-pointer-type))
1111           al-tn)
1112     (move result eax)))
1113
1114 (define-vop (data-vector-set-c/simple-array-unsigned-byte-8)
1115   (:translate data-vector-set)
1116   (:policy :fast-safe)
1117   (:args (object :scs (descriptor-reg) :to (:eval 0))
1118          (value :scs (unsigned-reg signed-reg) :target eax))
1119   (:info index)
1120   (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30))
1121               positive-fixnum)
1122   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1123                    :from (:argument 1) :to (:result 0))
1124               eax)
1125   (:results (result :scs (unsigned-reg signed-reg)))
1126   (:result-types positive-fixnum)
1127   (:generator 4
1128     (move eax value)
1129     (inst mov (make-ea :byte :base object
1130                        :disp (- (+ (* vector-data-offset word-bytes) index)
1131                                 other-pointer-type))
1132           al-tn)
1133     (move result eax)))
1134
1135 ;;; unsigned-byte-16
1136
1137 (define-vop (data-vector-ref/simple-array-unsigned-byte-16)
1138   (:translate data-vector-ref)
1139   (:policy :fast-safe)
1140   (:args (object :scs (descriptor-reg))
1141          (index :scs (unsigned-reg)))
1142   (:arg-types simple-array-unsigned-byte-16 positive-fixnum)
1143   (:results (value :scs (unsigned-reg signed-reg)))
1144   (:result-types positive-fixnum)
1145   (:generator 5
1146     (inst movzx value
1147           (make-ea :word :base object :index index :scale 2
1148                    :disp (- (* vector-data-offset word-bytes)
1149                             other-pointer-type)))))
1150
1151 (define-vop (data-vector-ref-c/simple-array-unsigned-byte-16)
1152   (:translate data-vector-ref)
1153   (:policy :fast-safe)
1154   (:args (object :scs (descriptor-reg)))
1155   (:info index)
1156   (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30)))
1157   (:results (value :scs (unsigned-reg signed-reg)))
1158   (:result-types positive-fixnum)
1159   (:generator 4
1160     (inst movzx value
1161           (make-ea :word :base object
1162                    :disp (- (+ (* vector-data-offset word-bytes) (* 2 index))
1163                             other-pointer-type)))))
1164
1165 (define-vop (data-vector-set/simple-array-unsigned-byte-16)
1166   (:translate data-vector-set)
1167   (:policy :fast-safe)
1168   (:args (object :scs (descriptor-reg) :to (:eval 0))
1169          (index :scs (unsigned-reg) :to (:eval 0))
1170          (value :scs (unsigned-reg signed-reg) :target eax))
1171   (:arg-types simple-array-unsigned-byte-16 positive-fixnum positive-fixnum)
1172   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1173                    :from (:argument 2) :to (:result 0))
1174               eax)
1175   (:results (result :scs (unsigned-reg signed-reg)))
1176   (:result-types positive-fixnum)
1177   (:generator 5
1178     (move eax value)
1179     (inst mov (make-ea :word :base object :index index :scale 2
1180                        :disp (- (* vector-data-offset word-bytes)
1181                                 other-pointer-type))
1182           ax-tn)
1183     (move result eax)))
1184
1185 (define-vop (data-vector-set-c/simple-array-unsigned-byte-16)
1186   (:translate data-vector-set)
1187   (:policy :fast-safe)
1188   (:args (object :scs (descriptor-reg) :to (:eval 0))
1189          (value :scs (unsigned-reg signed-reg) :target eax))
1190   (:info index)
1191   (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30))
1192               positive-fixnum)
1193   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1194                    :from (:argument 1) :to (:result 0))
1195               eax)
1196   (:results (result :scs (unsigned-reg signed-reg)))
1197   (:result-types positive-fixnum)
1198   (:generator 4
1199     (move eax value)
1200     (inst mov (make-ea :word :base object
1201                        :disp (- (+ (* vector-data-offset word-bytes)
1202                                    (* 2 index))
1203                                 other-pointer-type))
1204           ax-tn)
1205     (move result eax)))
1206
1207 ;;; simple-string
1208
1209 (define-vop (data-vector-ref/simple-string)
1210   (:translate data-vector-ref)
1211   (:policy :fast-safe)
1212   (:args (object :scs (descriptor-reg))
1213          (index :scs (unsigned-reg)))
1214   (:arg-types simple-string positive-fixnum)
1215   (:temporary (:sc unsigned-reg ; byte-reg
1216                    :offset eax-offset ; al-offset
1217                    :target value
1218                    :from (:eval 0) :to (:result 0))
1219               eax)
1220   (:ignore eax)
1221   (:results (value :scs (base-char-reg)))
1222   (:result-types base-char)
1223   (:generator 5
1224     (inst mov al-tn
1225           (make-ea :byte :base object :index index :scale 1
1226                    :disp (- (* vector-data-offset word-bytes)
1227                             other-pointer-type)))
1228     (move value al-tn)))
1229
1230 (define-vop (data-vector-ref-c/simple-string)
1231   (:translate data-vector-ref)
1232   (:policy :fast-safe)
1233   (:args (object :scs (descriptor-reg)))
1234   (:info index)
1235   (:arg-types simple-string (:constant (signed-byte 30)))
1236   (:temporary (:sc unsigned-reg :offset eax-offset :target value
1237                    :from (:eval 0) :to (:result 0))
1238               eax)
1239   (:ignore eax)
1240   (:results (value :scs (base-char-reg)))
1241   (:result-types base-char)
1242   (:generator 4
1243     (inst mov al-tn
1244           (make-ea :byte :base object
1245                    :disp (- (+ (* vector-data-offset word-bytes) index)
1246                             other-pointer-type)))
1247     (move value al-tn)))
1248
1249 (define-vop (data-vector-set/simple-string)
1250   (:translate data-vector-set)
1251   (:policy :fast-safe)
1252   (:args (object :scs (descriptor-reg) :to (:eval 0))
1253          (index :scs (unsigned-reg) :to (:eval 0))
1254          (value :scs (base-char-reg)))
1255   (:arg-types simple-string positive-fixnum base-char)
1256   (:results (result :scs (base-char-reg)))
1257   (:result-types base-char)
1258   (:generator 5
1259     (inst mov (make-ea :byte :base object :index index :scale 1
1260                        :disp (- (* vector-data-offset word-bytes)
1261                                 other-pointer-type))
1262           value)
1263     (move result value)))
1264
1265 (define-vop (data-vector-set/simple-string-c)
1266   (:translate data-vector-set)
1267   (:policy :fast-safe)
1268   (:args (object :scs (descriptor-reg) :to (:eval 0))
1269          (value :scs (base-char-reg)))
1270   (:info index)
1271   (:arg-types simple-string (:constant (signed-byte 30)) base-char)
1272   (:results (result :scs (base-char-reg)))
1273   (:result-types base-char)
1274   (:generator 4
1275    (inst mov (make-ea :byte :base object
1276                       :disp (- (+ (* vector-data-offset word-bytes) index)
1277                                other-pointer-type))
1278          value)
1279    (move result value)))
1280
1281 ;;; signed-byte-8
1282
1283 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1284   (:translate data-vector-ref)
1285   (:policy :fast-safe)
1286   (:args (object :scs (descriptor-reg))
1287          (index :scs (unsigned-reg)))
1288   (:arg-types simple-array-signed-byte-8 positive-fixnum)
1289   (:results (value :scs (signed-reg)))
1290   (:result-types tagged-num)
1291   (:generator 5
1292     (inst movsx value
1293           (make-ea :byte :base object :index index :scale 1
1294                    :disp (- (* vector-data-offset word-bytes)
1295                             other-pointer-type)))))
1296
1297 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1298   (:translate data-vector-ref)
1299   (:policy :fast-safe)
1300   (:args (object :scs (descriptor-reg)))
1301   (:info index)
1302   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1303   (:results (value :scs (signed-reg)))
1304   (:result-types tagged-num)
1305   (:generator 4
1306     (inst movsx value
1307           (make-ea :byte :base object
1308                    :disp (- (+ (* vector-data-offset word-bytes) index)
1309                             other-pointer-type)))))
1310
1311 (define-vop (data-vector-set/simple-array-signed-byte-8)
1312   (:translate data-vector-set)
1313   (:policy :fast-safe)
1314   (:args (object :scs (descriptor-reg) :to (:eval 0))
1315          (index :scs (unsigned-reg) :to (:eval 0))
1316          (value :scs (signed-reg) :target eax))
1317   (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1318   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1319                    :from (:argument 2) :to (:result 0))
1320               eax)
1321   (:results (result :scs (signed-reg)))
1322   (:result-types tagged-num)
1323   (:generator 5
1324     (move eax value)
1325     (inst mov (make-ea :byte :base object :index index :scale 1
1326                        :disp (- (* vector-data-offset word-bytes)
1327                                 other-pointer-type))
1328           al-tn)
1329     (move result eax)))
1330
1331 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1332   (:translate data-vector-set)
1333   (:policy :fast-safe)
1334   (:args (object :scs (descriptor-reg) :to (:eval 0))
1335          (value :scs (signed-reg) :target eax))
1336   (:info index)
1337   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1338               tagged-num)
1339   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1340                    :from (:argument 1) :to (:result 0))
1341               eax)
1342   (:results (result :scs (signed-reg)))
1343   (:result-types tagged-num)
1344   (:generator 4
1345     (move eax value)
1346     (inst mov (make-ea :byte :base object
1347                        :disp (- (+ (* vector-data-offset word-bytes) index)
1348                                 other-pointer-type))
1349           al-tn)
1350     (move result eax)))
1351
1352 ;;; signed-byte-16
1353
1354 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1355   (:translate data-vector-ref)
1356   (:policy :fast-safe)
1357   (:args (object :scs (descriptor-reg))
1358          (index :scs (unsigned-reg)))
1359   (:arg-types simple-array-signed-byte-16 positive-fixnum)
1360   (:results (value :scs (signed-reg)))
1361   (:result-types tagged-num)
1362   (:generator 5
1363     (inst movsx value
1364           (make-ea :word :base object :index index :scale 2
1365                    :disp (- (* vector-data-offset word-bytes)
1366                             other-pointer-type)))))
1367
1368 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1369   (:translate data-vector-ref)
1370   (:policy :fast-safe)
1371   (:args (object :scs (descriptor-reg)))
1372   (:info index)
1373   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1374   (:results (value :scs (signed-reg)))
1375   (:result-types tagged-num)
1376   (:generator 4
1377     (inst movsx value
1378           (make-ea :word :base object
1379                    :disp (- (+ (* vector-data-offset word-bytes)
1380                                (* 2 index))
1381                             other-pointer-type)))))
1382
1383 (define-vop (data-vector-set/simple-array-signed-byte-16)
1384   (:translate data-vector-set)
1385   (:policy :fast-safe)
1386   (:args (object :scs (descriptor-reg) :to (:eval 0))
1387          (index :scs (unsigned-reg) :to (:eval 0))
1388          (value :scs (signed-reg) :target eax))
1389   (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1390   (:temporary (:sc signed-reg :offset eax-offset :target result
1391                    :from (:argument 2) :to (:result 0))
1392               eax)
1393   (:results (result :scs (signed-reg)))
1394   (:result-types tagged-num)
1395   (:generator 5
1396     (move eax value)
1397     (inst mov (make-ea :word :base object :index index :scale 2
1398                        :disp (- (* vector-data-offset word-bytes)
1399                                 other-pointer-type))
1400           ax-tn)
1401     (move result eax)))
1402
1403 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1404   (:translate data-vector-set)
1405   (:policy :fast-safe)
1406   (:args (object :scs (descriptor-reg) :to (:eval 0))
1407          (value :scs (signed-reg) :target eax))
1408   (:info index)
1409   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1410   (:temporary (:sc signed-reg :offset eax-offset :target result
1411                    :from (:argument 1) :to (:result 0))
1412               eax)
1413   (:results (result :scs (signed-reg)))
1414   (:result-types tagged-num)
1415   (:generator 4
1416     (move eax value)
1417     (inst mov
1418           (make-ea :word :base object
1419                    :disp (- (+ (* vector-data-offset word-bytes)
1420                                (* 2 index))
1421                             other-pointer-type))
1422           ax-tn)
1423     (move result eax)))
1424 \f
1425 ;;; These VOPs are used for implementing float slots in structures (whose raw
1426 ;;; data is an unsigned-32 vector).
1427 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
1428   (:translate %raw-ref-single)
1429   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1430 (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
1431   (:translate %raw-ref-single)
1432   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1433 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
1434   (:translate %raw-set-single)
1435   (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
1436 (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
1437   (:translate %raw-set-single)
1438   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1439               single-float))
1440 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
1441   (:translate %raw-ref-double)
1442   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1443 (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
1444   (:translate %raw-ref-double)
1445   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1446 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
1447   (:translate %raw-set-double)
1448   (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
1449 (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
1450   (:translate %raw-set-double)
1451   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1452               double-float))
1453 #!+long-float
1454 (define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
1455   (:translate %raw-ref-long)
1456   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1457 #!+long-float
1458 (define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
1459   (:translate %raw-ref-long)
1460   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1461 #!+long-float
1462 (define-vop (raw-set-double data-vector-set/simple-array-long-float)
1463   (:translate %raw-set-long)
1464   (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float))
1465 #!+long-float
1466 (define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
1467   (:translate %raw-set-long)
1468   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1469               long-float))
1470
1471 ;;;; complex-float raw structure slot accessors
1472
1473 (define-vop (raw-ref-complex-single
1474              data-vector-ref/simple-array-complex-single-float)
1475   (:translate %raw-ref-complex-single)
1476   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1477 (define-vop (raw-ref-complex-single-c
1478              data-vector-ref-c/simple-array-complex-single-float)
1479   (:translate %raw-ref-complex-single)
1480   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1481 (define-vop (raw-set-complex-single
1482              data-vector-set/simple-array-complex-single-float)
1483   (:translate %raw-set-complex-single)
1484   (:arg-types simple-array-unsigned-byte-32 positive-fixnum complex-single-float))
1485 (define-vop (raw-set-complex-single-c
1486              data-vector-set-c/simple-array-complex-single-float)
1487   (:translate %raw-set-complex-single)
1488   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1489               complex-single-float))
1490 (define-vop (raw-ref-complex-double
1491              data-vector-ref/simple-array-complex-double-float)
1492   (:translate %raw-ref-complex-double)
1493   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1494 (define-vop (raw-ref-complex-double-c
1495              data-vector-ref-c/simple-array-complex-double-float)
1496   (:translate %raw-ref-complex-double)
1497   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1498 (define-vop (raw-set-complex-double
1499              data-vector-set/simple-array-complex-double-float)
1500   (:translate %raw-set-complex-double)
1501   (:arg-types simple-array-unsigned-byte-32 positive-fixnum
1502               complex-double-float))
1503 (define-vop (raw-set-complex-double-c
1504              data-vector-set-c/simple-array-complex-double-float)
1505   (:translate %raw-set-complex-double)
1506   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1507               complex-double-float))
1508 #!+long-float
1509 (define-vop (raw-ref-complex-long
1510              data-vector-ref/simple-array-complex-long-float)
1511   (:translate %raw-ref-complex-long)
1512   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1513 #!+long-float
1514 (define-vop (raw-ref-complex-long-c
1515              data-vector-ref-c/simple-array-complex-long-float)
1516   (:translate %raw-ref-complex-long)
1517   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1518 #!+long-float
1519 (define-vop (raw-set-complex-long
1520              data-vector-set/simple-array-complex-long-float)
1521   (:translate %raw-set-complex-long)
1522   (:arg-types simple-array-unsigned-byte-32 positive-fixnum
1523               complex-long-float))
1524 #!+long-float
1525 (define-vop (raw-set-complex-long-c
1526              data-vector-set-c/simple-array-complex-long-float)
1527   (:translate %raw-set-complex-long)
1528   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1529               complex-long-float))
1530
1531 ;;; These vops are useful for accessing the bits of a vector
1532 ;;; irrespective of what type of vector it is.
1533 (define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg)
1534   unsigned-num %raw-bits)
1535 (define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
1536   unsigned-num %set-raw-bits)
1537 \f
1538 ;;;; miscellaneous array VOPs
1539
1540 (define-vop (get-vector-subtype get-header-data))
1541 (define-vop (set-vector-subtype set-header-data))