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