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) 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 type-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-type))
  40      (storew header result 0 other-pointer-type))))
  41 \f
  42 ;;;; additional accessors and setters for the array header
  43
  44 (defknown sb!impl::%array-dimension (t index) index
  45   (flushable))
  46 (defknown sb!impl::%set-array-dimension (t index index) index
  47   ())
  48
  49 (define-full-reffer %array-dimension *
  50   array-dimensions-offset other-pointer-type
  51   (any-reg) positive-fixnum sb!impl::%array-dimension)
  52
  53 (define-full-setter %set-array-dimension *
  54   array-dimensions-offset other-pointer-type
  55   (any-reg) positive-fixnum sb!impl::%set-array-dimension)
  56
  57 (defknown sb!impl::%array-rank (t) index (flushable))
  58
  59 (define-vop (array-rank-vop)
  60   (:translate sb!impl::%array-rank)
  61   (:policy :fast-safe)
  62   (:args (x :scs (descriptor-reg)))
  63   (:results (res :scs (unsigned-reg)))
  64   (:result-types positive-fixnum)
  65   (:generator 6
  66     (loadw res x 0 other-pointer-type)
  67     (inst shr res type-bits)
  68     (inst sub res (1- array-dimensions-offset))))
  69 \f
  70 ;;;; bounds checking routine
  71
  72 ;;; Note that the immediate SC for the index argument is disabled
  73 ;;; because it is not possible to generate a valid error code SC for
  74 ;;; an immediate value.
  75 (define-vop (check-bound)
  76   (:translate %check-bound)
  77   (:policy :fast-safe)
  78   (:args (array :scs (descriptor-reg))
  79          (bound :scs (any-reg descriptor-reg))
  80          (index :scs (any-reg descriptor-reg #+nil immediate) :target result))
  81   (:arg-types * positive-fixnum tagged-num)
  82   (:results (result :scs (any-reg descriptor-reg)))
  83   (:result-types positive-fixnum)
  84   (:vop-var vop)
  85   (:save-p :compute-only)
  86   (:generator 5
  87     (let ((error (generate-error-code vop invalid-array-index-error
  88                                       array bound index))
  89           (index (if (sc-is index immediate)
  90                    (fixnumize (tn-value index))
  91                    index)))
  92       (inst cmp bound index)
  93       ;; We use below-or-equal even though it's an unsigned test,
  94       ;; because negative indexes appear as large unsigned numbers.
  95       ;; Therefore, we get the <0 and >=bound test all rolled into one.
  96       (inst jmp :be error)
  97       (unless (and (tn-p index) (location= result index))
  98         (inst mov result index)))))
  99 \f
 100 ;;;; accessors/setters
 101
 102 ;;; variants built on top of WORD-INDEX-REF, etc. I.e., those vectors
 103 ;;; whose elements are represented in integer registers and are built
 104 ;;; out of 8, 16, or 32 bit elements.
 105 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
 106              `(progn
 107                 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
 108                   ,type vector-data-offset other-pointer-type ,scs
 109                   ,element-type data-vector-ref)
 110                 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
 111                   ,type vector-data-offset other-pointer-type ,scs
 112                   ,element-type data-vector-set))))
 113   (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
 114   (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
 115     unsigned-reg)
 116   (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
 117   (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
 118     signed-reg))
 119 \f
 120 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
 121 ;;;; bit, 2-bit, and 4-bit vectors
 122
 123 (macrolet ((def-small-data-vector-frobs (type bits)
 124              (let* ((elements-per-word (floor sb!vm:word-bits bits))
 125                     (bit-shift (1- (integer-length elements-per-word))))
 126     `(progn
 127        (define-vop (,(symbolicate 'data-vector-ref/ type))
 128          (:note "inline array access")
 129          (:translate data-vector-ref)
 130          (:policy :fast-safe)
 131          (:args (object :scs (descriptor-reg))
 132                 (index :scs (unsigned-reg)))
 133          (:arg-types ,type positive-fixnum)
 134          (:results (result :scs (unsigned-reg) :from (:argument 0)))
 135          (:result-types positive-fixnum)
 136          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
 137          (:generator 20
 138            (move ecx index)
 139            (inst shr ecx ,bit-shift)
 140            (inst mov result
 141                  (make-ea :dword :base object :index ecx :scale 4
 142                           :disp (- (* vector-data-offset word-bytes)
 143                                    other-pointer-type)))
 144            (move ecx index)
 145            (inst and ecx ,(1- elements-per-word))
 146            ,@(unless (= bits 1)
 147                `((inst shl ecx ,(1- (integer-length bits)))))
 148            (inst shr result :cl)
 149            (inst and result ,(1- (ash 1 bits)))))
 150        (define-vop (,(symbolicate 'data-vector-ref-c/ type))
 151          (:translate data-vector-ref)
 152          (:policy :fast-safe)
 153          (:args (object :scs (descriptor-reg)))
 154          (:arg-types ,type (:constant index))
 155          (:info index)
 156          (:results (result :scs (unsigned-reg)))
 157          (:result-types positive-fixnum)
 158          (:generator 15
 159            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 160              (loadw result object (+ word vector-data-offset)
 161                     other-pointer-type)
 162              (unless (zerop extra)
 163                (inst shr result (* extra ,bits)))
 164              (unless (= extra ,(1- elements-per-word))
 165                (inst and result ,(1- (ash 1 bits)))))))
 166        (define-vop (,(symbolicate 'data-vector-set/ type))
 167          (:note "inline array store")
 168          (:translate data-vector-set)
 169          (:policy :fast-safe)
 170          (:args (object :scs (descriptor-reg) :target ptr)
 171                 (index :scs (unsigned-reg) :target ecx)
 172                 (value :scs (unsigned-reg immediate) :target result))
 173          (:arg-types ,type positive-fixnum positive-fixnum)
 174          (:results (result :scs (unsigned-reg)))
 175          (:result-types positive-fixnum)
 176          (:temporary (:sc unsigned-reg) word-index)
 177          (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old)
 178          (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1))
 179                      ecx)
 180          (:generator 25
 181            (move word-index index)
 182            (inst shr word-index ,bit-shift)
 183            (inst lea ptr
 184                  (make-ea :dword :base object :index word-index :scale 4
 185                           :disp (- (* vector-data-offset word-bytes)
 186                                    other-pointer-type)))
 187            (loadw old ptr)
 188            (move ecx index)
 189            (inst and ecx ,(1- elements-per-word))
 190            ,@(unless (= bits 1)
 191                `((inst shl ecx ,(1- (integer-length bits)))))
 192            (inst ror old :cl)
 193            (unless (and (sc-is value immediate)
 194                         (= (tn-value value) ,(1- (ash 1 bits))))
 195              (inst and old ,(lognot (1- (ash 1 bits)))))
 196            (sc-case value
 197              (immediate
 198               (unless (zerop (tn-value value))
 199                 (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
 200              (unsigned-reg
 201               (inst or old value)))
 202            (inst rol old :cl)
 203            (storew old ptr)
 204            (sc-case value
 205              (immediate
 206               (inst mov result (tn-value value)))
 207              (unsigned-reg
 208               (move result value)))))
 209        (define-vop (,(symbolicate 'data-vector-set-c/ type))
 210          (:translate data-vector-set)
 211          (:policy :fast-safe)
 212          (:args (object :scs (descriptor-reg))
 213                 (value :scs (unsigned-reg immediate) :target result))
 214          (:arg-types ,type (:constant index) positive-fixnum)
 215          (:info index)
 216          (:results (result :scs (unsigned-reg)))
 217          (:result-types positive-fixnum)
 218          (:temporary (:sc unsigned-reg :to (:result 0)) old)
 219          (:generator 20
 220            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 221              (inst mov old
 222                    (make-ea :dword :base object
 223                             :disp (- (* (+ word vector-data-offset) word-bytes)
 224                                      other-pointer-type)))
 225              (sc-case value
 226                (immediate
 227                 (let* ((value (tn-value value))
 228                        (mask ,(1- (ash 1 bits)))
 229                        (shift (* extra ,bits)))
 230                   (unless (= value mask)
 231                     (inst and old (lognot (ash mask shift))))
 232                   (unless (zerop value)
 233                     (inst or old (ash value shift)))))
 234                (unsigned-reg
 235                 (let ((shift (* extra ,bits)))
 236                   (unless (zerop shift)
 237                     (inst ror old shift)
 238                     (inst and old (lognot ,(1- (ash 1 bits))))
 239                     (inst or old value)
 240                     (inst rol old shift)))))
 241              (inst mov (make-ea :dword :base object
 242                                 :disp (- (* (+ word vector-data-offset)
 243                                             word-bytes)
 244                                          other-pointer-type))
 245                    old)
 246              (sc-case value
 247                (immediate
 248                 (inst mov result (tn-value value)))
 249                (unsigned-reg
 250                 (move result value))))))))))
 251   (def-small-data-vector-frobs simple-bit-vector 1)
 252   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 253   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 254
 255 ;;; And the float variants.
 256
 257 (define-vop (data-vector-ref/simple-array-single-float)
 258   (:note "inline array access")
 259   (:translate data-vector-ref)
 260   (:policy :fast-safe)
 261   (:args (object :scs (descriptor-reg))
 262          (index :scs (any-reg)))
 263   (:arg-types simple-array-single-float positive-fixnum)
 264   (:results (value :scs (single-reg)))
 265   (:result-types single-float)
 266   (:generator 5
 267    (with-empty-tn@fp-top(value)
 268      (inst fld (make-ea :dword :base object :index index :scale 1
 269                         :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 270                                  sb!vm:other-pointer-type))))))
 271
 272 (define-vop (data-vector-ref-c/simple-array-single-float)
 273   (:note "inline array access")
 274   (:translate data-vector-ref)
 275   (:policy :fast-safe)
 276   (:args (object :scs (descriptor-reg)))
 277   (:info index)
 278   (:arg-types simple-array-single-float (:constant (signed-byte 30)))
 279   (:results (value :scs (single-reg)))
 280   (:result-types single-float)
 281   (:generator 4
 282    (with-empty-tn@fp-top(value)
 283      (inst fld (make-ea :dword :base object
 284                         :disp (- (+ (* sb!vm:vector-data-offset
 285                                        sb!vm:word-bytes)
 286                                     (* 4 index))
 287                                  sb!vm:other-pointer-type))))))
 288
 289 (define-vop (data-vector-set/simple-array-single-float)
 290   (:note "inline array store")
 291   (:translate data-vector-set)
 292   (:policy :fast-safe)
 293   (:args (object :scs (descriptor-reg))
 294          (index :scs (any-reg))
 295          (value :scs (single-reg) :target result))
 296   (:arg-types simple-array-single-float positive-fixnum single-float)
 297   (:results (result :scs (single-reg)))
 298   (:result-types single-float)
 299   (:generator 5
 300     (cond ((zerop (tn-offset value))
 301            ;; Value is in ST0.
 302            (inst fst (make-ea :dword :base object :index index :scale 1
 303                               :disp (- (* sb!vm:vector-data-offset
 304                                           sb!vm:word-bytes)
 305                                        sb!vm:other-pointer-type)))
 306            (unless (zerop (tn-offset result))
 307                    ;; Value is in ST0 but not result.
 308                    (inst fst result)))
 309           (t
 310            ;; Value is not in ST0.
 311            (inst fxch value)
 312            (inst fst (make-ea :dword :base object :index index :scale 1
 313                               :disp (- (* sb!vm:vector-data-offset
 314                                           sb!vm:word-bytes)
 315                                        sb!vm:other-pointer-type)))
 316            (cond ((zerop (tn-offset result))
 317                   ;; The result is in ST0.
 318                   (inst fst value))
 319                  (t
 320                   ;; Neither value or result are in ST0
 321                   (unless (location= value result)
 322                           (inst fst result))
 323                   (inst fxch value)))))))
 324
 325 (define-vop (data-vector-set-c/simple-array-single-float)
 326   (:note "inline array store")
 327   (:translate data-vector-set)
 328   (:policy :fast-safe)
 329   (:args (object :scs (descriptor-reg))
 330          (value :scs (single-reg) :target result))
 331   (:info index)
 332   (:arg-types simple-array-single-float (:constant (signed-byte 30))
 333               single-float)
 334   (:results (result :scs (single-reg)))
 335   (:result-types single-float)
 336   (:generator 4
 337     (cond ((zerop (tn-offset value))
 338            ;; Value is in ST0.
 339            (inst fst (make-ea :dword :base object
 340                               :disp (- (+ (* sb!vm:vector-data-offset
 341                                              sb!vm:word-bytes)
 342                                           (* 4 index))
 343                                        sb!vm:other-pointer-type)))
 344            (unless (zerop (tn-offset result))
 345                    ;; Value is in ST0 but not result.
 346                    (inst fst result)))
 347           (t
 348            ;; Value is not in ST0.
 349            (inst fxch value)
 350            (inst fst (make-ea :dword :base object
 351                               :disp (- (+ (* sb!vm:vector-data-offset
 352                                              sb!vm:word-bytes)
 353                                           (* 4 index))
 354                                        sb!vm:other-pointer-type)))
 355            (cond ((zerop (tn-offset result))
 356                   ;; The result is in ST0.
 357                   (inst fst value))
 358                  (t
 359                   ;; Neither value or result are in ST0
 360                   (unless (location= value result)
 361                           (inst fst result))
 362                   (inst fxch value)))))))
 363
 364 (define-vop (data-vector-ref/simple-array-double-float)
 365   (:note "inline array access")
 366   (:translate data-vector-ref)
 367   (:policy :fast-safe)
 368   (:args (object :scs (descriptor-reg))
 369          (index :scs (any-reg)))
 370   (:arg-types simple-array-double-float positive-fixnum)
 371   (:results (value :scs (double-reg)))
 372   (:result-types double-float)
 373   (:generator 7
 374    (with-empty-tn@fp-top(value)
 375      (inst fldd (make-ea :dword :base object :index index :scale 2
 376                          :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 377                                   sb!vm:other-pointer-type))))))
 378
 379 (define-vop (data-vector-ref-c/simple-array-double-float)
 380   (:note "inline array access")
 381   (:translate data-vector-ref)
 382   (:policy :fast-safe)
 383   (:args (object :scs (descriptor-reg)))
 384   (:info index)
 385   (:arg-types simple-array-double-float (:constant (signed-byte 30)))
 386   (:results (value :scs (double-reg)))
 387   (:result-types double-float)
 388   (:generator 6
 389    (with-empty-tn@fp-top(value)
 390      (inst fldd (make-ea :dword :base object
 391                          :disp (- (+ (* sb!vm:vector-data-offset
 392                                         sb!vm:word-bytes)
 393                                      (* 8 index))
 394                                   sb!vm:other-pointer-type))))))
 395
 396 (define-vop (data-vector-set/simple-array-double-float)
 397   (:note "inline array store")
 398   (:translate data-vector-set)
 399   (:policy :fast-safe)
 400   (:args (object :scs (descriptor-reg))
 401          (index :scs (any-reg))
 402          (value :scs (double-reg) :target result))
 403   (:arg-types simple-array-double-float positive-fixnum double-float)
 404   (:results (result :scs (double-reg)))
 405   (:result-types double-float)
 406   (:generator 20
 407     (cond ((zerop (tn-offset value))
 408            ;; Value is in ST0.
 409            (inst fstd (make-ea :dword :base object :index index :scale 2
 410                                :disp (- (* sb!vm:vector-data-offset
 411                                            sb!vm:word-bytes)
 412                                         sb!vm:other-pointer-type)))
 413            (unless (zerop (tn-offset result))
 414                    ;; Value is in ST0 but not result.
 415                    (inst fstd result)))
 416           (t
 417            ;; Value is not in ST0.
 418            (inst fxch value)
 419            (inst fstd (make-ea :dword :base object :index index :scale 2
 420                                :disp (- (* sb!vm:vector-data-offset
 421                                            sb!vm:word-bytes)
 422                                         sb!vm:other-pointer-type)))
 423            (cond ((zerop (tn-offset result))
 424                   ;; The result is in ST0.
 425                   (inst fstd value))
 426                  (t
 427                   ;; Neither value or result are in ST0
 428                   (unless (location= value result)
 429                           (inst fstd result))
 430                   (inst fxch value)))))))
 431
 432 (define-vop (data-vector-set-c/simple-array-double-float)
 433   (:note "inline array store")
 434   (:translate data-vector-set)
 435   (:policy :fast-safe)
 436   (:args (object :scs (descriptor-reg))
 437          (value :scs (double-reg) :target result))
 438   (:info index)
 439   (:arg-types simple-array-double-float (:constant (signed-byte 30))
 440               double-float)
 441   (:results (result :scs (double-reg)))
 442   (:result-types double-float)
 443   (:generator 19
 444     (cond ((zerop (tn-offset value))
 445            ;; Value is in ST0.
 446            (inst fstd (make-ea :dword :base object
 447                                :disp (- (+ (* sb!vm:vector-data-offset
 448                                               sb!vm:word-bytes)
 449                                            (* 8 index))
 450                                         sb!vm:other-pointer-type)))
 451            (unless (zerop (tn-offset result))
 452                    ;; Value is in ST0 but not result.
 453                    (inst fstd result)))
 454           (t
 455            ;; Value is not in ST0.
 456            (inst fxch value)
 457            (inst fstd (make-ea :dword :base object
 458                                :disp (- (+ (* sb!vm:vector-data-offset
 459                                               sb!vm:word-bytes)
 460                                            (* 8 index))
 461                                         sb!vm:other-pointer-type)))
 462            (cond ((zerop (tn-offset result))
 463                   ;; The result is in ST0.
 464                   (inst fstd value))
 465                  (t
 466                   ;; Neither value or result are in ST0
 467                   (unless (location= value result)
 468                           (inst fstd result))
 469                   (inst fxch value)))))))
 470
 471 #!+long-float
 472 (define-vop (data-vector-ref/simple-array-long-float)
 473   (:note "inline array access")
 474   (:translate data-vector-ref)
 475   (:policy :fast-safe)
 476   (:args (object :scs (descriptor-reg) :to :result)
 477          (index :scs (any-reg)))
 478   (:arg-types simple-array-long-float positive-fixnum)
 479   (:temporary (:sc any-reg :from :eval :to :result) temp)
 480   (:results (value :scs (long-reg)))
 481   (:result-types long-float)
 482   (:generator 7
 483     ;; temp = 3 * index
 484     (inst lea temp (make-ea :dword :base index :index index :scale 2))
 485     (with-empty-tn@fp-top(value)
 486       (inst fldl (make-ea :dword :base object :index temp :scale 1
 487                           :disp (- (* sb!vm:vector-data-offset
 488                                       sb!vm:word-bytes)
 489                                    sb!vm:other-pointer-type))))))
 490
 491 #!+long-float
 492 (define-vop (data-vector-ref-c/simple-array-long-float)
 493   (:note "inline array access")
 494   (:translate data-vector-ref)
 495   (:policy :fast-safe)
 496   (:args (object :scs (descriptor-reg)))
 497   (:info index)
 498   (:arg-types simple-array-long-float (:constant (signed-byte 30)))
 499   (:results (value :scs (long-reg)))
 500   (:result-types long-float)
 501   (:generator 6
 502    (with-empty-tn@fp-top(value)
 503      (inst fldl (make-ea :dword :base object
 504                          :disp (- (+ (* sb!vm:vector-data-offset
 505                                         sb!vm:word-bytes)
 506                                      (* 12 index))
 507                                   sb!vm:other-pointer-type))))))
 508
 509 #!+long-float
 510 (define-vop (data-vector-set/simple-array-long-float)
 511   (:note "inline array store")
 512   (:translate data-vector-set)
 513   (:policy :fast-safe)
 514   (:args (object :scs (descriptor-reg) :to :result)
 515          (index :scs (any-reg))
 516          (value :scs (long-reg) :target result))
 517   (:arg-types simple-array-long-float positive-fixnum long-float)
 518   (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
 519   (:results (result :scs (long-reg)))
 520   (:result-types long-float)
 521   (:generator 20
 522     ;; temp = 3 * index
 523     (inst lea temp (make-ea :dword :base index :index index :scale 2))
 524     (cond ((zerop (tn-offset value))
 525            ;; Value is in ST0.
 526            (store-long-float
 527             (make-ea :dword :base object :index temp :scale 1
 528                      :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 529                               sb!vm:other-pointer-type)))
 530            (unless (zerop (tn-offset result))
 531                    ;; Value is in ST0 but not result.
 532                    (inst fstd result)))
 533           (t
 534            ;; Value is not in ST0.
 535            (inst fxch value)
 536            (store-long-float
 537             (make-ea :dword :base object :index temp :scale 1
 538                      :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 539                               sb!vm:other-pointer-type)))
 540            (cond ((zerop (tn-offset result))
 541                   ;; The result is in ST0.
 542                   (inst fstd value))
 543                  (t
 544                   ;; Neither value or result are in ST0
 545                   (unless (location= value result)
 546                     (inst fstd result))
 547                   (inst fxch value)))))))
 548
 549 #!+long-float
 550 (define-vop (data-vector-set-c/simple-array-long-float)
 551   (:note "inline array store")
 552   (:translate data-vector-set)
 553   (:policy :fast-safe)
 554   (:args (object :scs (descriptor-reg))
 555          (value :scs (long-reg) :target result))
 556   (:info index)
 557   (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
 558   (:results (result :scs (long-reg)))
 559   (:result-types long-float)
 560   (:generator 19
 561     (cond ((zerop (tn-offset value))
 562            ;; Value is in ST0.
 563            (store-long-float (make-ea :dword :base object
 564                                       :disp (- (+ (* sb!vm:vector-data-offset
 565                                                      sb!vm:word-bytes)
 566                                                   (* 12 index))
 567                                                sb!vm:other-pointer-type)))
 568            (unless (zerop (tn-offset result))
 569              ;; Value is in ST0 but not result.
 570              (inst fstd result)))
 571           (t
 572            ;; Value is not in ST0.
 573            (inst fxch value)
 574            (store-long-float (make-ea :dword :base object
 575                                       :disp (- (+ (* sb!vm:vector-data-offset
 576                                                      sb!vm:word-bytes)
 577                                                   (* 12 index))
 578                                                sb!vm:other-pointer-type)))
 579            (cond ((zerop (tn-offset result))
 580                   ;; The result is in ST0.
 581                   (inst fstd value))
 582                  (t
 583                   ;; Neither value or result are in ST0
 584                   (unless (location= value result)
 585                     (inst fstd result))
 586                   (inst fxch value)))))))
 587
 588 ;;; complex float variants
 589
 590 (define-vop (data-vector-ref/simple-array-complex-single-float)
 591   (:note "inline array access")
 592   (:translate data-vector-ref)
 593   (:policy :fast-safe)
 594   (:args (object :scs (descriptor-reg))
 595          (index :scs (any-reg)))
 596   (:arg-types simple-array-complex-single-float positive-fixnum)
 597   (:results (value :scs (complex-single-reg)))
 598   (:result-types complex-single-float)
 599   (:generator 5
 600     (let ((real-tn (complex-single-reg-real-tn value)))
 601       (with-empty-tn@fp-top (real-tn)
 602         (inst fld (make-ea :dword :base object :index index :scale 2
 603                            :disp (- (* sb!vm:vector-data-offset
 604                                        sb!vm:word-bytes)
 605                                     sb!vm:other-pointer-type)))))
 606     (let ((imag-tn (complex-single-reg-imag-tn value)))
 607       (with-empty-tn@fp-top (imag-tn)
 608         (inst fld (make-ea :dword :base object :index index :scale 2
 609                            :disp (- (* (1+ sb!vm:vector-data-offset)
 610                                        sb!vm:word-bytes)
 611                                     sb!vm:other-pointer-type)))))))
 612
 613 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
 614   (:note "inline array access")
 615   (:translate data-vector-ref)
 616   (:policy :fast-safe)
 617   (:args (object :scs (descriptor-reg)))
 618   (:info index)
 619   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
 620   (:results (value :scs (complex-single-reg)))
 621   (:result-types complex-single-float)
 622   (:generator 4
 623     (let ((real-tn (complex-single-reg-real-tn value)))
 624       (with-empty-tn@fp-top (real-tn)
 625         (inst fld (make-ea :dword :base object
 626                            :disp (- (+ (* sb!vm:vector-data-offset
 627                                           sb!vm:word-bytes)
 628                                        (* 8 index))
 629                                     sb!vm:other-pointer-type)))))
 630     (let ((imag-tn (complex-single-reg-imag-tn value)))
 631       (with-empty-tn@fp-top (imag-tn)
 632         (inst fld (make-ea :dword :base object
 633                            :disp (- (+ (* sb!vm:vector-data-offset
 634                                           sb!vm:word-bytes)
 635                                        (* 8 index) 4)
 636                                     sb!vm:other-pointer-type)))))))
 637
 638 (define-vop (data-vector-set/simple-array-complex-single-float)
 639   (:note "inline array store")
 640   (:translate data-vector-set)
 641   (:policy :fast-safe)
 642   (:args (object :scs (descriptor-reg))
 643          (index :scs (any-reg))
 644          (value :scs (complex-single-reg) :target result))
 645   (:arg-types simple-array-complex-single-float positive-fixnum
 646               complex-single-float)
 647   (:results (result :scs (complex-single-reg)))
 648   (:result-types complex-single-float)
 649   (:generator 5
 650     (let ((value-real (complex-single-reg-real-tn value))
 651           (result-real (complex-single-reg-real-tn result)))
 652       (cond ((zerop (tn-offset value-real))
 653              ;; Value is in ST0.
 654              (inst fst (make-ea :dword :base object :index index :scale 2
 655                                 :disp (- (* sb!vm:vector-data-offset
 656                                             sb!vm:word-bytes)
 657                                          sb!vm:other-pointer-type)))
 658              (unless (zerop (tn-offset result-real))
 659                ;; Value is in ST0 but not result.
 660                (inst fst result-real)))
 661             (t
 662              ;; Value is not in ST0.
 663              (inst fxch value-real)
 664              (inst fst (make-ea :dword :base object :index index :scale 2
 665                                 :disp (- (* sb!vm:vector-data-offset
 666                                             sb!vm:word-bytes)
 667                                          sb!vm:other-pointer-type)))
 668              (cond ((zerop (tn-offset result-real))
 669                     ;; The result is in ST0.
 670                     (inst fst value-real))
 671                    (t
 672                     ;; Neither value or result are in ST0
 673                     (unless (location= value-real result-real)
 674                       (inst fst result-real))
 675                     (inst fxch value-real))))))
 676     (let ((value-imag (complex-single-reg-imag-tn value))
 677           (result-imag (complex-single-reg-imag-tn result)))
 678       (inst fxch value-imag)
 679       (inst fst (make-ea :dword :base object :index index :scale 2
 680                          :disp (- (+ (* sb!vm:vector-data-offset
 681                                         sb!vm:word-bytes)
 682                                      4)
 683                                   sb!vm:other-pointer-type)))
 684       (unless (location= value-imag result-imag)
 685         (inst fst result-imag))
 686       (inst fxch value-imag))))
 687
 688 (define-vop (data-vector-set-c/simple-array-complex-single-float)
 689   (:note "inline array store")
 690   (:translate data-vector-set)
 691   (:policy :fast-safe)
 692   (:args (object :scs (descriptor-reg))
 693          (value :scs (complex-single-reg) :target result))
 694   (:info index)
 695   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
 696               complex-single-float)
 697   (:results (result :scs (complex-single-reg)))
 698   (:result-types complex-single-float)
 699   (:generator 4
 700     (let ((value-real (complex-single-reg-real-tn value))
 701           (result-real (complex-single-reg-real-tn result)))
 702       (cond ((zerop (tn-offset value-real))
 703              ;; Value is in ST0.
 704              (inst fst (make-ea :dword :base object
 705                                 :disp (- (+ (* sb!vm:vector-data-offset
 706                                                sb!vm:word-bytes)
 707                                             (* 8 index))
 708                                          sb!vm:other-pointer-type)))
 709              (unless (zerop (tn-offset result-real))
 710                ;; Value is in ST0 but not result.
 711                (inst fst result-real)))
 712             (t
 713              ;; Value is not in ST0.
 714              (inst fxch value-real)
 715              (inst fst (make-ea :dword :base object
 716                                 :disp (- (+ (* sb!vm:vector-data-offset
 717                                                sb!vm:word-bytes)
 718                                             (* 8 index))
 719                                          sb!vm:other-pointer-type)))
 720              (cond ((zerop (tn-offset result-real))
 721                     ;; The result is in ST0.
 722                     (inst fst value-real))
 723                    (t
 724                     ;; Neither value or result are in ST0
 725                     (unless (location= value-real result-real)
 726                       (inst fst result-real))
 727                     (inst fxch value-real))))))
 728     (let ((value-imag (complex-single-reg-imag-tn value))
 729           (result-imag (complex-single-reg-imag-tn result)))
 730       (inst fxch value-imag)
 731       (inst fst (make-ea :dword :base object
 732                          :disp (- (+ (* sb!vm:vector-data-offset
 733                                         sb!vm:word-bytes)
 734                                      (* 8 index) 4)
 735                                   sb!vm:other-pointer-type)))
 736       (unless (location= value-imag result-imag)
 737         (inst fst result-imag))
 738       (inst fxch value-imag))))
 739
 740
 741 (define-vop (data-vector-ref/simple-array-complex-double-float)
 742   (:note "inline array access")
 743   (:translate data-vector-ref)
 744   (:policy :fast-safe)
 745   (:args (object :scs (descriptor-reg))
 746          (index :scs (any-reg)))
 747   (:arg-types simple-array-complex-double-float positive-fixnum)
 748   (:results (value :scs (complex-double-reg)))
 749   (:result-types complex-double-float)
 750   (:generator 7
 751     (let ((real-tn (complex-double-reg-real-tn value)))
 752       (with-empty-tn@fp-top (real-tn)
 753         (inst fldd (make-ea :dword :base object :index index :scale 4
 754                             :disp (- (* sb!vm:vector-data-offset
 755                                         sb!vm:word-bytes)
 756                                      sb!vm:other-pointer-type)))))
 757     (let ((imag-tn (complex-double-reg-imag-tn value)))
 758       (with-empty-tn@fp-top (imag-tn)
 759         (inst fldd (make-ea :dword :base object :index index :scale 4
 760                             :disp (- (+ (* sb!vm:vector-data-offset
 761                                            sb!vm:word-bytes)
 762                                         8)
 763                                      sb!vm:other-pointer-type)))))))
 764
 765 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
 766   (:note "inline array access")
 767   (:translate data-vector-ref)
 768   (:policy :fast-safe)
 769   (:args (object :scs (descriptor-reg)))
 770   (:info index)
 771   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
 772   (:results (value :scs (complex-double-reg)))
 773   (:result-types complex-double-float)
 774   (:generator 6
 775     (let ((real-tn (complex-double-reg-real-tn value)))
 776       (with-empty-tn@fp-top (real-tn)
 777         (inst fldd (make-ea :dword :base object
 778                             :disp (- (+ (* sb!vm:vector-data-offset
 779                                            sb!vm:word-bytes)
 780                                         (* 16 index))
 781                                      sb!vm:other-pointer-type)))))
 782     (let ((imag-tn (complex-double-reg-imag-tn value)))
 783       (with-empty-tn@fp-top (imag-tn)
 784         (inst fldd (make-ea :dword :base object
 785                             :disp (- (+ (* sb!vm:vector-data-offset
 786                                            sb!vm:word-bytes)
 787                                         (* 16 index) 8)
 788                                      sb!vm:other-pointer-type)))))))
 789
 790 (define-vop (data-vector-set/simple-array-complex-double-float)
 791   (:note "inline array store")
 792   (:translate data-vector-set)
 793   (:policy :fast-safe)
 794   (:args (object :scs (descriptor-reg))
 795          (index :scs (any-reg))
 796          (value :scs (complex-double-reg) :target result))
 797   (:arg-types simple-array-complex-double-float positive-fixnum
 798               complex-double-float)
 799   (:results (result :scs (complex-double-reg)))
 800   (:result-types complex-double-float)
 801   (:generator 20
 802     (let ((value-real (complex-double-reg-real-tn value))
 803           (result-real (complex-double-reg-real-tn result)))
 804       (cond ((zerop (tn-offset value-real))
 805              ;; Value is in ST0.
 806              (inst fstd (make-ea :dword :base object :index index :scale 4
 807                                  :disp (- (* sb!vm:vector-data-offset
 808                                              sb!vm:word-bytes)
 809                                           sb!vm:other-pointer-type)))
 810              (unless (zerop (tn-offset result-real))
 811                ;; Value is in ST0 but not result.
 812                (inst fstd result-real)))
 813             (t
 814              ;; Value is not in ST0.
 815              (inst fxch value-real)
 816              (inst fstd (make-ea :dword :base object :index index :scale 4
 817                                  :disp (- (* sb!vm:vector-data-offset
 818                                              sb!vm:word-bytes)
 819                                           sb!vm:other-pointer-type)))
 820              (cond ((zerop (tn-offset result-real))
 821                     ;; The result is in ST0.
 822                     (inst fstd value-real))
 823                    (t
 824                     ;; Neither value or result are in ST0
 825                     (unless (location= value-real result-real)
 826                       (inst fstd result-real))
 827                     (inst fxch value-real))))))
 828     (let ((value-imag (complex-double-reg-imag-tn value))
 829           (result-imag (complex-double-reg-imag-tn result)))
 830       (inst fxch value-imag)
 831       (inst fstd (make-ea :dword :base object :index index :scale 4
 832                           :disp (- (+ (* sb!vm:vector-data-offset
 833                                          sb!vm:word-bytes)
 834                                       8)
 835                                    sb!vm:other-pointer-type)))
 836       (unless (location= value-imag result-imag)
 837         (inst fstd result-imag))
 838       (inst fxch value-imag))))
 839
 840 (define-vop (data-vector-set-c/simple-array-complex-double-float)
 841   (:note "inline array store")
 842   (:translate data-vector-set)
 843   (:policy :fast-safe)
 844   (:args (object :scs (descriptor-reg))
 845          (value :scs (complex-double-reg) :target result))
 846   (:info index)
 847   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
 848               complex-double-float)
 849   (:results (result :scs (complex-double-reg)))
 850   (:result-types complex-double-float)
 851   (:generator 19
 852     (let ((value-real (complex-double-reg-real-tn value))
 853           (result-real (complex-double-reg-real-tn result)))
 854       (cond ((zerop (tn-offset value-real))
 855              ;; Value is in ST0.
 856              (inst fstd (make-ea :dword :base object
 857                                  :disp (- (+ (* sb!vm:vector-data-offset
 858                                                 sb!vm:word-bytes)
 859                                              (* 16 index))
 860                                           sb!vm:other-pointer-type)))
 861              (unless (zerop (tn-offset result-real))
 862                ;; Value is in ST0 but not result.
 863                (inst fstd result-real)))
 864             (t
 865              ;; Value is not in ST0.
 866              (inst fxch value-real)
 867              (inst fstd (make-ea :dword :base object
 868                                  :disp (- (+ (* sb!vm:vector-data-offset
 869                                                 sb!vm:word-bytes)
 870                                              (* 16 index))
 871                                           sb!vm:other-pointer-type)))
 872              (cond ((zerop (tn-offset result-real))
 873                     ;; The result is in ST0.
 874                     (inst fstd value-real))
 875                    (t
 876                     ;; Neither value or result are in ST0
 877                     (unless (location= value-real result-real)
 878                       (inst fstd result-real))
 879                     (inst fxch value-real))))))
 880     (let ((value-imag (complex-double-reg-imag-tn value))
 881           (result-imag (complex-double-reg-imag-tn result)))
 882       (inst fxch value-imag)
 883       (inst fstd (make-ea :dword :base object
 884                           :disp (- (+ (* sb!vm:vector-data-offset
 885                                          sb!vm:word-bytes)
 886                                       (* 16 index) 8)
 887                                    sb!vm:other-pointer-type)))
 888       (unless (location= value-imag result-imag)
 889         (inst fstd result-imag))
 890       (inst fxch value-imag))))
 891
 892
 893 #!+long-float
 894 (define-vop (data-vector-ref/simple-array-complex-long-float)
 895   (:note "inline array access")
 896   (:translate data-vector-ref)
 897   (:policy :fast-safe)
 898   (:args (object :scs (descriptor-reg) :to :result)
 899          (index :scs (any-reg)))
 900   (:arg-types simple-array-complex-long-float positive-fixnum)
 901   (:temporary (:sc any-reg :from :eval :to :result) temp)
 902   (:results (value :scs (complex-long-reg)))
 903   (:result-types complex-long-float)
 904   (:generator 7
 905     ;; temp = 3 * index
 906     (inst lea temp (make-ea :dword :base index :index index :scale 2))
 907     (let ((real-tn (complex-long-reg-real-tn value)))
 908       (with-empty-tn@fp-top (real-tn)
 909         (inst fldl (make-ea :dword :base object :index temp :scale 2
 910                             :disp (- (* sb!vm:vector-data-offset
 911                                         sb!vm:word-bytes)
 912                                      sb!vm:other-pointer-type)))))
 913     (let ((imag-tn (complex-long-reg-imag-tn value)))
 914       (with-empty-tn@fp-top (imag-tn)
 915         (inst fldl (make-ea :dword :base object :index temp :scale 2
 916                             :disp (- (+ (* sb!vm:vector-data-offset
 917                                            sb!vm:word-bytes)
 918                                         12)
 919                                      sb!vm:other-pointer-type)))))))
 920
 921 #!+long-float
 922 (define-vop (data-vector-ref-c/simple-array-complex-long-float)
 923   (:note "inline array access")
 924   (:translate data-vector-ref)
 925   (:policy :fast-safe)
 926   (:args (object :scs (descriptor-reg)))
 927   (:info index)
 928   (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
 929   (:results (value :scs (complex-long-reg)))
 930   (:result-types complex-long-float)
 931   (:generator 6
 932     (let ((real-tn (complex-long-reg-real-tn value)))
 933       (with-empty-tn@fp-top (real-tn)
 934         (inst fldl (make-ea :dword :base object
 935                             :disp (- (+ (* sb!vm:vector-data-offset
 936                                            sb!vm:word-bytes)
 937                                         (* 24 index))
 938                                      sb!vm:other-pointer-type)))))
 939     (let ((imag-tn (complex-long-reg-imag-tn value)))
 940       (with-empty-tn@fp-top (imag-tn)
 941         (inst fldl (make-ea :dword :base object
 942                             :disp (- (+ (* sb!vm:vector-data-offset
 943                                            sb!vm:word-bytes)
 944                                         (* 24 index) 12)
 945                                      sb!vm:other-pointer-type)))))))
 946
 947 #!+long-float
 948 (define-vop (data-vector-set/simple-array-complex-long-float)
 949   (:note "inline array store")
 950   (:translate data-vector-set)
 951   (:policy :fast-safe)
 952   (:args (object :scs (descriptor-reg) :to :result)
 953          (index :scs (any-reg))
 954          (value :scs (complex-long-reg) :target result))
 955   (:arg-types simple-array-complex-long-float positive-fixnum
 956               complex-long-float)
 957   (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
 958   (:results (result :scs (complex-long-reg)))
 959   (:result-types complex-long-float)
 960   (:generator 20
 961     ;; temp = 3 * index
 962     (inst lea temp (make-ea :dword :base index :index index :scale 2))
 963     (let ((value-real (complex-long-reg-real-tn value))
 964           (result-real (complex-long-reg-real-tn result)))
 965       (cond ((zerop (tn-offset value-real))
 966              ;; Value is in ST0.
 967              (store-long-float
 968               (make-ea :dword :base object :index temp :scale 2
 969                        :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 970                                 sb!vm:other-pointer-type)))
 971              (unless (zerop (tn-offset result-real))
 972                ;; Value is in ST0 but not result.
 973                (inst fstd result-real)))
 974             (t
 975              ;; Value is not in ST0.
 976              (inst fxch value-real)
 977              (store-long-float
 978               (make-ea :dword :base object :index temp :scale 2
 979                        :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 980                                 sb!vm:other-pointer-type)))
 981              (cond ((zerop (tn-offset result-real))
 982                     ;; The result is in ST0.
 983                     (inst fstd value-real))
 984                    (t
 985                     ;; Neither value or result are in ST0
 986                     (unless (location= value-real result-real)
 987                       (inst fstd result-real))
 988                     (inst fxch value-real))))))
 989     (let ((value-imag (complex-long-reg-imag-tn value))
 990           (result-imag (complex-long-reg-imag-tn result)))
 991       (inst fxch value-imag)
 992       (store-long-float
 993        (make-ea :dword :base object :index temp :scale 2
 994                 :disp (- (+ (* sb!vm:vector-data-offset sb!vm:word-bytes) 12)
 995                          sb!vm:other-pointer-type)))
 996       (unless (location= value-imag result-imag)
 997         (inst fstd result-imag))
 998       (inst fxch value-imag))))
 999
1000 #!+long-float
1001 (define-vop (data-vector-set-c/simple-array-complex-long-float)
1002   (:note "inline array store")
1003   (:translate data-vector-set)
1004   (:policy :fast-safe)
1005   (:args (object :scs (descriptor-reg))
1006          (value :scs (complex-long-reg) :target result))
1007   (:info index)
1008   (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
1009               complex-long-float)
1010   (:results (result :scs (complex-long-reg)))
1011   (:result-types complex-long-float)
1012   (:generator 19
1013     (let ((value-real (complex-long-reg-real-tn value))
1014           (result-real (complex-long-reg-real-tn result)))
1015       (cond ((zerop (tn-offset value-real))
1016              ;; Value is in ST0.
1017              (store-long-float
1018               (make-ea :dword :base object
1019                        :disp (- (+ (* sb!vm:vector-data-offset
1020                                       sb!vm:word-bytes)
1021                                    (* 24 index))
1022                                 sb!vm:other-pointer-type)))
1023              (unless (zerop (tn-offset result-real))
1024                ;; Value is in ST0 but not result.
1025                (inst fstd result-real)))
1026             (t
1027              ;; Value is not in ST0.
1028              (inst fxch value-real)
1029              (store-long-float
1030               (make-ea :dword :base object
1031                        :disp (- (+ (* sb!vm:vector-data-offset
1032                                       sb!vm:word-bytes)
1033                                    (* 24 index))
1034                                 sb!vm:other-pointer-type)))
1035              (cond ((zerop (tn-offset result-real))
1036                     ;; The result is in ST0.
1037                     (inst fstd value-real))
1038                    (t
1039                     ;; Neither value or result are in ST0
1040                     (unless (location= value-real result-real)
1041                       (inst fstd result-real))
1042                     (inst fxch value-real))))))
1043     (let ((value-imag (complex-long-reg-imag-tn value))
1044           (result-imag (complex-long-reg-imag-tn result)))
1045       (inst fxch value-imag)
1046       (store-long-float
1047        (make-ea :dword :base object
1048                 :disp (- (+ (* sb!vm:vector-data-offset
1049                                sb!vm:word-bytes)
1050                             ;; FIXME: There are so many of these bare constants
1051                             ;; (24, 12..) in the LONG-FLOAT code that it's
1052                             ;; ridiculous. I should probably just delete it all
1053                             ;; instead of appearing to flirt with supporting
1054                             ;; this maintenance nightmare.
1055                             (* 24 index) 12)
1056                          sb!vm:other-pointer-type)))
1057       (unless (location= value-imag result-imag)
1058         (inst fstd result-imag))
1059       (inst fxch value-imag))))
1060 \f
1061 ;;; unsigned-byte-8
1062
1063 (define-vop (data-vector-ref/simple-array-unsigned-byte-8)
1064   (:translate data-vector-ref)
1065   (:policy :fast-safe)
1066   (:args (object :scs (descriptor-reg))
1067          (index :scs (unsigned-reg)))
1068   (:arg-types simple-array-unsigned-byte-8 positive-fixnum)
1069   (:results (value :scs (unsigned-reg signed-reg)))
1070   (:result-types positive-fixnum)
1071   (:generator 5
1072     (inst movzx value
1073           (make-ea :byte :base object :index index :scale 1
1074                    :disp (- (* vector-data-offset word-bytes)
1075                             other-pointer-type)))))
1076
1077 (define-vop (data-vector-ref-c/simple-array-unsigned-byte-8)
1078   (:translate data-vector-ref)
1079   (:policy :fast-safe)
1080   (:args (object :scs (descriptor-reg)))
1081   (:info index)
1082   (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)))
1083   (:results (value :scs (unsigned-reg signed-reg)))
1084   (:result-types positive-fixnum)
1085   (:generator 4
1086     (inst movzx value
1087           (make-ea :byte :base object
1088                    :disp (- (+ (* vector-data-offset word-bytes) index)
1089                             other-pointer-type)))))
1090
1091 (define-vop (data-vector-set/simple-array-unsigned-byte-8)
1092   (:translate data-vector-set)
1093   (:policy :fast-safe)
1094   (:args (object :scs (descriptor-reg) :to (:eval 0))
1095          (index :scs (unsigned-reg) :to (:eval 0))
1096          (value :scs (unsigned-reg signed-reg) :target eax))
1097   (:arg-types simple-array-unsigned-byte-8 positive-fixnum positive-fixnum)
1098   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1099                    :from (:argument 2) :to (:result 0))
1100               eax)
1101   (:results (result :scs (unsigned-reg signed-reg)))
1102   (:result-types positive-fixnum)
1103   (:generator 5
1104     (move eax value)
1105     (inst mov (make-ea :byte :base object :index index :scale 1
1106                        :disp (- (* vector-data-offset word-bytes)
1107                                 other-pointer-type))
1108           al-tn)
1109     (move result eax)))
1110
1111 (define-vop (data-vector-set-c/simple-array-unsigned-byte-8)
1112   (:translate data-vector-set)
1113   (:policy :fast-safe)
1114   (:args (object :scs (descriptor-reg) :to (:eval 0))
1115          (value :scs (unsigned-reg signed-reg) :target eax))
1116   (:info index)
1117   (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30))
1118               positive-fixnum)
1119   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1120                    :from (:argument 1) :to (:result 0))
1121               eax)
1122   (:results (result :scs (unsigned-reg signed-reg)))
1123   (:result-types positive-fixnum)
1124   (:generator 4
1125     (move eax value)
1126     (inst mov (make-ea :byte :base object
1127                        :disp (- (+ (* vector-data-offset word-bytes) index)
1128                                 other-pointer-type))
1129           al-tn)
1130     (move result eax)))
1131
1132 ;;; unsigned-byte-16
1133
1134 (define-vop (data-vector-ref/simple-array-unsigned-byte-16)
1135   (:translate data-vector-ref)
1136   (:policy :fast-safe)
1137   (:args (object :scs (descriptor-reg))
1138          (index :scs (unsigned-reg)))
1139   (:arg-types simple-array-unsigned-byte-16 positive-fixnum)
1140   (:results (value :scs (unsigned-reg signed-reg)))
1141   (:result-types positive-fixnum)
1142   (:generator 5
1143     (inst movzx value
1144           (make-ea :word :base object :index index :scale 2
1145                    :disp (- (* vector-data-offset word-bytes)
1146                             other-pointer-type)))))
1147
1148 (define-vop (data-vector-ref-c/simple-array-unsigned-byte-16)
1149   (:translate data-vector-ref)
1150   (:policy :fast-safe)
1151   (:args (object :scs (descriptor-reg)))
1152   (:info index)
1153   (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30)))
1154   (:results (value :scs (unsigned-reg signed-reg)))
1155   (:result-types positive-fixnum)
1156   (:generator 4
1157     (inst movzx value
1158           (make-ea :word :base object
1159                    :disp (- (+ (* vector-data-offset word-bytes) (* 2 index))
1160                             other-pointer-type)))))
1161
1162 (define-vop (data-vector-set/simple-array-unsigned-byte-16)
1163   (:translate data-vector-set)
1164   (:policy :fast-safe)
1165   (:args (object :scs (descriptor-reg) :to (:eval 0))
1166          (index :scs (unsigned-reg) :to (:eval 0))
1167          (value :scs (unsigned-reg signed-reg) :target eax))
1168   (:arg-types simple-array-unsigned-byte-16 positive-fixnum positive-fixnum)
1169   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1170                    :from (:argument 2) :to (:result 0))
1171               eax)
1172   (:results (result :scs (unsigned-reg signed-reg)))
1173   (:result-types positive-fixnum)
1174   (:generator 5
1175     (move eax value)
1176     (inst mov (make-ea :word :base object :index index :scale 2
1177                        :disp (- (* vector-data-offset word-bytes)
1178                                 other-pointer-type))
1179           ax-tn)
1180     (move result eax)))
1181
1182 (define-vop (data-vector-set-c/simple-array-unsigned-byte-16)
1183   (:translate data-vector-set)
1184   (:policy :fast-safe)
1185   (:args (object :scs (descriptor-reg) :to (:eval 0))
1186          (value :scs (unsigned-reg signed-reg) :target eax))
1187   (:info index)
1188   (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30))
1189               positive-fixnum)
1190   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1191                    :from (:argument 1) :to (:result 0))
1192               eax)
1193   (:results (result :scs (unsigned-reg signed-reg)))
1194   (:result-types positive-fixnum)
1195   (:generator 4
1196     (move eax value)
1197     (inst mov (make-ea :word :base object
1198                        :disp (- (+ (* vector-data-offset word-bytes)
1199                                    (* 2 index))
1200                                 other-pointer-type))
1201           ax-tn)
1202     (move result eax)))
1203
1204 ;;; simple-string
1205
1206 (define-vop (data-vector-ref/simple-string)
1207   (:translate data-vector-ref)
1208   (:policy :fast-safe)
1209   (:args (object :scs (descriptor-reg))
1210          (index :scs (unsigned-reg)))
1211   (:arg-types simple-string positive-fixnum)
1212   (:temporary (:sc unsigned-reg ; byte-reg
1213                    :offset eax-offset ; al-offset
1214                    :target value
1215                    :from (:eval 0) :to (:result 0))
1216               eax)
1217   (:ignore eax)
1218   (:results (value :scs (base-char-reg)))
1219   (:result-types base-char)
1220   (:generator 5
1221     (inst mov al-tn
1222           (make-ea :byte :base object :index index :scale 1
1223                    :disp (- (* vector-data-offset word-bytes)
1224                             other-pointer-type)))
1225     (move value al-tn)))
1226
1227 (define-vop (data-vector-ref-c/simple-string)
1228   (:translate data-vector-ref)
1229   (:policy :fast-safe)
1230   (:args (object :scs (descriptor-reg)))
1231   (:info index)
1232   (:arg-types simple-string (:constant (signed-byte 30)))
1233   (:temporary (:sc unsigned-reg :offset eax-offset :target value
1234                    :from (:eval 0) :to (:result 0))
1235               eax)
1236   (:ignore eax)
1237   (:results (value :scs (base-char-reg)))
1238   (:result-types base-char)
1239   (:generator 4
1240     (inst mov al-tn
1241           (make-ea :byte :base object
1242                    :disp (- (+ (* vector-data-offset word-bytes) index)
1243                             other-pointer-type)))
1244     (move value al-tn)))
1245
1246 (define-vop (data-vector-set/simple-string)
1247   (:translate data-vector-set)
1248   (:policy :fast-safe)
1249   (:args (object :scs (descriptor-reg) :to (:eval 0))
1250          (index :scs (unsigned-reg) :to (:eval 0))
1251          (value :scs (base-char-reg)))
1252   (:arg-types simple-string positive-fixnum base-char)
1253   (:results (result :scs (base-char-reg)))
1254   (:result-types base-char)
1255   (:generator 5
1256     (inst mov (make-ea :byte :base object :index index :scale 1
1257                        :disp (- (* vector-data-offset word-bytes)
1258                                 other-pointer-type))
1259           value)
1260     (move result value)))
1261
1262 (define-vop (data-vector-set/simple-string-c)
1263   (:translate data-vector-set)
1264   (:policy :fast-safe)
1265   (:args (object :scs (descriptor-reg) :to (:eval 0))
1266          (value :scs (base-char-reg)))
1267   (:info index)
1268   (:arg-types simple-string (:constant (signed-byte 30)) base-char)
1269   (:results (result :scs (base-char-reg)))
1270   (:result-types base-char)
1271   (:generator 4
1272    (inst mov (make-ea :byte :base object
1273                       :disp (- (+ (* vector-data-offset word-bytes) index)
1274                                other-pointer-type))
1275          value)
1276    (move result value)))
1277
1278 ;;; signed-byte-8
1279
1280 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1281   (:translate data-vector-ref)
1282   (:policy :fast-safe)
1283   (:args (object :scs (descriptor-reg))
1284          (index :scs (unsigned-reg)))
1285   (:arg-types simple-array-signed-byte-8 positive-fixnum)
1286   (:results (value :scs (signed-reg)))
1287   (:result-types tagged-num)
1288   (:generator 5
1289     (inst movsx value
1290           (make-ea :byte :base object :index index :scale 1
1291                    :disp (- (* vector-data-offset word-bytes)
1292                             other-pointer-type)))))
1293
1294 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1295   (:translate data-vector-ref)
1296   (:policy :fast-safe)
1297   (:args (object :scs (descriptor-reg)))
1298   (:info index)
1299   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1300   (:results (value :scs (signed-reg)))
1301   (:result-types tagged-num)
1302   (:generator 4
1303     (inst movsx value
1304           (make-ea :byte :base object
1305                    :disp (- (+ (* vector-data-offset word-bytes) index)
1306                             other-pointer-type)))))
1307
1308 (define-vop (data-vector-set/simple-array-signed-byte-8)
1309   (:translate data-vector-set)
1310   (:policy :fast-safe)
1311   (:args (object :scs (descriptor-reg) :to (:eval 0))
1312          (index :scs (unsigned-reg) :to (:eval 0))
1313          (value :scs (signed-reg) :target eax))
1314   (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1315   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1316                    :from (:argument 2) :to (:result 0))
1317               eax)
1318   (:results (result :scs (signed-reg)))
1319   (:result-types tagged-num)
1320   (:generator 5
1321     (move eax value)
1322     (inst mov (make-ea :byte :base object :index index :scale 1
1323                        :disp (- (* vector-data-offset word-bytes)
1324                                 other-pointer-type))
1325           al-tn)
1326     (move result eax)))
1327
1328 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1329   (:translate data-vector-set)
1330   (:policy :fast-safe)
1331   (:args (object :scs (descriptor-reg) :to (:eval 0))
1332          (value :scs (signed-reg) :target eax))
1333   (:info index)
1334   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1335               tagged-num)
1336   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1337                    :from (:argument 1) :to (:result 0))
1338               eax)
1339   (:results (result :scs (signed-reg)))
1340   (:result-types tagged-num)
1341   (:generator 4
1342     (move eax value)
1343     (inst mov (make-ea :byte :base object
1344                        :disp (- (+ (* vector-data-offset word-bytes) index)
1345                                 other-pointer-type))
1346           al-tn)
1347     (move result eax)))
1348
1349 ;;; signed-byte-16
1350
1351 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1352   (:translate data-vector-ref)
1353   (:policy :fast-safe)
1354   (:args (object :scs (descriptor-reg))
1355          (index :scs (unsigned-reg)))
1356   (:arg-types simple-array-signed-byte-16 positive-fixnum)
1357   (:results (value :scs (signed-reg)))
1358   (:result-types tagged-num)
1359   (:generator 5
1360     (inst movsx value
1361           (make-ea :word :base object :index index :scale 2
1362                    :disp (- (* vector-data-offset word-bytes)
1363                             other-pointer-type)))))
1364
1365 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1366   (:translate data-vector-ref)
1367   (:policy :fast-safe)
1368   (:args (object :scs (descriptor-reg)))
1369   (:info index)
1370   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1371   (:results (value :scs (signed-reg)))
1372   (:result-types tagged-num)
1373   (:generator 4
1374     (inst movsx value
1375           (make-ea :word :base object
1376                    :disp (- (+ (* vector-data-offset word-bytes)
1377                                (* 2 index))
1378                             other-pointer-type)))))
1379
1380 (define-vop (data-vector-set/simple-array-signed-byte-16)
1381   (:translate data-vector-set)
1382   (:policy :fast-safe)
1383   (:args (object :scs (descriptor-reg) :to (:eval 0))
1384          (index :scs (unsigned-reg) :to (:eval 0))
1385          (value :scs (signed-reg) :target eax))
1386   (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1387   (:temporary (:sc signed-reg :offset eax-offset :target result
1388                    :from (:argument 2) :to (:result 0))
1389               eax)
1390   (:results (result :scs (signed-reg)))
1391   (:result-types tagged-num)
1392   (:generator 5
1393     (move eax value)
1394     (inst mov (make-ea :word :base object :index index :scale 2
1395                        :disp (- (* vector-data-offset word-bytes)
1396                                 other-pointer-type))
1397           ax-tn)
1398     (move result eax)))
1399
1400 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1401   (:translate data-vector-set)
1402   (:policy :fast-safe)
1403   (:args (object :scs (descriptor-reg) :to (:eval 0))
1404          (value :scs (signed-reg) :target eax))
1405   (:info index)
1406   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1407   (:temporary (:sc signed-reg :offset eax-offset :target result
1408                    :from (:argument 1) :to (:result 0))
1409               eax)
1410   (:results (result :scs (signed-reg)))
1411   (:result-types tagged-num)
1412   (:generator 4
1413     (move eax value)
1414     (inst mov
1415           (make-ea :word :base object
1416                    :disp (- (+ (* vector-data-offset word-bytes)
1417                                (* 2 index))
1418                             other-pointer-type))
1419           ax-tn)
1420     (move result eax)))
1421 \f
1422 ;;; These VOPs are used for implementing float slots in structures (whose raw
1423 ;;; data is an unsigned-32 vector).
1424 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
1425   (:translate %raw-ref-single)
1426   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1427 (define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
1428   (:translate %raw-ref-single)
1429   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1430 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
1431   (:translate %raw-set-single)
1432   (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
1433 (define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
1434   (:translate %raw-set-single)
1435   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1436               single-float))
1437 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
1438   (:translate %raw-ref-double)
1439   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1440 (define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
1441   (:translate %raw-ref-double)
1442   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1443 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
1444   (:translate %raw-set-double)
1445   (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
1446 (define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
1447   (:translate %raw-set-double)
1448   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1449               double-float))
1450 #!+long-float
1451 (define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
1452   (:translate %raw-ref-long)
1453   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1454 #!+long-float
1455 (define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
1456   (:translate %raw-ref-long)
1457   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1458 #!+long-float
1459 (define-vop (raw-set-double data-vector-set/simple-array-long-float)
1460   (:translate %raw-set-long)
1461   (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float))
1462 #!+long-float
1463 (define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
1464   (:translate %raw-set-long)
1465   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1466               long-float))
1467
1468 ;;;; complex-float raw structure slot accessors
1469
1470 (define-vop (raw-ref-complex-single
1471              data-vector-ref/simple-array-complex-single-float)
1472   (:translate %raw-ref-complex-single)
1473   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1474 (define-vop (raw-ref-complex-single-c
1475              data-vector-ref-c/simple-array-complex-single-float)
1476   (:translate %raw-ref-complex-single)
1477   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1478 (define-vop (raw-set-complex-single
1479              data-vector-set/simple-array-complex-single-float)
1480   (:translate %raw-set-complex-single)
1481   (:arg-types simple-array-unsigned-byte-32 positive-fixnum complex-single-float))
1482 (define-vop (raw-set-complex-single-c
1483              data-vector-set-c/simple-array-complex-single-float)
1484   (:translate %raw-set-complex-single)
1485   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1486               complex-single-float))
1487 (define-vop (raw-ref-complex-double
1488              data-vector-ref/simple-array-complex-double-float)
1489   (:translate %raw-ref-complex-double)
1490   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1491 (define-vop (raw-ref-complex-double-c
1492              data-vector-ref-c/simple-array-complex-double-float)
1493   (:translate %raw-ref-complex-double)
1494   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1495 (define-vop (raw-set-complex-double
1496              data-vector-set/simple-array-complex-double-float)
1497   (:translate %raw-set-complex-double)
1498   (:arg-types simple-array-unsigned-byte-32 positive-fixnum
1499               complex-double-float))
1500 (define-vop (raw-set-complex-double-c
1501              data-vector-set-c/simple-array-complex-double-float)
1502   (:translate %raw-set-complex-double)
1503   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1504               complex-double-float))
1505 #!+long-float
1506 (define-vop (raw-ref-complex-long
1507              data-vector-ref/simple-array-complex-long-float)
1508   (:translate %raw-ref-complex-long)
1509   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
1510 #!+long-float
1511 (define-vop (raw-ref-complex-long-c
1512              data-vector-ref-c/simple-array-complex-long-float)
1513   (:translate %raw-ref-complex-long)
1514   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
1515 #!+long-float
1516 (define-vop (raw-set-complex-long
1517              data-vector-set/simple-array-complex-long-float)
1518   (:translate %raw-set-complex-long)
1519   (:arg-types simple-array-unsigned-byte-32 positive-fixnum
1520               complex-long-float))
1521 #!+long-float
1522 (define-vop (raw-set-complex-long-c
1523              data-vector-set-c/simple-array-complex-long-float)
1524   (:translate %raw-set-complex-long)
1525   (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
1526               complex-long-float))
1527
1528 ;;; These vops are useful for accessing the bits of a vector
1529 ;;; irrespective of what type of vector it is.
1530 (define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg)
1531   unsigned-num %raw-bits)
1532 (define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
1533   unsigned-num %set-raw-bits)
1534 \f
1535 ;;;; miscellaneous array VOPs
1536
1537 (define-vop (get-vector-subtype get-header-data))
1538 (define-vop (set-vector-subtype set-header-data))