Fix undefined function errors on PPC and MIPS.
[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+offset ,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" type)
136                   ,type vector-data-offset other-pointer-lowtag ,scs
137                   ,element-type data-vector-ref-with-offset)
138                 (define-full-setter+offset ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" type)
139                   ,type vector-data-offset other-pointer-lowtag ,scs
140                   ,element-type data-vector-set-with-offset))))
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-fixnum tagged-num any-reg)
145   (def-full-data-vector-frobs simple-array-unsigned-fixnum 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   #!+sb-unicode
151   (def-full-data-vector-frobs simple-character-string character character-reg))
152
153 (define-full-compare-and-swap %compare-and-swap-svref simple-vector
154   vector-data-offset other-pointer-lowtag
155   (descriptor-reg any-reg) *
156   %compare-and-swap-svref)
157 \f
158 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
159 ;;;; bit, 2-bit, and 4-bit vectors
160
161 (macrolet ((def-small-data-vector-frobs (type bits)
162              (let* ((elements-per-word (floor n-word-bits bits))
163                     (bit-shift (1- (integer-length elements-per-word))))
164     `(progn
165        (define-vop (,(symbolicate 'data-vector-ref-with-offset/ type))
166          (:note "inline array access")
167          (:translate data-vector-ref-with-offset)
168          (:policy :fast-safe)
169          (:args (object :scs (descriptor-reg))
170                 (index :scs (unsigned-reg)))
171          (:info offset)
172          (:arg-types ,type positive-fixnum (:constant (integer 0 0)))
173          (:results (result :scs (unsigned-reg) :from (:argument 0)))
174          (:result-types positive-fixnum)
175          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
176          (:generator 20
177            (aver (zerop offset))
178            (move ecx index)
179            (inst shr ecx ,bit-shift)
180            (inst mov result (make-ea-for-vector-data object :index ecx))
181            (move ecx index)
182            ;; We used to mask ECX for all values of ELEMENT-PER-WORD,
183            ;; but since Intel's documentation says that the chip will
184            ;; mask shift and rotate counts by 31 automatically, we can
185            ;; safely move the masking operation under the protection of
186            ;; this UNLESS in the bit-vector case.  --njf, 2006-07-14
187            ,@(unless (= elements-per-word n-word-bits)
188                `((inst and ecx ,(1- elements-per-word))
189                  (inst shl ecx ,(1- (integer-length bits)))))
190            (inst shr result :cl)
191            (inst and result ,(1- (ash 1 bits)))))
192        (define-vop (,(symbolicate 'data-vector-ref-c-with-offset/ type))
193          (:translate data-vector-ref-with-offset)
194          (:policy :fast-safe)
195          (:args (object :scs (descriptor-reg)))
196          (:arg-types ,type (:constant index) (:constant (integer 0 0)))
197          (:info index offset)
198          (:results (result :scs (unsigned-reg)))
199          (:result-types positive-fixnum)
200          (:generator 15
201            (aver (zerop offset))
202            (multiple-value-bind (word extra) (floor index ,elements-per-word)
203              (loadw result object (+ word vector-data-offset)
204                     other-pointer-lowtag)
205              (unless (zerop extra)
206                (inst shr result (* extra ,bits)))
207              (unless (= extra ,(1- elements-per-word))
208                (inst and result ,(1- (ash 1 bits)))))))
209        (define-vop (,(symbolicate 'data-vector-set-with-offset/ type))
210          (:note "inline array store")
211          (:translate data-vector-set-with-offset)
212          (:policy :fast-safe)
213          (:args (object :scs (descriptor-reg) :to (:argument 2))
214                 (index :scs (unsigned-reg) :target ecx)
215                 (value :scs (unsigned-reg immediate) :target result))
216          (:info offset)
217          (:arg-types ,type positive-fixnum (:constant (integer 0 0))
218                      positive-fixnum)
219          (:results (result :scs (unsigned-reg)))
220          (:result-types positive-fixnum)
221          (:temporary (:sc unsigned-reg) word-index)
222          (:temporary (:sc unsigned-reg) old)
223          (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
224          (:generator 25
225            (aver (zerop offset))
226            (move word-index index)
227            (inst shr word-index ,bit-shift)
228            (inst mov old (make-ea-for-vector-data object :index word-index))
229            (move ecx index)
230            ;; We used to mask ECX for all values of ELEMENT-PER-WORD,
231            ;; but since Intel's documentation says that the chip will
232            ;; mask shift and rotate counts by 31 automatically, we can
233            ;; safely move the masking operation under the protection of
234            ;; this UNLESS in the bit-vector case.  --njf, 2006-07-14
235            ,@(unless (= elements-per-word n-word-bits)
236                `((inst and ecx ,(1- elements-per-word))
237                  (inst shl ecx ,(1- (integer-length bits)))))
238            (inst ror old :cl)
239            (unless (and (sc-is value immediate)
240                         (= (tn-value value) ,(1- (ash 1 bits))))
241              (inst and old ,(lognot (1- (ash 1 bits)))))
242            (sc-case value
243              (immediate
244               (unless (zerop (tn-value value))
245                 (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
246              (unsigned-reg
247               (inst or old value)))
248            (inst rol old :cl)
249            (inst mov (make-ea-for-vector-data object :index word-index)
250                  old)
251            (sc-case value
252              (immediate
253               (inst mov result (tn-value value)))
254              (unsigned-reg
255               (move result value)))))
256        (define-vop (,(symbolicate 'data-vector-set-c-with-offset/ type))
257          (:translate data-vector-set-with-offset)
258          (:policy :fast-safe)
259          (:args (object :scs (descriptor-reg))
260                 (value :scs (unsigned-reg immediate) :target result))
261          (:arg-types ,type (:constant index) (:constant (integer 0 0))
262                      positive-fixnum)
263          (:info index offset)
264          (:results (result :scs (unsigned-reg)))
265          (:result-types positive-fixnum)
266          (:temporary (:sc unsigned-reg :to (:result 0)) old)
267          (:generator 20
268            (aver (zerop offset))
269            (multiple-value-bind (word extra) (floor index ,elements-per-word)
270              (loadw old object (+ word vector-data-offset) other-pointer-lowtag)
271              (sc-case value
272                (immediate
273                 (let* ((value (tn-value value))
274                        (mask ,(1- (ash 1 bits)))
275                        (shift (* extra ,bits)))
276                   (unless (= value mask)
277                     (inst and old (ldb (byte n-word-bits 0)
278                                        (lognot (ash mask shift)))))
279                   (unless (zerop value)
280                     (inst or old (ash value shift)))))
281                (unsigned-reg
282                 (let ((shift (* extra ,bits)))
283                   (unless (zerop shift)
284                     (inst ror old shift))
285                   (inst and old (lognot ,(1- (ash 1 bits))))
286                   (inst or old value)
287                   (unless (zerop shift)
288                     (inst rol old shift)))))
289              (storew old object (+ word vector-data-offset) other-pointer-lowtag)
290              (sc-case value
291                (immediate
292                 (inst mov result (tn-value value)))
293                (unsigned-reg
294                 (move result value))))))))))
295   (def-small-data-vector-frobs simple-bit-vector 1)
296   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
297   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
298
299 ;;; And the float variants.
300
301 (defun make-ea-for-float-ref (object index offset element-size
302                               &key (scale 1) (complex-offset 0))
303   (sc-case index
304     (immediate
305      (make-ea :dword :base object
306               :disp (- (+ (* vector-data-offset n-word-bytes)
307                           (* element-size (+ offset (tn-value index)))
308                           complex-offset)
309                        other-pointer-lowtag)))
310     (t
311      (make-ea :dword :base object :index index :scale scale
312               :disp (- (+ (* vector-data-offset n-word-bytes)
313                           (* element-size offset)
314                           complex-offset)
315                        other-pointer-lowtag)))))
316
317 (define-vop (data-vector-ref-with-offset/simple-array-single-float)
318   (:note "inline array access")
319   (:translate data-vector-ref-with-offset)
320   (:policy :fast-safe)
321   (:args (object :scs (descriptor-reg))
322          (index :scs (any-reg immediate)))
323   (:info offset)
324   (:arg-types simple-array-single-float tagged-num
325               (:constant (constant-displacement other-pointer-lowtag
326                                                 4 vector-data-offset)))
327   (:results (value :scs (single-reg)))
328   (:result-types single-float)
329   (:generator 5
330    (with-empty-tn@fp-top(value)
331      (inst fld (make-ea-for-float-ref object index offset 4)))))
332
333 (define-vop (data-vector-set-with-offset/simple-array-single-float)
334   (:note "inline array store")
335   (:translate data-vector-set-with-offset)
336   (:policy :fast-safe)
337   (:args (object :scs (descriptor-reg))
338          (index :scs (any-reg immediate))
339          (value :scs (single-reg) :target result))
340   (:info offset)
341   (:arg-types simple-array-single-float tagged-num
342               (:constant (constant-displacement other-pointer-lowtag
343                                                 4 vector-data-offset))
344               single-float)
345   (:results (result :scs (single-reg)))
346   (:result-types single-float)
347   (:generator 5
348     (cond ((zerop (tn-offset value))
349            ;; Value is in ST0.
350            (inst fst (make-ea-for-float-ref object index offset 4))
351            (unless (zerop (tn-offset result))
352              ;; Value is in ST0 but not result.
353              (inst fst result)))
354           (t
355            ;; Value is not in ST0.
356            (inst fxch value)
357            (inst fst (make-ea-for-float-ref object index offset 4))
358            (cond ((zerop (tn-offset result))
359                   ;; The result is in ST0.
360                   (inst fst value))
361                  (t
362                   ;; Neither value or result are in ST0
363                   (unless (location= value result)
364                     (inst fst result))
365                   (inst fxch value)))))))
366
367 (define-vop (data-vector-ref-with-offset/simple-array-double-float)
368   (:note "inline array access")
369   (:translate data-vector-ref-with-offset)
370   (:policy :fast-safe)
371   (:args (object :scs (descriptor-reg))
372          (index :scs (any-reg immediate)))
373   (:info offset)
374   (:arg-types simple-array-double-float
375               tagged-num
376               (:constant (constant-displacement other-pointer-lowtag
377                                                 8 vector-data-offset)))
378   (:results (value :scs (double-reg)))
379   (:result-types double-float)
380   (:generator 7
381    (with-empty-tn@fp-top(value)
382      (inst fldd (make-ea-for-float-ref object index offset 8 :scale 2)))))
383
384 (define-vop (data-vector-set-with-offset/simple-array-double-float)
385   (:note "inline array store")
386   (:translate data-vector-set-with-offset)
387   (:policy :fast-safe)
388   (:args (object :scs (descriptor-reg))
389          (index :scs (any-reg immediate))
390          (value :scs (double-reg) :target result))
391   (:info offset)
392   (:arg-types simple-array-double-float tagged-num
393               (:constant (constant-displacement other-pointer-lowtag
394                                                 8 vector-data-offset))
395               double-float)
396   (:results (result :scs (double-reg)))
397   (:result-types double-float)
398   (:generator 20
399     (cond ((zerop (tn-offset value))
400            ;; Value is in ST0.
401            (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2))
402            (unless (zerop (tn-offset result))
403                    ;; Value is in ST0 but not result.
404                    (inst fstd result)))
405           (t
406            ;; Value is not in ST0.
407            (inst fxch value)
408            (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2))
409            (cond ((zerop (tn-offset result))
410                   ;; The result is in ST0.
411                   (inst fstd value))
412                  (t
413                   ;; Neither value or result are in ST0
414                   (unless (location= value result)
415                           (inst fstd result))
416                   (inst fxch value)))))))
417
418 ;;; complex float variants
419
420 (define-vop (data-vector-ref-with-offset/simple-array-complex-single-float)
421   (:note "inline array access")
422   (:translate data-vector-ref-with-offset)
423   (:policy :fast-safe)
424   (:args (object :scs (descriptor-reg))
425          (index :scs (any-reg immediate)))
426   (:info offset)
427   (:arg-types simple-array-complex-single-float tagged-num
428               (:constant (constant-displacement other-pointer-lowtag
429                                                 8 vector-data-offset)))
430   (:results (value :scs (complex-single-reg)))
431   (:result-types complex-single-float)
432   (:generator 5
433     (let ((real-tn (complex-single-reg-real-tn value)))
434       (with-empty-tn@fp-top (real-tn)
435         (inst fld (make-ea-for-float-ref object index offset 8 :scale 2))))
436     (let ((imag-tn (complex-single-reg-imag-tn value)))
437       (with-empty-tn@fp-top (imag-tn)
438         ;; FIXME
439         (inst fld (make-ea-for-float-ref object index offset 8
440                                          :scale 2 :complex-offset 4))))))
441
442 (define-vop (data-vector-set-with-offset/simple-array-complex-single-float)
443   (:note "inline array store")
444   (:translate data-vector-set-with-offset)
445   (:policy :fast-safe)
446   (:args (object :scs (descriptor-reg))
447          (index :scs (any-reg immediate))
448          (value :scs (complex-single-reg) :target result))
449   (:info offset)
450   (:arg-types simple-array-complex-single-float tagged-num
451               (:constant (constant-displacement other-pointer-lowtag
452                                                 8 vector-data-offset))
453               complex-single-float)
454   (:results (result :scs (complex-single-reg)))
455   (:result-types complex-single-float)
456   (:generator 5
457     (let ((value-real (complex-single-reg-real-tn value))
458           (result-real (complex-single-reg-real-tn result)))
459       (cond ((zerop (tn-offset value-real))
460              ;; Value is in ST0.
461              (inst fst (make-ea-for-float-ref object index offset 8 :scale 2))
462              (unless (zerop (tn-offset result-real))
463                ;; Value is in ST0 but not result.
464                (inst fst result-real)))
465             (t
466              ;; Value is not in ST0.
467              (inst fxch value-real)
468              (inst fst (make-ea-for-float-ref object index offset 8 :scale 2))
469              (cond ((zerop (tn-offset result-real))
470                     ;; The result is in ST0.
471                     (inst fst value-real))
472                    (t
473                     ;; Neither value or result are in ST0
474                     (unless (location= value-real result-real)
475                       (inst fst result-real))
476                     (inst fxch value-real))))))
477     (let ((value-imag (complex-single-reg-imag-tn value))
478           (result-imag (complex-single-reg-imag-tn result)))
479       (inst fxch value-imag)
480       (inst fst (make-ea-for-float-ref object index offset 8
481                                        :scale 2 :complex-offset 4))
482       (unless (location= value-imag result-imag)
483         (inst fst result-imag))
484       (inst fxch value-imag))))
485
486 (define-vop (data-vector-ref-with-offset/simple-array-complex-double-float)
487   (:note "inline array access")
488   (:translate data-vector-ref-with-offset)
489   (:policy :fast-safe)
490   (:args (object :scs (descriptor-reg))
491          (index :scs (any-reg immediate)))
492   (:info offset)
493   (:arg-types simple-array-complex-double-float tagged-num
494               (:constant (constant-displacement other-pointer-lowtag
495                                                 16 vector-data-offset)))
496   (:results (value :scs (complex-double-reg)))
497   (:result-types complex-double-float)
498   (:generator 7
499     (let ((real-tn (complex-double-reg-real-tn value)))
500       (with-empty-tn@fp-top (real-tn)
501         (inst fldd (make-ea-for-float-ref object index offset 16 :scale 4)))
502     (let ((imag-tn (complex-double-reg-imag-tn value)))
503       (with-empty-tn@fp-top (imag-tn)
504         (inst fldd (make-ea-for-float-ref object index offset 16
505                                           :scale 4 :complex-offset 8)))))))
506
507 (define-vop (data-vector-set-with-offset/simple-array-complex-double-float)
508   (:note "inline array store")
509   (:translate data-vector-set-with-offset)
510   (:policy :fast-safe)
511   (:args (object :scs (descriptor-reg))
512          (index :scs (any-reg immediate))
513          (value :scs (complex-double-reg) :target result))
514   (:info offset)
515   (:arg-types simple-array-complex-double-float tagged-num
516               (:constant (constant-displacement other-pointer-lowtag
517                                                 16 vector-data-offset))
518               complex-double-float)
519   (:results (result :scs (complex-double-reg)))
520   (:result-types complex-double-float)
521   (:generator 20
522     (let ((value-real (complex-double-reg-real-tn value))
523           (result-real (complex-double-reg-real-tn result)))
524       (cond ((zerop (tn-offset value-real))
525              ;; Value is in ST0.
526              (inst fstd (make-ea-for-float-ref object index offset 16
527                                                :scale 4))
528              (unless (zerop (tn-offset result-real))
529                ;; Value is in ST0 but not result.
530                (inst fstd result-real)))
531             (t
532              ;; Value is not in ST0.
533              (inst fxch value-real)
534              (inst fstd (make-ea-for-float-ref object index offset 16
535                                                :scale 4))
536              (cond ((zerop (tn-offset result-real))
537                     ;; The result is in ST0.
538                     (inst fstd value-real))
539                    (t
540                     ;; Neither value or result are in ST0
541                     (unless (location= value-real result-real)
542                       (inst fstd result-real))
543                     (inst fxch value-real))))))
544     (let ((value-imag (complex-double-reg-imag-tn value))
545           (result-imag (complex-double-reg-imag-tn result)))
546       (inst fxch value-imag)
547       (inst fstd (make-ea-for-float-ref object index offset 16
548                                         :scale 4 :complex-offset 8))
549       (unless (location= value-imag result-imag)
550         (inst fstd result-imag))
551       (inst fxch value-imag))))
552
553 \f
554 ;;; {un,}signed-byte-8, simple-base-string
555
556 (macrolet ((define-data-vector-frobs (ptype element-type ref-inst
557                                             8-bit-tns-p &rest scs)
558   `(progn
559     (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype))
560       (:translate data-vector-ref-with-offset)
561       (:policy :fast-safe)
562       (:args (object :scs (descriptor-reg))
563              (index :scs (signed-reg immediate)))
564       (:info offset)
565       (:arg-types ,ptype tagged-num
566                   (:constant (constant-displacement other-pointer-lowtag
567                                                     1 vector-data-offset)))
568       (:results (value :scs ,scs))
569       (:result-types ,element-type)
570       (:generator 5
571         (sc-case index
572           (immediate
573            (inst ,ref-inst value (make-ea-for-vector-data
574                                   object :size :byte
575                                   :offset (+ (tn-value index) offset))))
576           (t
577            (inst ,ref-inst value
578                  (make-ea-for-vector-data object :size :byte
579                                           :index index :offset offset))))))
580     (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype))
581       (:translate data-vector-set-with-offset)
582       (:policy :fast-safe)
583       (:args (object :scs (descriptor-reg) :to (:eval 0))
584              (index :scs (signed-reg immediate) :to (:eval 0))
585              (value :scs ,scs ,@(unless 8-bit-tns-p
586                                   '(:target eax))))
587       (:info offset)
588       (:arg-types ,ptype tagged-num
589                   (:constant (constant-displacement other-pointer-lowtag
590                                                     1 vector-data-offset))
591                   ,element-type)
592       ,@(unless 8-bit-tns-p
593          '((:temporary (:sc unsigned-reg :offset eax-offset :target result
594                         :from (:argument 2) :to (:result 0))
595             eax)))
596       (:results (result :scs ,scs))
597       (:result-types ,element-type)
598       (:generator 5
599         ,@(unless 8-bit-tns-p
600            '((move eax value)))
601         (sc-case index
602           (immediate
603            (inst mov (make-ea-for-vector-data
604                       object :size :byte :offset (+ (tn-value index) offset))
605                  ,(if 8-bit-tns-p
606                       'value
607                       'al-tn)))
608           (t
609            (inst mov (make-ea-for-vector-data object :size :byte
610                                               :index index :offset offset)
611                  ,(if 8-bit-tns-p
612                       'value
613                       'al-tn))))
614         (move result ,(if 8-bit-tns-p
615                           'value
616                           'eax)))))))
617   (define-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
618     movzx nil unsigned-reg signed-reg)
619   (define-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
620     movzx nil unsigned-reg signed-reg)
621   (define-data-vector-frobs simple-array-signed-byte-8 tagged-num
622     movsx nil signed-reg)
623   (define-data-vector-frobs simple-base-string character
624                             #!+sb-unicode movzx #!-sb-unicode mov
625                             #!+sb-unicode nil #!-sb-unicode t character-reg))
626
627 ;;; {un,}signed-byte-16
628 (macrolet ((define-data-vector-frobs (ptype element-type ref-inst &rest scs)
629     `(progn
630       (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype))
631         (:translate data-vector-ref-with-offset)
632         (:policy :fast-safe)
633         (:args (object :scs (descriptor-reg))
634                (index :scs (signed-reg immediate)))
635         (:info offset)
636         (:arg-types ,ptype tagged-num
637                     (:constant (constant-displacement other-pointer-lowtag
638                                                       2 vector-data-offset)))
639         (:results (value :scs ,scs))
640         (:result-types ,element-type)
641         (:generator 5
642           (sc-case index
643             (immediate
644              (inst ,ref-inst value
645                    (make-ea-for-vector-data object :size :word
646                                             :offset (+ (tn-value index) offset))))
647             (t
648              (inst ,ref-inst value
649                    (make-ea-for-vector-data object :size :word
650                                             :index index :offset offset))))))
651       (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype))
652         (:translate data-vector-set-with-offset)
653         (:policy :fast-safe)
654         (:args (object :scs (descriptor-reg) :to (:eval 0))
655                (index :scs (signed-reg immediate) :to (:eval 0))
656                (value :scs ,scs :target eax))
657         (:info offset)
658         (:arg-types ,ptype tagged-num
659                     (:constant (constant-displacement other-pointer-lowtag
660                                                       2 vector-data-offset))
661                     ,element-type)
662         (:temporary (:sc unsigned-reg :offset eax-offset :target result
663                          :from (:argument 2) :to (:result 0))
664                     eax)
665         (:results (result :scs ,scs))
666         (:result-types ,element-type)
667         (:generator 5
668           (move eax value)
669           (sc-case index
670             (immediate
671              (inst mov (make-ea-for-vector-data
672                         object :size :word :offset (+ (tn-value index) offset))
673                    ax-tn))
674             (t
675              (inst mov (make-ea-for-vector-data object :size :word
676                                                 :index index :offset offset)
677                    ax-tn)))
678           (move result eax))))))
679   (define-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
680     movzx unsigned-reg signed-reg)
681   (define-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
682     movzx unsigned-reg signed-reg)
683   (define-data-vector-frobs simple-array-signed-byte-16 tagged-num
684     movsx signed-reg))
685
686 \f
687 ;;; These vops are useful for accessing the bits of a vector
688 ;;; irrespective of what type of vector it is.
689 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
690  (unsigned-reg) unsigned-num %vector-raw-bits)
691 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
692  (unsigned-reg) unsigned-num %set-vector-raw-bits)
693
694 \f
695 ;;;; miscellaneous array VOPs
696
697 (define-vop (get-vector-subtype get-header-data))
698 (define-vop (set-vector-subtype set-header-data))
699 \f
700 ;;;; ATOMIC-INCF for arrays
701
702 (define-vop (array-atomic-incf/word)
703   (:translate %array-atomic-incf/word)
704   (:policy :fast-safe)
705   (:args (array :scs (descriptor-reg))
706          (index :scs (any-reg))
707          (diff :scs (unsigned-reg) :target result))
708   (:arg-types * positive-fixnum unsigned-num)
709   (:results (result :scs (unsigned-reg)))
710   (:result-types unsigned-num)
711   (:generator 4
712     (inst xadd (make-ea :dword :base array
713                         :scale 1 :index index
714                         :disp (- (* vector-data-offset n-word-bytes)
715                                  other-pointer-lowtag))
716           diff :lock)
717     (move result diff)))