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