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