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