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 (define-vop (data-vector-ref/simple-base-string)
1243   (:translate data-vector-ref)
1244   (:policy :fast-safe)
1245   (:args (object :scs (descriptor-reg))
1246          (index :scs (unsigned-reg)))
1247   (:arg-types simple-base-string positive-fixnum)
1248   (:results (value :scs (base-char-reg)))
1249   (:result-types base-char)
1250   (:generator 5
1251     (inst mov value
1252           (make-ea :byte :base object :index index :scale 1
1253                    :disp (- (* vector-data-offset n-word-bytes)
1254                             other-pointer-lowtag)))))
1255
1256 (define-vop (data-vector-ref-c/simple-base-string)
1257   (:translate data-vector-ref)
1258   (:policy :fast-safe)
1259   (:args (object :scs (descriptor-reg)))
1260   (:info index)
1261   (:arg-types simple-base-string (:constant (signed-byte 30)))
1262   (:results (value :scs (base-char-reg)))
1263   (:result-types base-char)
1264   (:generator 4
1265     (inst mov value
1266           (make-ea :byte :base object
1267                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1268                             other-pointer-lowtag)))))
1269
1270 (define-vop (data-vector-set/simple-base-string)
1271   (:translate data-vector-set)
1272   (:policy :fast-safe)
1273   (:args (object :scs (descriptor-reg) :to (:eval 0))
1274          (index :scs (unsigned-reg) :to (:eval 0))
1275          (value :scs (base-char-reg) :target result))
1276   (:arg-types simple-base-string positive-fixnum base-char)
1277   (:results (result :scs (base-char-reg)))
1278   (:result-types base-char)
1279   (:generator 5
1280     (inst mov (make-ea :byte :base object :index index :scale 1
1281                        :disp (- (* vector-data-offset n-word-bytes)
1282                                 other-pointer-lowtag))
1283           value)
1284     (move result value)))
1285
1286 (define-vop (data-vector-set/simple-base-string-c)
1287   (:translate data-vector-set)
1288   (:policy :fast-safe)
1289   (:args (object :scs (descriptor-reg) :to (:eval 0))
1290          (value :scs (base-char-reg)))
1291   (:info index)
1292   (:arg-types simple-base-string (:constant (signed-byte 30)) base-char)
1293   (:results (result :scs (base-char-reg)))
1294   (:result-types base-char)
1295   (:generator 4
1296    (inst mov (make-ea :byte :base object
1297                       :disp (- (+ (* vector-data-offset n-word-bytes) index)
1298                                other-pointer-lowtag))
1299          value)
1300    (move result value)))
1301
1302 ;;; signed-byte-8
1303
1304 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1305   (:translate data-vector-ref)
1306   (:policy :fast-safe)
1307   (:args (object :scs (descriptor-reg))
1308          (index :scs (unsigned-reg)))
1309   (:arg-types simple-array-signed-byte-8 positive-fixnum)
1310   (:results (value :scs (signed-reg)))
1311   (:result-types tagged-num)
1312   (:generator 5
1313     (inst movsx value
1314           (make-ea :byte :base object :index index :scale 1
1315                    :disp (- (* vector-data-offset n-word-bytes)
1316                             other-pointer-lowtag)))))
1317
1318 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1319   (:translate data-vector-ref)
1320   (:policy :fast-safe)
1321   (:args (object :scs (descriptor-reg)))
1322   (:info index)
1323   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1324   (:results (value :scs (signed-reg)))
1325   (:result-types tagged-num)
1326   (:generator 4
1327     (inst movsx value
1328           (make-ea :byte :base object
1329                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1330                             other-pointer-lowtag)))))
1331
1332 (define-vop (data-vector-set/simple-array-signed-byte-8)
1333   (:translate data-vector-set)
1334   (:policy :fast-safe)
1335   (:args (object :scs (descriptor-reg) :to (:eval 0))
1336          (index :scs (unsigned-reg) :to (:eval 0))
1337          (value :scs (signed-reg) :target eax))
1338   (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1339   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1340                    :from (:argument 2) :to (:result 0))
1341               eax)
1342   (:results (result :scs (signed-reg)))
1343   (:result-types tagged-num)
1344   (:generator 5
1345     (move eax value)
1346     (inst mov (make-ea :byte :base object :index index :scale 1
1347                        :disp (- (* vector-data-offset n-word-bytes)
1348                                 other-pointer-lowtag))
1349           al-tn)
1350     (move result eax)))
1351
1352 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1353   (:translate data-vector-set)
1354   (:policy :fast-safe)
1355   (:args (object :scs (descriptor-reg) :to (:eval 0))
1356          (value :scs (signed-reg) :target eax))
1357   (:info index)
1358   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1359               tagged-num)
1360   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1361                    :from (:argument 1) :to (:result 0))
1362               eax)
1363   (:results (result :scs (signed-reg)))
1364   (:result-types tagged-num)
1365   (:generator 4
1366     (move eax value)
1367     (inst mov (make-ea :byte :base object
1368                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
1369                                 other-pointer-lowtag))
1370           al-tn)
1371     (move result eax)))
1372
1373 ;;; signed-byte-16
1374
1375 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1376   (:translate data-vector-ref)
1377   (:policy :fast-safe)
1378   (:args (object :scs (descriptor-reg))
1379          (index :scs (unsigned-reg)))
1380   (:arg-types simple-array-signed-byte-16 positive-fixnum)
1381   (:results (value :scs (signed-reg)))
1382   (:result-types tagged-num)
1383   (:generator 5
1384     (inst movsx value
1385           (make-ea :word :base object :index index :scale 2
1386                    :disp (- (* vector-data-offset n-word-bytes)
1387                             other-pointer-lowtag)))))
1388
1389 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1390   (:translate data-vector-ref)
1391   (:policy :fast-safe)
1392   (:args (object :scs (descriptor-reg)))
1393   (:info index)
1394   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1395   (:results (value :scs (signed-reg)))
1396   (:result-types tagged-num)
1397   (:generator 4
1398     (inst movsx value
1399           (make-ea :word :base object
1400                    :disp (- (+ (* vector-data-offset n-word-bytes)
1401                                (* 2 index))
1402                             other-pointer-lowtag)))))
1403
1404 (define-vop (data-vector-set/simple-array-signed-byte-16)
1405   (:translate data-vector-set)
1406   (:policy :fast-safe)
1407   (:args (object :scs (descriptor-reg) :to (:eval 0))
1408          (index :scs (unsigned-reg) :to (:eval 0))
1409          (value :scs (signed-reg) :target eax))
1410   (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1411   (:temporary (:sc signed-reg :offset eax-offset :target result
1412                    :from (:argument 2) :to (:result 0))
1413               eax)
1414   (:results (result :scs (signed-reg)))
1415   (:result-types tagged-num)
1416   (:generator 5
1417     (move eax value)
1418     (inst mov (make-ea :word :base object :index index :scale 2
1419                        :disp (- (* vector-data-offset n-word-bytes)
1420                                 other-pointer-lowtag))
1421           ax-tn)
1422     (move result eax)))
1423
1424 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1425   (:translate data-vector-set)
1426   (:policy :fast-safe)
1427   (:args (object :scs (descriptor-reg) :to (:eval 0))
1428          (value :scs (signed-reg) :target eax))
1429   (:info index)
1430   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1431   (:temporary (:sc signed-reg :offset eax-offset :target result
1432                    :from (:argument 1) :to (:result 0))
1433               eax)
1434   (:results (result :scs (signed-reg)))
1435   (:result-types tagged-num)
1436   (:generator 4
1437     (move eax value)
1438     (inst mov
1439           (make-ea :word :base object
1440                    :disp (- (+ (* vector-data-offset n-word-bytes)
1441                                (* 2 index))
1442                             other-pointer-lowtag))
1443           ax-tn)
1444     (move result eax)))
1445 \f
1446 ;;; These VOPs are used for implementing float slots in structures (whose raw
1447 ;;; data is an unsigned-32 vector).
1448 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
1449   (:translate %raw-ref-single)
1450   (:arg-types sb!c::raw-vector positive-fixnum))
1451 (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
1452   (:translate %raw-ref-single)
1453   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1454 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
1455   (:translate %raw-set-single)
1456   (:arg-types sb!c::raw-vector positive-fixnum single-float))
1457 (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
1458   (:translate %raw-set-single)
1459   (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) single-float))
1460 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
1461   (:translate %raw-ref-double)
1462   (:arg-types sb!c::raw-vector positive-fixnum))
1463 (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
1464   (:translate %raw-ref-double)
1465   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1466 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
1467   (:translate %raw-set-double)
1468   (:arg-types sb!c::raw-vector positive-fixnum double-float))
1469 (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
1470   (:translate %raw-set-double)
1471   (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) double-float))
1472 #!+long-float
1473 (define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
1474   (:translate %raw-ref-long)
1475   (:arg-types sb!c::raw-vector positive-fixnum))
1476 #!+long-float
1477 (define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
1478   (:translate %raw-ref-long)
1479   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1480 #!+long-float
1481 (define-vop (raw-set-double data-vector-set/simple-array-long-float)
1482   (:translate %raw-set-long)
1483   (:arg-types sb!c::raw-vector positive-fixnum long-float))
1484 #!+long-float
1485 (define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
1486   (:translate %raw-set-long)
1487   (:arg-types sb!c::raw-vector (:constant (signed-byte 30)) long-float))
1488
1489 ;;;; complex-float raw structure slot accessors
1490
1491 (define-vop (raw-ref-complex-single
1492              data-vector-ref/simple-array-complex-single-float)
1493   (:translate %raw-ref-complex-single)
1494   (:arg-types sb!c::raw-vector positive-fixnum))
1495 (define-vop (raw-ref-complex-single-c
1496              data-vector-ref-c/simple-array-complex-single-float)
1497   (:translate %raw-ref-complex-single)
1498   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1499 (define-vop (raw-set-complex-single
1500              data-vector-set/simple-array-complex-single-float)
1501   (:translate %raw-set-complex-single)
1502   (:arg-types sb!c::raw-vector positive-fixnum complex-single-float))
1503 (define-vop (raw-set-complex-single-c
1504              data-vector-set-c/simple-array-complex-single-float)
1505   (:translate %raw-set-complex-single)
1506   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1507               complex-single-float))
1508 (define-vop (raw-ref-complex-double
1509              data-vector-ref/simple-array-complex-double-float)
1510   (:translate %raw-ref-complex-double)
1511   (:arg-types sb!c::raw-vector positive-fixnum))
1512 (define-vop (raw-ref-complex-double-c
1513              data-vector-ref-c/simple-array-complex-double-float)
1514   (:translate %raw-ref-complex-double)
1515   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1516 (define-vop (raw-set-complex-double
1517              data-vector-set/simple-array-complex-double-float)
1518   (:translate %raw-set-complex-double)
1519   (:arg-types sb!c::raw-vector positive-fixnum complex-double-float))
1520 (define-vop (raw-set-complex-double-c
1521              data-vector-set-c/simple-array-complex-double-float)
1522   (:translate %raw-set-complex-double)
1523   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1524               complex-double-float))
1525 #!+long-float
1526 (define-vop (raw-ref-complex-long
1527              data-vector-ref/simple-array-complex-long-float)
1528   (:translate %raw-ref-complex-long)
1529   (:arg-types sb!c::raw-vector positive-fixnum))
1530 #!+long-float
1531 (define-vop (raw-ref-complex-long-c
1532              data-vector-ref-c/simple-array-complex-long-float)
1533   (:translate %raw-ref-complex-long)
1534   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))))
1535 #!+long-float
1536 (define-vop (raw-set-complex-long
1537              data-vector-set/simple-array-complex-long-float)
1538   (:translate %raw-set-complex-long)
1539   (:arg-types sb!c::raw-vector positive-fixnum complex-long-float))
1540 #!+long-float
1541 (define-vop (raw-set-complex-long-c
1542              data-vector-set-c/simple-array-complex-long-float)
1543   (:translate %raw-set-complex-long)
1544   (:arg-types sb!c::raw-vector (:constant (signed-byte 30))
1545               complex-long-float))
1546
1547 ;;; These vops are useful for accessing the bits of a vector
1548 ;;; irrespective of what type of vector it is.
1549 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1550   unsigned-num %raw-bits)
1551 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1552   unsigned-num %set-raw-bits)
1553 \f
1554 ;;;; miscellaneous array VOPs
1555
1556 (define-vop (get-vector-subtype get-header-data))
1557 (define-vop (set-vector-subtype set-header-data))