src/compiler/x86/array.lisp

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