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 (ldb (byte n-word-bits 0)
 264                                        (lognot (ash mask shift)))))
 265                   (unless (zerop value)
 266                     (inst or old (ash value shift)))))
 267                (unsigned-reg
 268                 (let ((shift (* extra ,bits)))
 269                   (unless (zerop shift)
 270                     (inst ror old shift))
 271                   (inst and old (lognot ,(1- (ash 1 bits))))
 272                   (inst or old value)
 273                   (unless (zerop shift)
 274                     (inst rol old shift)))))
 275              (inst mov (make-ea :dword :base object
 276                                 :disp (- (* (+ word vector-data-offset)
 277                                             n-word-bytes)
 278                                          other-pointer-lowtag))
 279                    old)
 280              (sc-case value
 281                (immediate
 282                 (inst mov result (tn-value value)))
 283                (unsigned-reg
 284                 (move result value))))))))))
 285   (def-small-data-vector-frobs simple-bit-vector 1)
 286   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 287   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 288
 289 ;;; And the float variants.
 290
 291 (define-vop (data-vector-ref/simple-array-single-float)
 292   (:note "inline array access")
 293   (:translate data-vector-ref)
 294   (:policy :fast-safe)
 295   (:args (object :scs (descriptor-reg))
 296          (index :scs (any-reg)))
 297   (:arg-types simple-array-single-float positive-fixnum)
 298   (:results (value :scs (single-reg)))
 299   (:result-types single-float)
 300   (:generator 5
 301    (with-empty-tn@fp-top(value)
 302      (inst fld (make-ea :dword :base object :index index :scale 1
 303                         :disp (- (* vector-data-offset
 304                                     n-word-bytes)
 305                                  other-pointer-lowtag))))))
 306
 307 (define-vop (data-vector-ref-c/simple-array-single-float)
 308   (:note "inline array access")
 309   (:translate data-vector-ref)
 310   (:policy :fast-safe)
 311   (:args (object :scs (descriptor-reg)))
 312   (:info index)
 313   (:arg-types simple-array-single-float (:constant (signed-byte 30)))
 314   (:results (value :scs (single-reg)))
 315   (:result-types single-float)
 316   (:generator 4
 317    (with-empty-tn@fp-top(value)
 318      (inst fld (make-ea :dword :base object
 319                         :disp (- (+ (* vector-data-offset
 320                                        n-word-bytes)
 321                                     (* 4 index))
 322                                  other-pointer-lowtag))))))
 323
 324 (define-vop (data-vector-set/simple-array-single-float)
 325   (:note "inline array store")
 326   (:translate data-vector-set)
 327   (:policy :fast-safe)
 328   (:args (object :scs (descriptor-reg))
 329          (index :scs (any-reg))
 330          (value :scs (single-reg) :target result))
 331   (:arg-types simple-array-single-float positive-fixnum single-float)
 332   (:results (result :scs (single-reg)))
 333   (:result-types single-float)
 334   (:generator 5
 335     (cond ((zerop (tn-offset value))
 336            ;; Value is in ST0.
 337            (inst fst (make-ea :dword :base object :index index :scale 1
 338                               :disp (- (* vector-data-offset
 339                                           n-word-bytes)
 340                                        other-pointer-lowtag)))
 341            (unless (zerop (tn-offset result))
 342                    ;; Value is in ST0 but not result.
 343                    (inst fst result)))
 344           (t
 345            ;; Value is not in ST0.
 346            (inst fxch value)
 347            (inst fst (make-ea :dword :base object :index index :scale 1
 348                               :disp (- (* vector-data-offset
 349                                           n-word-bytes)
 350                                        other-pointer-lowtag)))
 351            (cond ((zerop (tn-offset result))
 352                   ;; The result is in ST0.
 353                   (inst fst value))
 354                  (t
 355                   ;; Neither value or result are in ST0
 356                   (unless (location= value result)
 357                           (inst fst result))
 358                   (inst fxch value)))))))
 359
 360 (define-vop (data-vector-set-c/simple-array-single-float)
 361   (:note "inline array store")
 362   (:translate data-vector-set)
 363   (:policy :fast-safe)
 364   (:args (object :scs (descriptor-reg))
 365          (value :scs (single-reg) :target result))
 366   (:info index)
 367   (:arg-types simple-array-single-float (:constant (signed-byte 30))
 368               single-float)
 369   (:results (result :scs (single-reg)))
 370   (:result-types single-float)
 371   (:generator 4
 372     (cond ((zerop (tn-offset value))
 373            ;; Value is in ST0.
 374            (inst fst (make-ea :dword :base object
 375                               :disp (- (+ (* vector-data-offset
 376                                              n-word-bytes)
 377                                           (* 4 index))
 378                                        other-pointer-lowtag)))
 379            (unless (zerop (tn-offset result))
 380                    ;; Value is in ST0 but not result.
 381                    (inst fst result)))
 382           (t
 383            ;; Value is not in ST0.
 384            (inst fxch value)
 385            (inst fst (make-ea :dword :base object
 386                               :disp (- (+ (* vector-data-offset
 387                                              n-word-bytes)
 388                                           (* 4 index))
 389                                        other-pointer-lowtag)))
 390            (cond ((zerop (tn-offset result))
 391                   ;; The result is in ST0.
 392                   (inst fst value))
 393                  (t
 394                   ;; Neither value or result are in ST0
 395                   (unless (location= value result)
 396                           (inst fst result))
 397                   (inst fxch value)))))))
 398
 399 (define-vop (data-vector-ref/simple-array-double-float)
 400   (:note "inline array access")
 401   (:translate data-vector-ref)
 402   (:policy :fast-safe)
 403   (:args (object :scs (descriptor-reg))
 404          (index :scs (any-reg)))
 405   (:arg-types simple-array-double-float positive-fixnum)
 406   (:results (value :scs (double-reg)))
 407   (:result-types double-float)
 408   (:generator 7
 409    (with-empty-tn@fp-top(value)
 410      (inst fldd (make-ea :dword :base object :index index :scale 2
 411                          :disp (- (* vector-data-offset
 412                                      n-word-bytes)
 413                                   other-pointer-lowtag))))))
 414
 415 (define-vop (data-vector-ref-c/simple-array-double-float)
 416   (:note "inline array access")
 417   (:translate data-vector-ref)
 418   (:policy :fast-safe)
 419   (:args (object :scs (descriptor-reg)))
 420   (:info index)
 421   (:arg-types simple-array-double-float (:constant (signed-byte 30)))
 422   (:results (value :scs (double-reg)))
 423   (:result-types double-float)
 424   (:generator 6
 425    (with-empty-tn@fp-top(value)
 426      (inst fldd (make-ea :dword :base object
 427                          :disp (- (+ (* vector-data-offset
 428                                         n-word-bytes)
 429                                      (* 8 index))
 430                                   other-pointer-lowtag))))))
 431
 432 (define-vop (data-vector-set/simple-array-double-float)
 433   (:note "inline array store")
 434   (:translate data-vector-set)
 435   (:policy :fast-safe)
 436   (:args (object :scs (descriptor-reg))
 437          (index :scs (any-reg))
 438          (value :scs (double-reg) :target result))
 439   (:arg-types simple-array-double-float positive-fixnum double-float)
 440   (:results (result :scs (double-reg)))
 441   (:result-types double-float)
 442   (:generator 20
 443     (cond ((zerop (tn-offset value))
 444            ;; Value is in ST0.
 445            (inst fstd (make-ea :dword :base object :index index :scale 2
 446                                :disp (- (* vector-data-offset
 447                                            n-word-bytes)
 448                                         other-pointer-lowtag)))
 449            (unless (zerop (tn-offset result))
 450                    ;; Value is in ST0 but not result.
 451                    (inst fstd result)))
 452           (t
 453            ;; Value is not in ST0.
 454            (inst fxch value)
 455            (inst fstd (make-ea :dword :base object :index index :scale 2
 456                                :disp (- (* vector-data-offset
 457                                            n-word-bytes)
 458                                         other-pointer-lowtag)))
 459            (cond ((zerop (tn-offset result))
 460                   ;; The result is in ST0.
 461                   (inst fstd value))
 462                  (t
 463                   ;; Neither value or result are in ST0
 464                   (unless (location= value result)
 465                           (inst fstd result))
 466                   (inst fxch value)))))))
 467
 468 (define-vop (data-vector-set-c/simple-array-double-float)
 469   (:note "inline array store")
 470   (:translate data-vector-set)
 471   (:policy :fast-safe)
 472   (:args (object :scs (descriptor-reg))
 473          (value :scs (double-reg) :target result))
 474   (:info index)
 475   (:arg-types simple-array-double-float (:constant (signed-byte 30))
 476               double-float)
 477   (:results (result :scs (double-reg)))
 478   (:result-types double-float)
 479   (:generator 19
 480     (cond ((zerop (tn-offset value))
 481            ;; Value is in ST0.
 482            (inst fstd (make-ea :dword :base object
 483                                :disp (- (+ (* vector-data-offset
 484                                               n-word-bytes)
 485                                            (* 8 index))
 486                                         other-pointer-lowtag)))
 487            (unless (zerop (tn-offset result))
 488                    ;; Value is in ST0 but not result.
 489                    (inst fstd result)))
 490           (t
 491            ;; Value is not in ST0.
 492            (inst fxch value)
 493            (inst fstd (make-ea :dword :base object
 494                                :disp (- (+ (* vector-data-offset
 495                                               n-word-bytes)
 496                                            (* 8 index))
 497                                         other-pointer-lowtag)))
 498            (cond ((zerop (tn-offset result))
 499                   ;; The result is in ST0.
 500                   (inst fstd value))
 501                  (t
 502                   ;; Neither value or result are in ST0
 503                   (unless (location= value result)
 504                           (inst fstd result))
 505                   (inst fxch value)))))))
 506
 507
 508
 509 ;;; complex float variants
 510
 511 (define-vop (data-vector-ref/simple-array-complex-single-float)
 512   (:note "inline array access")
 513   (:translate data-vector-ref)
 514   (:policy :fast-safe)
 515   (:args (object :scs (descriptor-reg))
 516          (index :scs (any-reg)))
 517   (:arg-types simple-array-complex-single-float positive-fixnum)
 518   (:results (value :scs (complex-single-reg)))
 519   (:result-types complex-single-float)
 520   (:generator 5
 521     (let ((real-tn (complex-single-reg-real-tn value)))
 522       (with-empty-tn@fp-top (real-tn)
 523         (inst fld (make-ea :dword :base object :index index :scale 2
 524                            :disp (- (* vector-data-offset
 525                                        n-word-bytes)
 526                                     other-pointer-lowtag)))))
 527     (let ((imag-tn (complex-single-reg-imag-tn value)))
 528       (with-empty-tn@fp-top (imag-tn)
 529         (inst fld (make-ea :dword :base object :index index :scale 2
 530                            :disp (- (* (1+ vector-data-offset)
 531                                        n-word-bytes)
 532                                     other-pointer-lowtag)))))))
 533
 534 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
 535   (:note "inline array access")
 536   (:translate data-vector-ref)
 537   (:policy :fast-safe)
 538   (:args (object :scs (descriptor-reg)))
 539   (:info index)
 540   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
 541   (:results (value :scs (complex-single-reg)))
 542   (:result-types complex-single-float)
 543   (:generator 4
 544     (let ((real-tn (complex-single-reg-real-tn value)))
 545       (with-empty-tn@fp-top (real-tn)
 546         (inst fld (make-ea :dword :base object
 547                            :disp (- (+ (* vector-data-offset
 548                                           n-word-bytes)
 549                                        (* 8 index))
 550                                     other-pointer-lowtag)))))
 551     (let ((imag-tn (complex-single-reg-imag-tn value)))
 552       (with-empty-tn@fp-top (imag-tn)
 553         (inst fld (make-ea :dword :base object
 554                            :disp (- (+ (* vector-data-offset
 555                                           n-word-bytes)
 556                                        (* 8 index) 4)
 557                                     other-pointer-lowtag)))))))
 558
 559 (define-vop (data-vector-set/simple-array-complex-single-float)
 560   (:note "inline array store")
 561   (:translate data-vector-set)
 562   (:policy :fast-safe)
 563   (:args (object :scs (descriptor-reg))
 564          (index :scs (any-reg))
 565          (value :scs (complex-single-reg) :target result))
 566   (:arg-types simple-array-complex-single-float positive-fixnum
 567               complex-single-float)
 568   (:results (result :scs (complex-single-reg)))
 569   (:result-types complex-single-float)
 570   (:generator 5
 571     (let ((value-real (complex-single-reg-real-tn value))
 572           (result-real (complex-single-reg-real-tn result)))
 573       (cond ((zerop (tn-offset value-real))
 574              ;; Value is in ST0.
 575              (inst fst (make-ea :dword :base object :index index :scale 2
 576                                 :disp (- (* vector-data-offset
 577                                             n-word-bytes)
 578                                          other-pointer-lowtag)))
 579              (unless (zerop (tn-offset result-real))
 580                ;; Value is in ST0 but not result.
 581                (inst fst result-real)))
 582             (t
 583              ;; Value is not in ST0.
 584              (inst fxch value-real)
 585              (inst fst (make-ea :dword :base object :index index :scale 2
 586                                 :disp (- (* vector-data-offset
 587                                             n-word-bytes)
 588                                          other-pointer-lowtag)))
 589              (cond ((zerop (tn-offset result-real))
 590                     ;; The result is in ST0.
 591                     (inst fst value-real))
 592                    (t
 593                     ;; Neither value or result are in ST0
 594                     (unless (location= value-real result-real)
 595                       (inst fst result-real))
 596                     (inst fxch value-real))))))
 597     (let ((value-imag (complex-single-reg-imag-tn value))
 598           (result-imag (complex-single-reg-imag-tn result)))
 599       (inst fxch value-imag)
 600       (inst fst (make-ea :dword :base object :index index :scale 2
 601                          :disp (- (+ (* vector-data-offset
 602                                         n-word-bytes)
 603                                      4)
 604                                   other-pointer-lowtag)))
 605       (unless (location= value-imag result-imag)
 606         (inst fst result-imag))
 607       (inst fxch value-imag))))
 608
 609 (define-vop (data-vector-set-c/simple-array-complex-single-float)
 610   (:note "inline array store")
 611   (:translate data-vector-set)
 612   (:policy :fast-safe)
 613   (:args (object :scs (descriptor-reg))
 614          (value :scs (complex-single-reg) :target result))
 615   (:info index)
 616   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
 617               complex-single-float)
 618   (:results (result :scs (complex-single-reg)))
 619   (:result-types complex-single-float)
 620   (:generator 4
 621     (let ((value-real (complex-single-reg-real-tn value))
 622           (result-real (complex-single-reg-real-tn result)))
 623       (cond ((zerop (tn-offset value-real))
 624              ;; Value is in ST0.
 625              (inst fst (make-ea :dword :base object
 626                                 :disp (- (+ (* vector-data-offset
 627                                                n-word-bytes)
 628                                             (* 8 index))
 629                                          other-pointer-lowtag)))
 630              (unless (zerop (tn-offset result-real))
 631                ;; Value is in ST0 but not result.
 632                (inst fst result-real)))
 633             (t
 634              ;; Value is not in ST0.
 635              (inst fxch value-real)
 636              (inst fst (make-ea :dword :base object
 637                                 :disp (- (+ (* vector-data-offset
 638                                                n-word-bytes)
 639                                             (* 8 index))
 640                                          other-pointer-lowtag)))
 641              (cond ((zerop (tn-offset result-real))
 642                     ;; The result is in ST0.
 643                     (inst fst value-real))
 644                    (t
 645                     ;; Neither value or result are in ST0
 646                     (unless (location= value-real result-real)
 647                       (inst fst result-real))
 648                     (inst fxch value-real))))))
 649     (let ((value-imag (complex-single-reg-imag-tn value))
 650           (result-imag (complex-single-reg-imag-tn result)))
 651       (inst fxch value-imag)
 652       (inst fst (make-ea :dword :base object
 653                          :disp (- (+ (* vector-data-offset
 654                                         n-word-bytes)
 655                                      (* 8 index) 4)
 656                                   other-pointer-lowtag)))
 657       (unless (location= value-imag result-imag)
 658         (inst fst result-imag))
 659       (inst fxch value-imag))))
 660
 661
 662 (define-vop (data-vector-ref/simple-array-complex-double-float)
 663   (:note "inline array access")
 664   (:translate data-vector-ref)
 665   (:policy :fast-safe)
 666   (:args (object :scs (descriptor-reg))
 667          (index :scs (any-reg)))
 668   (:arg-types simple-array-complex-double-float positive-fixnum)
 669   (:results (value :scs (complex-double-reg)))
 670   (:result-types complex-double-float)
 671   (:generator 7
 672     (let ((real-tn (complex-double-reg-real-tn value)))
 673       (with-empty-tn@fp-top (real-tn)
 674         (inst fldd (make-ea :dword :base object :index index :scale 4
 675                             :disp (- (* vector-data-offset
 676                                         n-word-bytes)
 677                                      other-pointer-lowtag)))))
 678     (let ((imag-tn (complex-double-reg-imag-tn value)))
 679       (with-empty-tn@fp-top (imag-tn)
 680         (inst fldd (make-ea :dword :base object :index index :scale 4
 681                             :disp (- (+ (* vector-data-offset
 682                                            n-word-bytes)
 683                                         8)
 684                                      other-pointer-lowtag)))))))
 685
 686 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
 687   (:note "inline array access")
 688   (:translate data-vector-ref)
 689   (:policy :fast-safe)
 690   (:args (object :scs (descriptor-reg)))
 691   (:info index)
 692   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
 693   (:results (value :scs (complex-double-reg)))
 694   (:result-types complex-double-float)
 695   (:generator 6
 696     (let ((real-tn (complex-double-reg-real-tn value)))
 697       (with-empty-tn@fp-top (real-tn)
 698         (inst fldd (make-ea :dword :base object
 699                             :disp (- (+ (* vector-data-offset
 700                                            n-word-bytes)
 701                                         (* 16 index))
 702                                      other-pointer-lowtag)))))
 703     (let ((imag-tn (complex-double-reg-imag-tn value)))
 704       (with-empty-tn@fp-top (imag-tn)
 705         (inst fldd (make-ea :dword :base object
 706                             :disp (- (+ (* vector-data-offset
 707                                            n-word-bytes)
 708                                         (* 16 index) 8)
 709                                      other-pointer-lowtag)))))))
 710
 711 (define-vop (data-vector-set/simple-array-complex-double-float)
 712   (:note "inline array store")
 713   (:translate data-vector-set)
 714   (:policy :fast-safe)
 715   (:args (object :scs (descriptor-reg))
 716          (index :scs (any-reg))
 717          (value :scs (complex-double-reg) :target result))
 718   (:arg-types simple-array-complex-double-float positive-fixnum
 719               complex-double-float)
 720   (:results (result :scs (complex-double-reg)))
 721   (:result-types complex-double-float)
 722   (:generator 20
 723     (let ((value-real (complex-double-reg-real-tn value))
 724           (result-real (complex-double-reg-real-tn result)))
 725       (cond ((zerop (tn-offset value-real))
 726              ;; Value is in ST0.
 727              (inst fstd (make-ea :dword :base object :index index :scale 4
 728                                  :disp (- (* vector-data-offset
 729                                              n-word-bytes)
 730                                           other-pointer-lowtag)))
 731              (unless (zerop (tn-offset result-real))
 732                ;; Value is in ST0 but not result.
 733                (inst fstd result-real)))
 734             (t
 735              ;; Value is not in ST0.
 736              (inst fxch value-real)
 737              (inst fstd (make-ea :dword :base object :index index :scale 4
 738                                  :disp (- (* vector-data-offset
 739                                              n-word-bytes)
 740                                           other-pointer-lowtag)))
 741              (cond ((zerop (tn-offset result-real))
 742                     ;; The result is in ST0.
 743                     (inst fstd value-real))
 744                    (t
 745                     ;; Neither value or result are in ST0
 746                     (unless (location= value-real result-real)
 747                       (inst fstd result-real))
 748                     (inst fxch value-real))))))
 749     (let ((value-imag (complex-double-reg-imag-tn value))
 750           (result-imag (complex-double-reg-imag-tn result)))
 751       (inst fxch value-imag)
 752       (inst fstd (make-ea :dword :base object :index index :scale 4
 753                           :disp (- (+ (* vector-data-offset
 754                                          n-word-bytes)
 755                                       8)
 756                                    other-pointer-lowtag)))
 757       (unless (location= value-imag result-imag)
 758         (inst fstd result-imag))
 759       (inst fxch value-imag))))
 760
 761 (define-vop (data-vector-set-c/simple-array-complex-double-float)
 762   (:note "inline array store")
 763   (:translate data-vector-set)
 764   (:policy :fast-safe)
 765   (:args (object :scs (descriptor-reg))
 766          (value :scs (complex-double-reg) :target result))
 767   (:info index)
 768   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
 769               complex-double-float)
 770   (:results (result :scs (complex-double-reg)))
 771   (:result-types complex-double-float)
 772   (:generator 19
 773     (let ((value-real (complex-double-reg-real-tn value))
 774           (result-real (complex-double-reg-real-tn result)))
 775       (cond ((zerop (tn-offset value-real))
 776              ;; Value is in ST0.
 777              (inst fstd (make-ea :dword :base object
 778                                  :disp (- (+ (* vector-data-offset
 779                                                 n-word-bytes)
 780                                              (* 16 index))
 781                                           other-pointer-lowtag)))
 782              (unless (zerop (tn-offset result-real))
 783                ;; Value is in ST0 but not result.
 784                (inst fstd result-real)))
 785             (t
 786              ;; Value is not in ST0.
 787              (inst fxch value-real)
 788              (inst fstd (make-ea :dword :base object
 789                                  :disp (- (+ (* vector-data-offset
 790                                                 n-word-bytes)
 791                                              (* 16 index))
 792                                           other-pointer-lowtag)))
 793              (cond ((zerop (tn-offset result-real))
 794                     ;; The result is in ST0.
 795                     (inst fstd value-real))
 796                    (t
 797                     ;; Neither value or result are in ST0
 798                     (unless (location= value-real result-real)
 799                       (inst fstd result-real))
 800                     (inst fxch value-real))))))
 801     (let ((value-imag (complex-double-reg-imag-tn value))
 802           (result-imag (complex-double-reg-imag-tn result)))
 803       (inst fxch value-imag)
 804       (inst fstd (make-ea :dword :base object
 805                           :disp (- (+ (* vector-data-offset
 806                                          n-word-bytes)
 807                                       (* 16 index) 8)
 808                                    other-pointer-lowtag)))
 809       (unless (location= value-imag result-imag)
 810         (inst fstd result-imag))
 811       (inst fxch value-imag))))
 812
 813
 814
 815 \f
 816 ;;; unsigned-byte-8
 817 (macrolet ((define-data-vector-frobs (ptype)
 818   `(progn
 819     (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
 820       (:translate data-vector-ref)
 821       (:policy :fast-safe)
 822       (:args (object :scs (descriptor-reg))
 823              (index :scs (unsigned-reg)))
 824       (:arg-types ,ptype positive-fixnum)
 825       (:results (value :scs (unsigned-reg signed-reg)))
 826       (:result-types positive-fixnum)
 827       (:generator 5
 828         (inst movzx value
 829               (make-ea :byte :base object :index index :scale 1
 830                        :disp (- (* vector-data-offset n-word-bytes)
 831                                 other-pointer-lowtag)))))
 832     (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
 833       (:translate data-vector-ref)
 834       (:policy :fast-safe)
 835       (:args (object :scs (descriptor-reg)))
 836       (:info index)
 837       (:arg-types ,ptype (:constant (signed-byte 30)))
 838       (:results (value :scs (unsigned-reg signed-reg)))
 839       (:result-types positive-fixnum)
 840       (:generator 4
 841         (inst movzx value
 842               (make-ea :byte :base object
 843                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
 844                                 other-pointer-lowtag)))))
 845     (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
 846       (:translate data-vector-set)
 847       (:policy :fast-safe)
 848       (:args (object :scs (descriptor-reg) :to (:eval 0))
 849              (index :scs (unsigned-reg) :to (:eval 0))
 850              (value :scs (unsigned-reg signed-reg) :target eax))
 851       (:arg-types ,ptype positive-fixnum positive-fixnum)
 852       (:temporary (:sc unsigned-reg :offset eax-offset :target result
 853                        :from (:argument 2) :to (:result 0))
 854                   eax)
 855       (:results (result :scs (unsigned-reg signed-reg)))
 856       (:result-types positive-fixnum)
 857       (:generator 5
 858         (move eax value)
 859         (inst mov (make-ea :byte :base object :index index :scale 1
 860                            :disp (- (* vector-data-offset n-word-bytes)
 861                                     other-pointer-lowtag))
 862               al-tn)
 863         (move result eax)))
 864     (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
 865       (:translate data-vector-set)
 866       (:policy :fast-safe)
 867       (:args (object :scs (descriptor-reg) :to (:eval 0))
 868              (value :scs (unsigned-reg signed-reg) :target eax))
 869       (:info index)
 870       (:arg-types ,ptype (:constant (signed-byte 30))
 871                   positive-fixnum)
 872       (:temporary (:sc unsigned-reg :offset eax-offset :target result
 873                        :from (:argument 1) :to (:result 0))
 874                   eax)
 875       (:results (result :scs (unsigned-reg signed-reg)))
 876       (:result-types positive-fixnum)
 877       (:generator 4
 878         (move eax value)
 879         (inst mov (make-ea :byte :base object
 880                            :disp (- (+ (* vector-data-offset n-word-bytes) index)
 881                                     other-pointer-lowtag))
 882               al-tn)
 883         (move result eax))))))
 884   (define-data-vector-frobs simple-array-unsigned-byte-7)
 885   (define-data-vector-frobs simple-array-unsigned-byte-8))
 886
 887 ;;; unsigned-byte-16
 888 (macrolet ((define-data-vector-frobs (ptype)
 889     `(progn
 890       (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
 891         (:translate data-vector-ref)
 892         (:policy :fast-safe)
 893         (:args (object :scs (descriptor-reg))
 894                (index :scs (unsigned-reg)))
 895         (:arg-types ,ptype positive-fixnum)
 896         (:results (value :scs (unsigned-reg signed-reg)))
 897         (:result-types positive-fixnum)
 898         (:generator 5
 899           (inst movzx value
 900                 (make-ea :word :base object :index index :scale 2
 901                          :disp (- (* vector-data-offset n-word-bytes)
 902                                   other-pointer-lowtag)))))
 903       (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
 904         (:translate data-vector-ref)
 905         (:policy :fast-safe)
 906         (:args (object :scs (descriptor-reg)))
 907         (:info index)
 908         (:arg-types ,ptype (:constant (signed-byte 30)))
 909         (:results (value :scs (unsigned-reg signed-reg)))
 910         (:result-types positive-fixnum)
 911         (:generator 4
 912           (inst movzx value
 913                 (make-ea :word :base object
 914                          :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
 915                                   other-pointer-lowtag)))))
 916       (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
 917         (:translate data-vector-set)
 918         (:policy :fast-safe)
 919         (:args (object :scs (descriptor-reg) :to (:eval 0))
 920                (index :scs (unsigned-reg) :to (:eval 0))
 921                (value :scs (unsigned-reg signed-reg) :target eax))
 922         (:arg-types ,ptype positive-fixnum positive-fixnum)
 923         (:temporary (:sc unsigned-reg :offset eax-offset :target result
 924                          :from (:argument 2) :to (:result 0))
 925                     eax)
 926         (:results (result :scs (unsigned-reg signed-reg)))
 927         (:result-types positive-fixnum)
 928         (:generator 5
 929           (move eax value)
 930           (inst mov (make-ea :word :base object :index index :scale 2
 931                              :disp (- (* vector-data-offset n-word-bytes)
 932                                       other-pointer-lowtag))
 933                 ax-tn)
 934           (move result eax)))
 935
 936       (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
 937         (:translate data-vector-set)
 938         (:policy :fast-safe)
 939         (:args (object :scs (descriptor-reg) :to (:eval 0))
 940                (value :scs (unsigned-reg signed-reg) :target eax))
 941         (:info index)
 942         (:arg-types ,ptype (:constant (signed-byte 30))
 943                     positive-fixnum)
 944         (:temporary (:sc unsigned-reg :offset eax-offset :target result
 945                          :from (:argument 1) :to (:result 0))
 946                     eax)
 947         (:results (result :scs (unsigned-reg signed-reg)))
 948         (:result-types positive-fixnum)
 949         (:generator 4
 950           (move eax value)
 951           (inst mov (make-ea :word :base object
 952                              :disp (- (+ (* vector-data-offset n-word-bytes)
 953                                          (* 2 index))
 954                                       other-pointer-lowtag))
 955                 ax-tn)
 956           (move result eax))))))
 957   (define-data-vector-frobs simple-array-unsigned-byte-15)
 958   (define-data-vector-frobs simple-array-unsigned-byte-16))
 959
 960 ;;; simple-string
 961
 962 #!+sb-unicode
 963 (progn
 964 (define-vop (data-vector-ref/simple-base-string)
 965   (:translate data-vector-ref)
 966   (:policy :fast-safe)
 967   (:args (object :scs (descriptor-reg))
 968          (index :scs (unsigned-reg)))
 969   (:arg-types simple-base-string positive-fixnum)
 970   (:results (value :scs (character-reg)))
 971   (:result-types character)
 972   (:generator 5
 973     (inst movzx value
 974           (make-ea :byte :base object :index index :scale 1
 975                    :disp (- (* vector-data-offset n-word-bytes)
 976                             other-pointer-lowtag)))))
 977
 978 (define-vop (data-vector-ref-c/simple-base-string)
 979   (:translate data-vector-ref)
 980   (:policy :fast-safe)
 981   (:args (object :scs (descriptor-reg)))
 982   (:info index)
 983   (:arg-types simple-base-string (:constant (signed-byte 30)))
 984   (:results (value :scs (character-reg)))
 985   (:result-types character)
 986   (:generator 4
 987     (inst movzx value
 988           (make-ea :byte :base object
 989                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
 990                             other-pointer-lowtag)))))
 991
 992 (define-vop (data-vector-set/simple-base-string)
 993   (:translate data-vector-set)
 994   (:policy :fast-safe)
 995   (:args (object :scs (descriptor-reg) :to (:eval 0))
 996          (index :scs (unsigned-reg) :to (:eval 0))
 997          (value :scs (character-reg) :target eax))
 998   (:arg-types simple-base-string positive-fixnum character)
 999   (:temporary (:sc character-reg :offset eax-offset :target result
1000                    :from (:argument 2) :to (:result 0))
1001               eax)
1002   (:results (result :scs (character-reg)))
1003   (:result-types character)
1004   (:generator 5
1005     (move eax value)
1006     (inst mov (make-ea :byte :base object :index index :scale 1
1007                        :disp (- (* vector-data-offset n-word-bytes)
1008                                 other-pointer-lowtag))
1009           al-tn)
1010     (move result eax)))
1011
1012 (define-vop (data-vector-set-c/simple-base-string)
1013   (:translate data-vector-set)
1014   (:policy :fast-safe)
1015   (:args (object :scs (descriptor-reg) :to (:eval 0))
1016          (value :scs (character-reg)))
1017   (:info index)
1018   (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1019   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1020                    :from (:argument 1) :to (:result 0))
1021               eax)
1022   (:results (result :scs (character-reg)))
1023   (:result-types character)
1024   (:generator 4
1025     (move eax value)
1026     (inst mov (make-ea :byte :base object
1027                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
1028                                 other-pointer-lowtag))
1029           al-tn)
1030     (move result eax)))
1031 ) ; PROGN
1032
1033 #!-sb-unicode
1034 (progn
1035 (define-vop (data-vector-ref/simple-base-string)
1036   (:translate data-vector-ref)
1037   (:policy :fast-safe)
1038   (:args (object :scs (descriptor-reg))
1039          (index :scs (unsigned-reg)))
1040   (:arg-types simple-base-string positive-fixnum)
1041   (:results (value :scs (character-reg)))
1042   (:result-types character)
1043   (:generator 5
1044     (inst mov value
1045           (make-ea :byte :base object :index index :scale 1
1046                    :disp (- (* vector-data-offset n-word-bytes)
1047                             other-pointer-lowtag)))))
1048
1049 (define-vop (data-vector-ref-c/simple-base-string)
1050   (:translate data-vector-ref)
1051   (:policy :fast-safe)
1052   (:args (object :scs (descriptor-reg)))
1053   (:info index)
1054   (:arg-types simple-base-string (:constant (signed-byte 30)))
1055   (:results (value :scs (character-reg)))
1056   (:result-types character)
1057   (:generator 4
1058     (inst mov value
1059           (make-ea :byte :base object
1060                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1061                             other-pointer-lowtag)))))
1062
1063 (define-vop (data-vector-set/simple-base-string)
1064   (:translate data-vector-set)
1065   (:policy :fast-safe)
1066   (:args (object :scs (descriptor-reg) :to (:eval 0))
1067          (index :scs (unsigned-reg) :to (:eval 0))
1068          (value :scs (character-reg) :target result))
1069   (:arg-types simple-base-string positive-fixnum character)
1070   (:results (result :scs (character-reg)))
1071   (:result-types character)
1072   (:generator 5
1073     (inst mov (make-ea :byte :base object :index index :scale 1
1074                        :disp (- (* vector-data-offset n-word-bytes)
1075                                 other-pointer-lowtag))
1076           value)
1077     (move result value)))
1078
1079 (define-vop (data-vector-set-c/simple-base-string)
1080   (:translate data-vector-set)
1081   (:policy :fast-safe)
1082   (:args (object :scs (descriptor-reg) :to (:eval 0))
1083          (value :scs (character-reg)))
1084   (:info index)
1085   (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1086   (:results (result :scs (character-reg)))
1087   (:result-types character)
1088   (:generator 4
1089    (inst mov (make-ea :byte :base object
1090                       :disp (- (+ (* vector-data-offset n-word-bytes) index)
1091                                other-pointer-lowtag))
1092          value)
1093    (move result value)))
1094 ) ; PROGN
1095
1096 #!+sb-unicode
1097 (define-full-reffer data-vector-ref/simple-character-string
1098     simple-character-string vector-data-offset other-pointer-lowtag
1099     (character-reg) character data-vector-ref)
1100 #!+sb-unicode
1101 (define-full-setter data-vector-set/simple-character-string
1102     simple-character-string vector-data-offset other-pointer-lowtag
1103     (character-reg) character data-vector-set)
1104
1105 ;;; signed-byte-8
1106
1107 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1108   (:translate data-vector-ref)
1109   (:policy :fast-safe)
1110   (:args (object :scs (descriptor-reg))
1111          (index :scs (unsigned-reg)))
1112   (:arg-types simple-array-signed-byte-8 positive-fixnum)
1113   (:results (value :scs (signed-reg)))
1114   (:result-types tagged-num)
1115   (:generator 5
1116     (inst movsx value
1117           (make-ea :byte :base object :index index :scale 1
1118                    :disp (- (* vector-data-offset n-word-bytes)
1119                             other-pointer-lowtag)))))
1120
1121 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1122   (:translate data-vector-ref)
1123   (:policy :fast-safe)
1124   (:args (object :scs (descriptor-reg)))
1125   (:info index)
1126   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1127   (:results (value :scs (signed-reg)))
1128   (:result-types tagged-num)
1129   (:generator 4
1130     (inst movsx value
1131           (make-ea :byte :base object
1132                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1133                             other-pointer-lowtag)))))
1134
1135 (define-vop (data-vector-set/simple-array-signed-byte-8)
1136   (:translate data-vector-set)
1137   (:policy :fast-safe)
1138   (:args (object :scs (descriptor-reg) :to (:eval 0))
1139          (index :scs (unsigned-reg) :to (:eval 0))
1140          (value :scs (signed-reg) :target eax))
1141   (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1142   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1143                    :from (:argument 2) :to (:result 0))
1144               eax)
1145   (:results (result :scs (signed-reg)))
1146   (:result-types tagged-num)
1147   (:generator 5
1148     (move eax value)
1149     (inst mov (make-ea :byte :base object :index index :scale 1
1150                        :disp (- (* vector-data-offset n-word-bytes)
1151                                 other-pointer-lowtag))
1152           al-tn)
1153     (move result eax)))
1154
1155 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1156   (:translate data-vector-set)
1157   (:policy :fast-safe)
1158   (:args (object :scs (descriptor-reg) :to (:eval 0))
1159          (value :scs (signed-reg) :target eax))
1160   (:info index)
1161   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1162               tagged-num)
1163   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1164                    :from (:argument 1) :to (:result 0))
1165               eax)
1166   (:results (result :scs (signed-reg)))
1167   (:result-types tagged-num)
1168   (:generator 4
1169     (move eax value)
1170     (inst mov (make-ea :byte :base object
1171                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
1172                                 other-pointer-lowtag))
1173           al-tn)
1174     (move result eax)))
1175
1176 ;;; signed-byte-16
1177
1178 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1179   (:translate data-vector-ref)
1180   (:policy :fast-safe)
1181   (:args (object :scs (descriptor-reg))
1182          (index :scs (unsigned-reg)))
1183   (:arg-types simple-array-signed-byte-16 positive-fixnum)
1184   (:results (value :scs (signed-reg)))
1185   (:result-types tagged-num)
1186   (:generator 5
1187     (inst movsx value
1188           (make-ea :word :base object :index index :scale 2
1189                    :disp (- (* vector-data-offset n-word-bytes)
1190                             other-pointer-lowtag)))))
1191
1192 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1193   (:translate data-vector-ref)
1194   (:policy :fast-safe)
1195   (:args (object :scs (descriptor-reg)))
1196   (:info index)
1197   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1198   (:results (value :scs (signed-reg)))
1199   (:result-types tagged-num)
1200   (:generator 4
1201     (inst movsx value
1202           (make-ea :word :base object
1203                    :disp (- (+ (* vector-data-offset n-word-bytes)
1204                                (* 2 index))
1205                             other-pointer-lowtag)))))
1206
1207 (define-vop (data-vector-set/simple-array-signed-byte-16)
1208   (:translate data-vector-set)
1209   (:policy :fast-safe)
1210   (:args (object :scs (descriptor-reg) :to (:eval 0))
1211          (index :scs (unsigned-reg) :to (:eval 0))
1212          (value :scs (signed-reg) :target eax))
1213   (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1214   (:temporary (:sc signed-reg :offset eax-offset :target result
1215                    :from (:argument 2) :to (:result 0))
1216               eax)
1217   (:results (result :scs (signed-reg)))
1218   (:result-types tagged-num)
1219   (:generator 5
1220     (move eax value)
1221     (inst mov (make-ea :word :base object :index index :scale 2
1222                        :disp (- (* vector-data-offset n-word-bytes)
1223                                 other-pointer-lowtag))
1224           ax-tn)
1225     (move result eax)))
1226
1227 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1228   (:translate data-vector-set)
1229   (:policy :fast-safe)
1230   (:args (object :scs (descriptor-reg) :to (:eval 0))
1231          (value :scs (signed-reg) :target eax))
1232   (:info index)
1233   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1234   (:temporary (:sc signed-reg :offset eax-offset :target result
1235                    :from (:argument 1) :to (:result 0))
1236               eax)
1237   (:results (result :scs (signed-reg)))
1238   (:result-types tagged-num)
1239   (:generator 4
1240     (move eax value)
1241     (inst mov
1242           (make-ea :word :base object
1243                    :disp (- (+ (* vector-data-offset n-word-bytes)
1244                                (* 2 index))
1245                             other-pointer-lowtag))
1246           ax-tn)
1247     (move result eax)))
1248 \f
1249 ;;; These VOPs are used for implementing float slots in structures (whose raw
1250 ;;; data is an unsigned-32 vector).
1251 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
1252   (:translate %raw-ref-single)
1253   (:arg-types sb!c::raw-vector positive-fixnum))
1254 (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
1255   (:translate %raw-ref-single)
1256   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1257 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
1258   (:translate %raw-set-single)
1259   (:arg-types sb!c::raw-vector positive-fixnum single-float))
1260 (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
1261   (:translate %raw-set-single)
1262   (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) single-float))
1263 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
1264   (:translate %raw-ref-double)
1265   (:arg-types sb!c::raw-vector positive-fixnum))
1266 (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
1267   (:translate %raw-ref-double)
1268   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1269 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
1270   (:translate %raw-set-double)
1271   (:arg-types sb!c::raw-vector positive-fixnum double-float))
1272 (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
1273   (:translate %raw-set-double)
1274   (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) double-float))
1275
1276
1277 ;;;; complex-float raw structure slot accessors
1278
1279 (define-vop (raw-ref-complex-single
1280              data-vector-ref/simple-array-complex-single-float)
1281   (:translate %raw-ref-complex-single)
1282   (:arg-types sb!c::raw-vector positive-fixnum))
1283 (define-vop (raw-ref-complex-single-c
1284              data-vector-ref-c/simple-array-complex-single-float)
1285   (:translate %raw-ref-complex-single)
1286   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1287 (define-vop (raw-set-complex-single
1288              data-vector-set/simple-array-complex-single-float)
1289   (:translate %raw-set-complex-single)
1290   (:arg-types sb!c::raw-vector positive-fixnum complex-single-float))
1291 (define-vop (raw-set-complex-single-c
1292              data-vector-set-c/simple-array-complex-single-float)
1293   (:translate %raw-set-complex-single)
1294   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1295               complex-single-float))
1296 (define-vop (raw-ref-complex-double
1297              data-vector-ref/simple-array-complex-double-float)
1298   (:translate %raw-ref-complex-double)
1299   (:arg-types sb!c::raw-vector positive-fixnum))
1300 (define-vop (raw-ref-complex-double-c
1301              data-vector-ref-c/simple-array-complex-double-float)
1302   (:translate %raw-ref-complex-double)
1303   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1304 (define-vop (raw-set-complex-double
1305              data-vector-set/simple-array-complex-double-float)
1306   (:translate %raw-set-complex-double)
1307   (:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
1308 (define-vop (raw-set-complex-double-c
1309              data-vector-set-c/simple-array-complex-double-float)
1310   (:translate %raw-set-complex-double)
1311   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1312               complex-double-float))
1313
1314
1315 ;;; These vops are useful for accessing the bits of a vector
1316 ;;; irrespective of what type of vector it is.
1317 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1318   unsigned-num %raw-bits)
1319 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1320   unsigned-num %set-raw-bits)
1321 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
1322   (unsigned-reg) unsigned-num %vector-raw-bits)
1323 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
1324   (unsigned-reg) unsigned-num %set-vector-raw-bits)
1325 \f
1326 ;;;; miscellaneous array VOPs
1327
1328 (define-vop (get-vector-subtype get-header-data))
1329 (define-vop (set-vector-subtype set-header-data))