src/compiler/x86/array.lisp

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