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 positive-fixnum
 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 positive-fixnum
 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               positive-fixnum
 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 positive-fixnum
 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 positive-fixnum
 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 positive-fixnum
 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 positive-fixnum
 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 positive-fixnum
 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 (unsigned-reg immediate)))
 564       (:info offset)
 565       (:arg-types ,ptype positive-fixnum
 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 (unsigned-reg immediate) :to (:eval 0))
 585              (value :scs ,scs ,@(unless 8-bit-tns-p
 586                                   '(:target eax))))
 587       (:info offset)
 588       (:arg-types ,ptype positive-fixnum
 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 (unsigned-reg immediate)))
 635         (:info offset)
 636         (:arg-types ,ptype positive-fixnum
 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 (unsigned-reg immediate) :to (:eval 0))
 656                (value :scs ,scs :target eax))
 657         (:info offset)
 658         (:arg-types ,ptype positive-fixnum
 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)))