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 #!+long-float
 507 (define-vop (data-vector-ref/simple-array-long-float)
 508   (:note "inline array access")
 509   (:translate data-vector-ref)
 510   (:policy :fast-safe)
 511   (:args (object :scs (descriptor-reg) :to :result)
 512          (index :scs (any-reg)))
 513   (:arg-types simple-array-long-float positive-fixnum)
 514   (:temporary (:sc any-reg :from :eval :to :result) temp)
 515   (:results (value :scs (long-reg)))
 516   (:result-types long-float)
 517   (:generator 7
 518     ;; temp = 3 * index
 519     (inst lea temp (make-ea :dword :base index :index index :scale 2))
 520     (with-empty-tn@fp-top(value)
 521       (inst fldl (make-ea :dword :base object :index temp :scale 1
 522                           :disp (- (* vector-data-offset
 523                                       n-word-bytes)
 524                                    other-pointer-lowtag))))))
 525
 526 #!+long-float
 527 (define-vop (data-vector-ref-c/simple-array-long-float)
 528   (:note "inline array access")
 529   (:translate data-vector-ref)
 530   (:policy :fast-safe)
 531   (:args (object :scs (descriptor-reg)))
 532   (:info index)
 533   (:arg-types simple-array-long-float (:constant (signed-byte 30)))
 534   (:results (value :scs (long-reg)))
 535   (:result-types long-float)
 536   (:generator 6
 537    (with-empty-tn@fp-top(value)
 538      (inst fldl (make-ea :dword :base object
 539                          :disp (- (+ (* vector-data-offset
 540                                         n-word-bytes)
 541                                      (* 12 index))
 542                                   other-pointer-lowtag))))))
 543
 544 #!+long-float
 545 (define-vop (data-vector-set/simple-array-long-float)
 546   (:note "inline array store")
 547   (:translate data-vector-set)
 548   (:policy :fast-safe)
 549   (:args (object :scs (descriptor-reg) :to :result)
 550          (index :scs (any-reg))
 551          (value :scs (long-reg) :target result))
 552   (:arg-types simple-array-long-float positive-fixnum long-float)
 553   (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
 554   (:results (result :scs (long-reg)))
 555   (:result-types long-float)
 556   (:generator 20
 557     ;; temp = 3 * index
 558     (inst lea temp (make-ea :dword :base index :index index :scale 2))
 559     (cond ((zerop (tn-offset value))
 560            ;; Value is in ST0.
 561            (store-long-float
 562             (make-ea :dword :base object :index temp :scale 1
 563                      :disp (- (* vector-data-offset n-word-bytes)
 564                               other-pointer-lowtag)))
 565            (unless (zerop (tn-offset result))
 566                    ;; Value is in ST0 but not result.
 567                    (inst fstd result)))
 568           (t
 569            ;; Value is not in ST0.
 570            (inst fxch value)
 571            (store-long-float
 572             (make-ea :dword :base object :index temp :scale 1
 573                      :disp (- (* vector-data-offset n-word-bytes)
 574                               other-pointer-lowtag)))
 575            (cond ((zerop (tn-offset result))
 576                   ;; The result is in ST0.
 577                   (inst fstd value))
 578                  (t
 579                   ;; Neither value or result are in ST0
 580                   (unless (location= value result)
 581                     (inst fstd result))
 582                   (inst fxch value)))))))
 583
 584 #!+long-float
 585 (define-vop (data-vector-set-c/simple-array-long-float)
 586   (:note "inline array store")
 587   (:translate data-vector-set)
 588   (:policy :fast-safe)
 589   (:args (object :scs (descriptor-reg))
 590          (value :scs (long-reg) :target result))
 591   (:info index)
 592   (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
 593   (:results (result :scs (long-reg)))
 594   (:result-types long-float)
 595   (:generator 19
 596     (cond ((zerop (tn-offset value))
 597            ;; Value is in ST0.
 598            (store-long-float (make-ea :dword :base object
 599                                       :disp (- (+ (* vector-data-offset
 600                                                      n-word-bytes)
 601                                                   (* 12 index))
 602                                                other-pointer-lowtag)))
 603            (unless (zerop (tn-offset result))
 604              ;; Value is in ST0 but not result.
 605              (inst fstd result)))
 606           (t
 607            ;; Value is not in ST0.
 608            (inst fxch value)
 609            (store-long-float (make-ea :dword :base object
 610                                       :disp (- (+ (* vector-data-offset
 611                                                      n-word-bytes)
 612                                                   (* 12 index))
 613                                                other-pointer-lowtag)))
 614            (cond ((zerop (tn-offset result))
 615                   ;; The result is in ST0.
 616                   (inst fstd value))
 617                  (t
 618                   ;; Neither value or result are in ST0
 619                   (unless (location= value result)
 620                     (inst fstd result))
 621                   (inst fxch value)))))))
 622
 623 ;;; complex float variants
 624
 625 (define-vop (data-vector-ref/simple-array-complex-single-float)
 626   (:note "inline array access")
 627   (:translate data-vector-ref)
 628   (:policy :fast-safe)
 629   (:args (object :scs (descriptor-reg))
 630          (index :scs (any-reg)))
 631   (:arg-types simple-array-complex-single-float positive-fixnum)
 632   (:results (value :scs (complex-single-reg)))
 633   (:result-types complex-single-float)
 634   (:generator 5
 635     (let ((real-tn (complex-single-reg-real-tn value)))
 636       (with-empty-tn@fp-top (real-tn)
 637         (inst fld (make-ea :dword :base object :index index :scale 2
 638                            :disp (- (* vector-data-offset
 639                                        n-word-bytes)
 640                                     other-pointer-lowtag)))))
 641     (let ((imag-tn (complex-single-reg-imag-tn value)))
 642       (with-empty-tn@fp-top (imag-tn)
 643         (inst fld (make-ea :dword :base object :index index :scale 2
 644                            :disp (- (* (1+ vector-data-offset)
 645                                        n-word-bytes)
 646                                     other-pointer-lowtag)))))))
 647
 648 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
 649   (:note "inline array access")
 650   (:translate data-vector-ref)
 651   (:policy :fast-safe)
 652   (:args (object :scs (descriptor-reg)))
 653   (:info index)
 654   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
 655   (:results (value :scs (complex-single-reg)))
 656   (:result-types complex-single-float)
 657   (:generator 4
 658     (let ((real-tn (complex-single-reg-real-tn value)))
 659       (with-empty-tn@fp-top (real-tn)
 660         (inst fld (make-ea :dword :base object
 661                            :disp (- (+ (* vector-data-offset
 662                                           n-word-bytes)
 663                                        (* 8 index))
 664                                     other-pointer-lowtag)))))
 665     (let ((imag-tn (complex-single-reg-imag-tn value)))
 666       (with-empty-tn@fp-top (imag-tn)
 667         (inst fld (make-ea :dword :base object
 668                            :disp (- (+ (* vector-data-offset
 669                                           n-word-bytes)
 670                                        (* 8 index) 4)
 671                                     other-pointer-lowtag)))))))
 672
 673 (define-vop (data-vector-set/simple-array-complex-single-float)
 674   (:note "inline array store")
 675   (:translate data-vector-set)
 676   (:policy :fast-safe)
 677   (:args (object :scs (descriptor-reg))
 678          (index :scs (any-reg))
 679          (value :scs (complex-single-reg) :target result))
 680   (:arg-types simple-array-complex-single-float positive-fixnum
 681               complex-single-float)
 682   (:results (result :scs (complex-single-reg)))
 683   (:result-types complex-single-float)
 684   (:generator 5
 685     (let ((value-real (complex-single-reg-real-tn value))
 686           (result-real (complex-single-reg-real-tn result)))
 687       (cond ((zerop (tn-offset value-real))
 688              ;; Value is in ST0.
 689              (inst fst (make-ea :dword :base object :index index :scale 2
 690                                 :disp (- (* vector-data-offset
 691                                             n-word-bytes)
 692                                          other-pointer-lowtag)))
 693              (unless (zerop (tn-offset result-real))
 694                ;; Value is in ST0 but not result.
 695                (inst fst result-real)))
 696             (t
 697              ;; Value is not in ST0.
 698              (inst fxch value-real)
 699              (inst fst (make-ea :dword :base object :index index :scale 2
 700                                 :disp (- (* vector-data-offset
 701                                             n-word-bytes)
 702                                          other-pointer-lowtag)))
 703              (cond ((zerop (tn-offset result-real))
 704                     ;; The result is in ST0.
 705                     (inst fst value-real))
 706                    (t
 707                     ;; Neither value or result are in ST0
 708                     (unless (location= value-real result-real)
 709                       (inst fst result-real))
 710                     (inst fxch value-real))))))
 711     (let ((value-imag (complex-single-reg-imag-tn value))
 712           (result-imag (complex-single-reg-imag-tn result)))
 713       (inst fxch value-imag)
 714       (inst fst (make-ea :dword :base object :index index :scale 2
 715                          :disp (- (+ (* vector-data-offset
 716                                         n-word-bytes)
 717                                      4)
 718                                   other-pointer-lowtag)))
 719       (unless (location= value-imag result-imag)
 720         (inst fst result-imag))
 721       (inst fxch value-imag))))
 722
 723 (define-vop (data-vector-set-c/simple-array-complex-single-float)
 724   (:note "inline array store")
 725   (:translate data-vector-set)
 726   (:policy :fast-safe)
 727   (:args (object :scs (descriptor-reg))
 728          (value :scs (complex-single-reg) :target result))
 729   (:info index)
 730   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
 731               complex-single-float)
 732   (:results (result :scs (complex-single-reg)))
 733   (:result-types complex-single-float)
 734   (:generator 4
 735     (let ((value-real (complex-single-reg-real-tn value))
 736           (result-real (complex-single-reg-real-tn result)))
 737       (cond ((zerop (tn-offset value-real))
 738              ;; Value is in ST0.
 739              (inst fst (make-ea :dword :base object
 740                                 :disp (- (+ (* vector-data-offset
 741                                                n-word-bytes)
 742                                             (* 8 index))
 743                                          other-pointer-lowtag)))
 744              (unless (zerop (tn-offset result-real))
 745                ;; Value is in ST0 but not result.
 746                (inst fst result-real)))
 747             (t
 748              ;; Value is not in ST0.
 749              (inst fxch value-real)
 750              (inst fst (make-ea :dword :base object
 751                                 :disp (- (+ (* vector-data-offset
 752                                                n-word-bytes)
 753                                             (* 8 index))
 754                                          other-pointer-lowtag)))
 755              (cond ((zerop (tn-offset result-real))
 756                     ;; The result is in ST0.
 757                     (inst fst value-real))
 758                    (t
 759                     ;; Neither value or result are in ST0
 760                     (unless (location= value-real result-real)
 761                       (inst fst result-real))
 762                     (inst fxch value-real))))))
 763     (let ((value-imag (complex-single-reg-imag-tn value))
 764           (result-imag (complex-single-reg-imag-tn result)))
 765       (inst fxch value-imag)
 766       (inst fst (make-ea :dword :base object
 767                          :disp (- (+ (* vector-data-offset
 768                                         n-word-bytes)
 769                                      (* 8 index) 4)
 770                                   other-pointer-lowtag)))
 771       (unless (location= value-imag result-imag)
 772         (inst fst result-imag))
 773       (inst fxch value-imag))))
 774
 775
 776 (define-vop (data-vector-ref/simple-array-complex-double-float)
 777   (:note "inline array access")
 778   (:translate data-vector-ref)
 779   (:policy :fast-safe)
 780   (:args (object :scs (descriptor-reg))
 781          (index :scs (any-reg)))
 782   (:arg-types simple-array-complex-double-float positive-fixnum)
 783   (:results (value :scs (complex-double-reg)))
 784   (:result-types complex-double-float)
 785   (:generator 7
 786     (let ((real-tn (complex-double-reg-real-tn value)))
 787       (with-empty-tn@fp-top (real-tn)
 788         (inst fldd (make-ea :dword :base object :index index :scale 4
 789                             :disp (- (* vector-data-offset
 790                                         n-word-bytes)
 791                                      other-pointer-lowtag)))))
 792     (let ((imag-tn (complex-double-reg-imag-tn value)))
 793       (with-empty-tn@fp-top (imag-tn)
 794         (inst fldd (make-ea :dword :base object :index index :scale 4
 795                             :disp (- (+ (* vector-data-offset
 796                                            n-word-bytes)
 797                                         8)
 798                                      other-pointer-lowtag)))))))
 799
 800 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
 801   (:note "inline array access")
 802   (:translate data-vector-ref)
 803   (:policy :fast-safe)
 804   (:args (object :scs (descriptor-reg)))
 805   (:info index)
 806   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
 807   (:results (value :scs (complex-double-reg)))
 808   (:result-types complex-double-float)
 809   (:generator 6
 810     (let ((real-tn (complex-double-reg-real-tn value)))
 811       (with-empty-tn@fp-top (real-tn)
 812         (inst fldd (make-ea :dword :base object
 813                             :disp (- (+ (* vector-data-offset
 814                                            n-word-bytes)
 815                                         (* 16 index))
 816                                      other-pointer-lowtag)))))
 817     (let ((imag-tn (complex-double-reg-imag-tn value)))
 818       (with-empty-tn@fp-top (imag-tn)
 819         (inst fldd (make-ea :dword :base object
 820                             :disp (- (+ (* vector-data-offset
 821                                            n-word-bytes)
 822                                         (* 16 index) 8)
 823                                      other-pointer-lowtag)))))))
 824
 825 (define-vop (data-vector-set/simple-array-complex-double-float)
 826   (:note "inline array store")
 827   (:translate data-vector-set)
 828   (:policy :fast-safe)
 829   (:args (object :scs (descriptor-reg))
 830          (index :scs (any-reg))
 831          (value :scs (complex-double-reg) :target result))
 832   (:arg-types simple-array-complex-double-float positive-fixnum
 833               complex-double-float)
 834   (:results (result :scs (complex-double-reg)))
 835   (:result-types complex-double-float)
 836   (:generator 20
 837     (let ((value-real (complex-double-reg-real-tn value))
 838           (result-real (complex-double-reg-real-tn result)))
 839       (cond ((zerop (tn-offset value-real))
 840              ;; Value is in ST0.
 841              (inst fstd (make-ea :dword :base object :index index :scale 4
 842                                  :disp (- (* vector-data-offset
 843                                              n-word-bytes)
 844                                           other-pointer-lowtag)))
 845              (unless (zerop (tn-offset result-real))
 846                ;; Value is in ST0 but not result.
 847                (inst fstd result-real)))
 848             (t
 849              ;; Value is not in ST0.
 850              (inst fxch value-real)
 851              (inst fstd (make-ea :dword :base object :index index :scale 4
 852                                  :disp (- (* vector-data-offset
 853                                              n-word-bytes)
 854                                           other-pointer-lowtag)))
 855              (cond ((zerop (tn-offset result-real))
 856                     ;; The result is in ST0.
 857                     (inst fstd value-real))
 858                    (t
 859                     ;; Neither value or result are in ST0
 860                     (unless (location= value-real result-real)
 861                       (inst fstd result-real))
 862                     (inst fxch value-real))))))
 863     (let ((value-imag (complex-double-reg-imag-tn value))
 864           (result-imag (complex-double-reg-imag-tn result)))
 865       (inst fxch value-imag)
 866       (inst fstd (make-ea :dword :base object :index index :scale 4
 867                           :disp (- (+ (* vector-data-offset
 868                                          n-word-bytes)
 869                                       8)
 870                                    other-pointer-lowtag)))
 871       (unless (location= value-imag result-imag)
 872         (inst fstd result-imag))
 873       (inst fxch value-imag))))
 874
 875 (define-vop (data-vector-set-c/simple-array-complex-double-float)
 876   (:note "inline array store")
 877   (:translate data-vector-set)
 878   (:policy :fast-safe)
 879   (:args (object :scs (descriptor-reg))
 880          (value :scs (complex-double-reg) :target result))
 881   (:info index)
 882   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
 883               complex-double-float)
 884   (:results (result :scs (complex-double-reg)))
 885   (:result-types complex-double-float)
 886   (:generator 19
 887     (let ((value-real (complex-double-reg-real-tn value))
 888           (result-real (complex-double-reg-real-tn result)))
 889       (cond ((zerop (tn-offset value-real))
 890              ;; Value is in ST0.
 891              (inst fstd (make-ea :dword :base object
 892                                  :disp (- (+ (* vector-data-offset
 893                                                 n-word-bytes)
 894                                              (* 16 index))
 895                                           other-pointer-lowtag)))
 896              (unless (zerop (tn-offset result-real))
 897                ;; Value is in ST0 but not result.
 898                (inst fstd result-real)))
 899             (t
 900              ;; Value is not in ST0.
 901              (inst fxch value-real)
 902              (inst fstd (make-ea :dword :base object
 903                                  :disp (- (+ (* vector-data-offset
 904                                                 n-word-bytes)
 905                                              (* 16 index))
 906                                           other-pointer-lowtag)))
 907              (cond ((zerop (tn-offset result-real))
 908                     ;; The result is in ST0.
 909                     (inst fstd value-real))
 910                    (t
 911                     ;; Neither value or result are in ST0
 912                     (unless (location= value-real result-real)
 913                       (inst fstd result-real))
 914                     (inst fxch value-real))))))
 915     (let ((value-imag (complex-double-reg-imag-tn value))
 916           (result-imag (complex-double-reg-imag-tn result)))
 917       (inst fxch value-imag)
 918       (inst fstd (make-ea :dword :base object
 919                           :disp (- (+ (* vector-data-offset
 920                                          n-word-bytes)
 921                                       (* 16 index) 8)
 922                                    other-pointer-lowtag)))
 923       (unless (location= value-imag result-imag)
 924         (inst fstd result-imag))
 925       (inst fxch value-imag))))
 926
 927
 928 #!+long-float
 929 (define-vop (data-vector-ref/simple-array-complex-long-float)
 930   (:note "inline array access")
 931   (:translate data-vector-ref)
 932   (:policy :fast-safe)
 933   (:args (object :scs (descriptor-reg) :to :result)
 934          (index :scs (any-reg)))
 935   (:arg-types simple-array-complex-long-float positive-fixnum)
 936   (:temporary (:sc any-reg :from :eval :to :result) temp)
 937   (:results (value :scs (complex-long-reg)))
 938   (:result-types complex-long-float)
 939   (:generator 7
 940     ;; temp = 3 * index
 941     (inst lea temp (make-ea :dword :base index :index index :scale 2))
 942     (let ((real-tn (complex-long-reg-real-tn value)))
 943       (with-empty-tn@fp-top (real-tn)
 944         (inst fldl (make-ea :dword :base object :index temp :scale 2
 945                             :disp (- (* vector-data-offset
 946                                         n-word-bytes)
 947                                      other-pointer-lowtag)))))
 948     (let ((imag-tn (complex-long-reg-imag-tn value)))
 949       (with-empty-tn@fp-top (imag-tn)
 950         (inst fldl (make-ea :dword :base object :index temp :scale 2
 951                             :disp (- (+ (* vector-data-offset
 952                                            n-word-bytes)
 953                                         12)
 954                                      other-pointer-lowtag)))))))
 955
 956 #!+long-float
 957 (define-vop (data-vector-ref-c/simple-array-complex-long-float)
 958   (:note "inline array access")
 959   (:translate data-vector-ref)
 960   (:policy :fast-safe)
 961   (:args (object :scs (descriptor-reg)))
 962   (:info index)
 963   (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
 964   (:results (value :scs (complex-long-reg)))
 965   (:result-types complex-long-float)
 966   (:generator 6
 967     (let ((real-tn (complex-long-reg-real-tn value)))
 968       (with-empty-tn@fp-top (real-tn)
 969         (inst fldl (make-ea :dword :base object
 970                             :disp (- (+ (* vector-data-offset
 971                                            n-word-bytes)
 972                                         (* 24 index))
 973                                      other-pointer-lowtag)))))
 974     (let ((imag-tn (complex-long-reg-imag-tn value)))
 975       (with-empty-tn@fp-top (imag-tn)
 976         (inst fldl (make-ea :dword :base object
 977                             :disp (- (+ (* vector-data-offset
 978                                            n-word-bytes)
 979                                         (* 24 index) 12)
 980                                      other-pointer-lowtag)))))))
 981
 982 #!+long-float
 983 (define-vop (data-vector-set/simple-array-complex-long-float)
 984   (:note "inline array store")
 985   (:translate data-vector-set)
 986   (:policy :fast-safe)
 987   (:args (object :scs (descriptor-reg) :to :result)
 988          (index :scs (any-reg))
 989          (value :scs (complex-long-reg) :target result))
 990   (:arg-types simple-array-complex-long-float positive-fixnum
 991               complex-long-float)
 992   (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
 993   (:results (result :scs (complex-long-reg)))
 994   (:result-types complex-long-float)
 995   (:generator 20
 996     ;; temp = 3 * index
 997     (inst lea temp (make-ea :dword :base index :index index :scale 2))
 998     (let ((value-real (complex-long-reg-real-tn value))
 999           (result-real (complex-long-reg-real-tn result)))
1000       (cond ((zerop (tn-offset value-real))
1001              ;; Value is in ST0.
1002              (store-long-float
1003               (make-ea :dword :base object :index temp :scale 2
1004                        :disp (- (* vector-data-offset n-word-bytes)
1005                                 other-pointer-lowtag)))
1006              (unless (zerop (tn-offset result-real))
1007                ;; Value is in ST0 but not result.
1008                (inst fstd result-real)))
1009             (t
1010              ;; Value is not in ST0.
1011              (inst fxch value-real)
1012              (store-long-float
1013               (make-ea :dword :base object :index temp :scale 2
1014                        :disp (- (* vector-data-offset n-word-bytes)
1015                                 other-pointer-lowtag)))
1016              (cond ((zerop (tn-offset result-real))
1017                     ;; The result is in ST0.
1018                     (inst fstd value-real))
1019                    (t
1020                     ;; Neither value or result are in ST0
1021                     (unless (location= value-real result-real)
1022                       (inst fstd result-real))
1023                     (inst fxch value-real))))))
1024     (let ((value-imag (complex-long-reg-imag-tn value))
1025           (result-imag (complex-long-reg-imag-tn result)))
1026       (inst fxch value-imag)
1027       (store-long-float
1028        (make-ea :dword :base object :index temp :scale 2
1029                 :disp (- (+ (* vector-data-offset n-word-bytes) 12)
1030                          other-pointer-lowtag)))
1031       (unless (location= value-imag result-imag)
1032         (inst fstd result-imag))
1033       (inst fxch value-imag))))
1034
1035 #!+long-float
1036 (define-vop (data-vector-set-c/simple-array-complex-long-float)
1037   (:note "inline array store")
1038   (:translate data-vector-set)
1039   (:policy :fast-safe)
1040   (:args (object :scs (descriptor-reg))
1041          (value :scs (complex-long-reg) :target result))
1042   (:info index)
1043   (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
1044               complex-long-float)
1045   (:results (result :scs (complex-long-reg)))
1046   (:result-types complex-long-float)
1047   (:generator 19
1048     (let ((value-real (complex-long-reg-real-tn value))
1049           (result-real (complex-long-reg-real-tn result)))
1050       (cond ((zerop (tn-offset value-real))
1051              ;; Value is in ST0.
1052              (store-long-float
1053               (make-ea :dword :base object
1054                        :disp (- (+ (* vector-data-offset
1055                                       n-word-bytes)
1056                                    (* 24 index))
1057                                 other-pointer-lowtag)))
1058              (unless (zerop (tn-offset result-real))
1059                ;; Value is in ST0 but not result.
1060                (inst fstd result-real)))
1061             (t
1062              ;; Value is not in ST0.
1063              (inst fxch value-real)
1064              (store-long-float
1065               (make-ea :dword :base object
1066                        :disp (- (+ (* vector-data-offset
1067                                       n-word-bytes)
1068                                    (* 24 index))
1069                                 other-pointer-lowtag)))
1070              (cond ((zerop (tn-offset result-real))
1071                     ;; The result is in ST0.
1072                     (inst fstd value-real))
1073                    (t
1074                     ;; Neither value or result are in ST0
1075                     (unless (location= value-real result-real)
1076                       (inst fstd result-real))
1077                     (inst fxch value-real))))))
1078     (let ((value-imag (complex-long-reg-imag-tn value))
1079           (result-imag (complex-long-reg-imag-tn result)))
1080       (inst fxch value-imag)
1081       (store-long-float
1082        (make-ea :dword :base object
1083                 :disp (- (+ (* vector-data-offset
1084                                n-word-bytes)
1085                             ;; FIXME: There are so many of these bare constants
1086                             ;; (24, 12..) in the LONG-FLOAT code that it's
1087                             ;; ridiculous. I should probably just delete it all
1088                             ;; instead of appearing to flirt with supporting
1089                             ;; this maintenance nightmare.
1090                             (* 24 index) 12)
1091                          other-pointer-lowtag)))
1092       (unless (location= value-imag result-imag)
1093         (inst fstd result-imag))
1094       (inst fxch value-imag))))
1095 \f
1096 ;;; unsigned-byte-8
1097 (macrolet ((define-data-vector-frobs (ptype)
1098   `(progn
1099     (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
1100       (:translate data-vector-ref)
1101       (:policy :fast-safe)
1102       (:args (object :scs (descriptor-reg))
1103              (index :scs (unsigned-reg)))
1104       (:arg-types ,ptype positive-fixnum)
1105       (:results (value :scs (unsigned-reg signed-reg)))
1106       (:result-types positive-fixnum)
1107       (:generator 5
1108         (inst movzx value
1109               (make-ea :byte :base object :index index :scale 1
1110                        :disp (- (* vector-data-offset n-word-bytes)
1111                                 other-pointer-lowtag)))))
1112     (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
1113       (:translate data-vector-ref)
1114       (:policy :fast-safe)
1115       (:args (object :scs (descriptor-reg)))
1116       (:info index)
1117       (:arg-types ,ptype (:constant (signed-byte 30)))
1118       (:results (value :scs (unsigned-reg signed-reg)))
1119       (:result-types positive-fixnum)
1120       (:generator 4
1121         (inst movzx value
1122               (make-ea :byte :base object
1123                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
1124                                 other-pointer-lowtag)))))
1125     (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
1126       (:translate data-vector-set)
1127       (:policy :fast-safe)
1128       (:args (object :scs (descriptor-reg) :to (:eval 0))
1129              (index :scs (unsigned-reg) :to (:eval 0))
1130              (value :scs (unsigned-reg signed-reg) :target eax))
1131       (:arg-types ,ptype positive-fixnum positive-fixnum)
1132       (:temporary (:sc unsigned-reg :offset eax-offset :target result
1133                        :from (:argument 2) :to (:result 0))
1134                   eax)
1135       (:results (result :scs (unsigned-reg signed-reg)))
1136       (:result-types positive-fixnum)
1137       (:generator 5
1138         (move eax value)
1139         (inst mov (make-ea :byte :base object :index index :scale 1
1140                            :disp (- (* vector-data-offset n-word-bytes)
1141                                     other-pointer-lowtag))
1142               al-tn)
1143         (move result eax)))
1144     (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
1145       (:translate data-vector-set)
1146       (:policy :fast-safe)
1147       (:args (object :scs (descriptor-reg) :to (:eval 0))
1148              (value :scs (unsigned-reg signed-reg) :target eax))
1149       (:info index)
1150       (:arg-types ,ptype (:constant (signed-byte 30))
1151                   positive-fixnum)
1152       (:temporary (:sc unsigned-reg :offset eax-offset :target result
1153                        :from (:argument 1) :to (:result 0))
1154                   eax)
1155       (:results (result :scs (unsigned-reg signed-reg)))
1156       (:result-types positive-fixnum)
1157       (:generator 4
1158         (move eax value)
1159         (inst mov (make-ea :byte :base object
1160                            :disp (- (+ (* vector-data-offset n-word-bytes) index)
1161                                     other-pointer-lowtag))
1162               al-tn)
1163         (move result eax))))))
1164   (define-data-vector-frobs simple-array-unsigned-byte-7)
1165   (define-data-vector-frobs simple-array-unsigned-byte-8))
1166
1167 ;;; unsigned-byte-16
1168 (macrolet ((define-data-vector-frobs (ptype)
1169     `(progn
1170       (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
1171         (:translate data-vector-ref)
1172         (:policy :fast-safe)
1173         (:args (object :scs (descriptor-reg))
1174                (index :scs (unsigned-reg)))
1175         (:arg-types ,ptype positive-fixnum)
1176         (:results (value :scs (unsigned-reg signed-reg)))
1177         (:result-types positive-fixnum)
1178         (:generator 5
1179           (inst movzx value
1180                 (make-ea :word :base object :index index :scale 2
1181                          :disp (- (* vector-data-offset n-word-bytes)
1182                                   other-pointer-lowtag)))))
1183       (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
1184         (:translate data-vector-ref)
1185         (:policy :fast-safe)
1186         (:args (object :scs (descriptor-reg)))
1187         (:info index)
1188         (:arg-types ,ptype (:constant (signed-byte 30)))
1189         (:results (value :scs (unsigned-reg signed-reg)))
1190         (:result-types positive-fixnum)
1191         (:generator 4
1192           (inst movzx value
1193                 (make-ea :word :base object
1194                          :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
1195                                   other-pointer-lowtag)))))
1196       (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
1197         (:translate data-vector-set)
1198         (:policy :fast-safe)
1199         (:args (object :scs (descriptor-reg) :to (:eval 0))
1200                (index :scs (unsigned-reg) :to (:eval 0))
1201                (value :scs (unsigned-reg signed-reg) :target eax))
1202         (:arg-types ,ptype positive-fixnum positive-fixnum)
1203         (:temporary (:sc unsigned-reg :offset eax-offset :target result
1204                          :from (:argument 2) :to (:result 0))
1205                     eax)
1206         (:results (result :scs (unsigned-reg signed-reg)))
1207         (:result-types positive-fixnum)
1208         (:generator 5
1209           (move eax value)
1210           (inst mov (make-ea :word :base object :index index :scale 2
1211                              :disp (- (* vector-data-offset n-word-bytes)
1212                                       other-pointer-lowtag))
1213                 ax-tn)
1214           (move result eax)))
1215
1216       (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
1217         (:translate data-vector-set)
1218         (:policy :fast-safe)
1219         (:args (object :scs (descriptor-reg) :to (:eval 0))
1220                (value :scs (unsigned-reg signed-reg) :target eax))
1221         (:info index)
1222         (:arg-types ,ptype (:constant (signed-byte 30))
1223                     positive-fixnum)
1224         (:temporary (:sc unsigned-reg :offset eax-offset :target result
1225                          :from (:argument 1) :to (:result 0))
1226                     eax)
1227         (:results (result :scs (unsigned-reg signed-reg)))
1228         (:result-types positive-fixnum)
1229         (:generator 4
1230           (move eax value)
1231           (inst mov (make-ea :word :base object
1232                              :disp (- (+ (* vector-data-offset n-word-bytes)
1233                                          (* 2 index))
1234                                       other-pointer-lowtag))
1235                 ax-tn)
1236           (move result eax))))))
1237   (define-data-vector-frobs simple-array-unsigned-byte-15)
1238   (define-data-vector-frobs simple-array-unsigned-byte-16))
1239
1240 ;;; simple-string
1241
1242 #!+sb-unicode
1243 (progn
1244 (define-vop (data-vector-ref/simple-base-string)
1245   (:translate data-vector-ref)
1246   (:policy :fast-safe)
1247   (:args (object :scs (descriptor-reg))
1248          (index :scs (unsigned-reg)))
1249   (:arg-types simple-base-string positive-fixnum)
1250   (:results (value :scs (character-reg)))
1251   (:result-types character)
1252   (:generator 5
1253     (inst movzx value
1254           (make-ea :byte :base object :index index :scale 1
1255                    :disp (- (* vector-data-offset n-word-bytes)
1256                             other-pointer-lowtag)))))
1257
1258 (define-vop (data-vector-ref-c/simple-base-string)
1259   (:translate data-vector-ref)
1260   (:policy :fast-safe)
1261   (:args (object :scs (descriptor-reg)))
1262   (:info index)
1263   (:arg-types simple-base-string (:constant (signed-byte 30)))
1264   (:results (value :scs (character-reg)))
1265   (:result-types character)
1266   (:generator 4
1267     (inst movzx value
1268           (make-ea :byte :base object
1269                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1270                             other-pointer-lowtag)))))
1271
1272 (define-vop (data-vector-set/simple-base-string)
1273   (:translate data-vector-set)
1274   (:policy :fast-safe)
1275   (:args (object :scs (descriptor-reg) :to (:eval 0))
1276          (index :scs (unsigned-reg) :to (:eval 0))
1277          (value :scs (character-reg) :target eax))
1278   (:arg-types simple-base-string positive-fixnum character)
1279   (:temporary (:sc character-reg :offset eax-offset :target result
1280                    :from (:argument 2) :to (:result 0))
1281               eax)
1282   (:results (result :scs (character-reg)))
1283   (:result-types character)
1284   (:generator 5
1285     (move eax value)
1286     (inst mov (make-ea :byte :base object :index index :scale 1
1287                        :disp (- (* vector-data-offset n-word-bytes)
1288                                 other-pointer-lowtag))
1289           al-tn)
1290     (move result eax)))
1291
1292 (define-vop (data-vector-set-c/simple-base-string)
1293   (:translate data-vector-set)
1294   (:policy :fast-safe)
1295   (:args (object :scs (descriptor-reg) :to (:eval 0))
1296          (value :scs (character-reg)))
1297   (:info index)
1298   (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1299   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1300                    :from (:argument 1) :to (:result 0))
1301               eax)
1302   (:results (result :scs (character-reg)))
1303   (:result-types character)
1304   (:generator 4
1305     (move eax value)
1306     (inst mov (make-ea :byte :base object
1307                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
1308                                 other-pointer-lowtag))
1309           al-tn)
1310     (move result eax)))
1311 ) ; PROGN
1312
1313 #!-sb-unicode
1314 (progn
1315 (define-vop (data-vector-ref/simple-base-string)
1316   (:translate data-vector-ref)
1317   (:policy :fast-safe)
1318   (:args (object :scs (descriptor-reg))
1319          (index :scs (unsigned-reg)))
1320   (:arg-types simple-base-string positive-fixnum)
1321   (:results (value :scs (character-reg)))
1322   (:result-types character)
1323   (:generator 5
1324     (inst mov value
1325           (make-ea :byte :base object :index index :scale 1
1326                    :disp (- (* vector-data-offset n-word-bytes)
1327                             other-pointer-lowtag)))))
1328
1329 (define-vop (data-vector-ref-c/simple-base-string)
1330   (:translate data-vector-ref)
1331   (:policy :fast-safe)
1332   (:args (object :scs (descriptor-reg)))
1333   (:info index)
1334   (:arg-types simple-base-string (:constant (signed-byte 30)))
1335   (:results (value :scs (character-reg)))
1336   (:result-types character)
1337   (:generator 4
1338     (inst mov value
1339           (make-ea :byte :base object
1340                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1341                             other-pointer-lowtag)))))
1342
1343 (define-vop (data-vector-set/simple-base-string)
1344   (:translate data-vector-set)
1345   (:policy :fast-safe)
1346   (:args (object :scs (descriptor-reg) :to (:eval 0))
1347          (index :scs (unsigned-reg) :to (:eval 0))
1348          (value :scs (character-reg) :target result))
1349   (:arg-types simple-base-string positive-fixnum character)
1350   (:results (result :scs (character-reg)))
1351   (:result-types character)
1352   (:generator 5
1353     (inst mov (make-ea :byte :base object :index index :scale 1
1354                        :disp (- (* vector-data-offset n-word-bytes)
1355                                 other-pointer-lowtag))
1356           value)
1357     (move result value)))
1358
1359 (define-vop (data-vector-set-c/simple-base-string)
1360   (:translate data-vector-set)
1361   (:policy :fast-safe)
1362   (:args (object :scs (descriptor-reg) :to (:eval 0))
1363          (value :scs (character-reg)))
1364   (:info index)
1365   (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1366   (:results (result :scs (character-reg)))
1367   (:result-types character)
1368   (:generator 4
1369    (inst mov (make-ea :byte :base object
1370                       :disp (- (+ (* vector-data-offset n-word-bytes) index)
1371                                other-pointer-lowtag))
1372          value)
1373    (move result value)))
1374 ) ; PROGN
1375
1376 #!+sb-unicode
1377 (define-full-reffer data-vector-ref/simple-character-string
1378     simple-character-string vector-data-offset other-pointer-lowtag
1379     (character-reg) character data-vector-ref)
1380 #!+sb-unicode
1381 (define-full-setter data-vector-ref/simple-character-string
1382     simple-character-string vector-data-offset other-pointer-lowtag
1383     (character-reg) character data-vector-set)
1384
1385 ;;; signed-byte-8
1386
1387 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1388   (:translate data-vector-ref)
1389   (:policy :fast-safe)
1390   (:args (object :scs (descriptor-reg))
1391          (index :scs (unsigned-reg)))
1392   (:arg-types simple-array-signed-byte-8 positive-fixnum)
1393   (:results (value :scs (signed-reg)))
1394   (:result-types tagged-num)
1395   (:generator 5
1396     (inst movsx value
1397           (make-ea :byte :base object :index index :scale 1
1398                    :disp (- (* vector-data-offset n-word-bytes)
1399                             other-pointer-lowtag)))))
1400
1401 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1402   (:translate data-vector-ref)
1403   (:policy :fast-safe)
1404   (:args (object :scs (descriptor-reg)))
1405   (:info index)
1406   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1407   (:results (value :scs (signed-reg)))
1408   (:result-types tagged-num)
1409   (:generator 4
1410     (inst movsx value
1411           (make-ea :byte :base object
1412                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1413                             other-pointer-lowtag)))))
1414
1415 (define-vop (data-vector-set/simple-array-signed-byte-8)
1416   (:translate data-vector-set)
1417   (:policy :fast-safe)
1418   (:args (object :scs (descriptor-reg) :to (:eval 0))
1419          (index :scs (unsigned-reg) :to (:eval 0))
1420          (value :scs (signed-reg) :target eax))
1421   (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1422   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1423                    :from (:argument 2) :to (:result 0))
1424               eax)
1425   (:results (result :scs (signed-reg)))
1426   (:result-types tagged-num)
1427   (:generator 5
1428     (move eax value)
1429     (inst mov (make-ea :byte :base object :index index :scale 1
1430                        :disp (- (* vector-data-offset n-word-bytes)
1431                                 other-pointer-lowtag))
1432           al-tn)
1433     (move result eax)))
1434
1435 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1436   (:translate data-vector-set)
1437   (:policy :fast-safe)
1438   (:args (object :scs (descriptor-reg) :to (:eval 0))
1439          (value :scs (signed-reg) :target eax))
1440   (:info index)
1441   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1442               tagged-num)
1443   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1444                    :from (:argument 1) :to (:result 0))
1445               eax)
1446   (:results (result :scs (signed-reg)))
1447   (:result-types tagged-num)
1448   (:generator 4
1449     (move eax value)
1450     (inst mov (make-ea :byte :base object
1451                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
1452                                 other-pointer-lowtag))
1453           al-tn)
1454     (move result eax)))
1455
1456 ;;; signed-byte-16
1457
1458 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1459   (:translate data-vector-ref)
1460   (:policy :fast-safe)
1461   (:args (object :scs (descriptor-reg))
1462          (index :scs (unsigned-reg)))
1463   (:arg-types simple-array-signed-byte-16 positive-fixnum)
1464   (:results (value :scs (signed-reg)))
1465   (:result-types tagged-num)
1466   (:generator 5
1467     (inst movsx value
1468           (make-ea :word :base object :index index :scale 2
1469                    :disp (- (* vector-data-offset n-word-bytes)
1470                             other-pointer-lowtag)))))
1471
1472 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1473   (:translate data-vector-ref)
1474   (:policy :fast-safe)
1475   (:args (object :scs (descriptor-reg)))
1476   (:info index)
1477   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1478   (:results (value :scs (signed-reg)))
1479   (:result-types tagged-num)
1480   (:generator 4
1481     (inst movsx value
1482           (make-ea :word :base object
1483                    :disp (- (+ (* vector-data-offset n-word-bytes)
1484                                (* 2 index))
1485                             other-pointer-lowtag)))))
1486
1487 (define-vop (data-vector-set/simple-array-signed-byte-16)
1488   (:translate data-vector-set)
1489   (:policy :fast-safe)
1490   (:args (object :scs (descriptor-reg) :to (:eval 0))
1491          (index :scs (unsigned-reg) :to (:eval 0))
1492          (value :scs (signed-reg) :target eax))
1493   (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1494   (:temporary (:sc signed-reg :offset eax-offset :target result
1495                    :from (:argument 2) :to (:result 0))
1496               eax)
1497   (:results (result :scs (signed-reg)))
1498   (:result-types tagged-num)
1499   (:generator 5
1500     (move eax value)
1501     (inst mov (make-ea :word :base object :index index :scale 2
1502                        :disp (- (* vector-data-offset n-word-bytes)
1503                                 other-pointer-lowtag))
1504           ax-tn)
1505     (move result eax)))
1506
1507 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1508   (:translate data-vector-set)
1509   (:policy :fast-safe)
1510   (:args (object :scs (descriptor-reg) :to (:eval 0))
1511          (value :scs (signed-reg) :target eax))
1512   (:info index)
1513   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1514   (:temporary (:sc signed-reg :offset eax-offset :target result
1515                    :from (:argument 1) :to (:result 0))
1516               eax)
1517   (:results (result :scs (signed-reg)))
1518   (:result-types tagged-num)
1519   (:generator 4
1520     (move eax value)
1521     (inst mov
1522           (make-ea :word :base object
1523                    :disp (- (+ (* vector-data-offset n-word-bytes)
1524                                (* 2 index))
1525                             other-pointer-lowtag))
1526           ax-tn)
1527     (move result eax)))
1528 \f
1529 ;;; These VOPs are used for implementing float slots in structures (whose raw
1530 ;;; data is an unsigned-32 vector).
1531 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
1532   (:translate %raw-ref-single)
1533   (:arg-types sb!c::raw-vector positive-fixnum))
1534 (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
1535   (:translate %raw-ref-single)
1536   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1537 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
1538   (:translate %raw-set-single)
1539   (:arg-types sb!c::raw-vector positive-fixnum single-float))
1540 (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
1541   (:translate %raw-set-single)
1542   (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) single-float))
1543 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
1544   (:translate %raw-ref-double)
1545   (:arg-types sb!c::raw-vector positive-fixnum))
1546 (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
1547   (:translate %raw-ref-double)
1548   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1549 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
1550   (:translate %raw-set-double)
1551   (:arg-types sb!c::raw-vector positive-fixnum double-float))
1552 (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
1553   (:translate %raw-set-double)
1554   (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) double-float))
1555 #!+long-float
1556 (define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
1557   (:translate %raw-ref-long)
1558   (:arg-types sb!c::raw-vector positive-fixnum))
1559 #!+long-float
1560 (define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
1561   (:translate %raw-ref-long)
1562   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1563 #!+long-float
1564 (define-vop (raw-set-double data-vector-set/simple-array-long-float)
1565   (:translate %raw-set-long)
1566   (:arg-types sb!c::raw-vector positive-fixnum long-float))
1567 #!+long-float
1568 (define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
1569   (:translate %raw-set-long)
1570   (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) long-float))
1571
1572 ;;;; complex-float raw structure slot accessors
1573
1574 (define-vop (raw-ref-complex-single
1575              data-vector-ref/simple-array-complex-single-float)
1576   (:translate %raw-ref-complex-single)
1577   (:arg-types sb!c::raw-vector positive-fixnum))
1578 (define-vop (raw-ref-complex-single-c
1579              data-vector-ref-c/simple-array-complex-single-float)
1580   (:translate %raw-ref-complex-single)
1581   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1582 (define-vop (raw-set-complex-single
1583              data-vector-set/simple-array-complex-single-float)
1584   (:translate %raw-set-complex-single)
1585   (:arg-types sb!c::raw-vector positive-fixnum complex-single-float))
1586 (define-vop (raw-set-complex-single-c
1587              data-vector-set-c/simple-array-complex-single-float)
1588   (:translate %raw-set-complex-single)
1589   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1590               complex-single-float))
1591 (define-vop (raw-ref-complex-double
1592              data-vector-ref/simple-array-complex-double-float)
1593   (:translate %raw-ref-complex-double)
1594   (:arg-types sb!c::raw-vector positive-fixnum))
1595 (define-vop (raw-ref-complex-double-c
1596              data-vector-ref-c/simple-array-complex-double-float)
1597   (:translate %raw-ref-complex-double)
1598   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1599 (define-vop (raw-set-complex-double
1600              data-vector-set/simple-array-complex-double-float)
1601   (:translate %raw-set-complex-double)
1602   (:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
1603 (define-vop (raw-set-complex-double-c
1604              data-vector-set-c/simple-array-complex-double-float)
1605   (:translate %raw-set-complex-double)
1606   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1607               complex-double-float))
1608 #!+long-float
1609 (define-vop (raw-ref-complex-long
1610              data-vector-ref/simple-array-complex-long-float)
1611   (:translate %raw-ref-complex-long)
1612   (:arg-types sb!c::raw-vector positive-fixnum))
1613 #!+long-float
1614 (define-vop (raw-ref-complex-long-c
1615              data-vector-ref-c/simple-array-complex-long-float)
1616   (:translate %raw-ref-complex-long)
1617   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1618 #!+long-float
1619 (define-vop (raw-set-complex-long
1620              data-vector-set/simple-array-complex-long-float)
1621   (:translate %raw-set-complex-long)
1622   (:arg-types sb!c::raw-vector positive-fixnum complex-long-float))
1623 #!+long-float
1624 (define-vop (raw-set-complex-long-c
1625              data-vector-set-c/simple-array-complex-long-float)
1626   (:translate %raw-set-complex-long)
1627   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1628               complex-long-float))
1629
1630 ;;; These vops are useful for accessing the bits of a vector
1631 ;;; irrespective of what type of vector it is.
1632 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1633   unsigned-num %raw-bits)
1634 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1635   unsigned-num %set-raw-bits)
1636 \f
1637 ;;;; miscellaneous array VOPs
1638
1639 (define-vop (get-vector-subtype get-header-data))
1640 (define-vop (set-vector-subtype set-header-data))