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 (define-full-reffer %array-dimension *
  44   array-dimensions-offset other-pointer-lowtag
  45   (any-reg) positive-fixnum sb!kernel:%array-dimension)
  46
  47 (define-full-setter %set-array-dimension *
  48   array-dimensions-offset other-pointer-lowtag
  49   (any-reg) positive-fixnum sb!kernel:%set-array-dimension)
  50
  51 (define-vop (array-rank-vop)
  52   (:translate sb!kernel:%array-rank)
  53   (:policy :fast-safe)
  54   (:args (x :scs (descriptor-reg)))
  55   (:results (res :scs (unsigned-reg)))
  56   (:result-types positive-fixnum)
  57   (:generator 6
  58     (loadw res x 0 other-pointer-lowtag)
  59     (inst shr res n-widetag-bits)
  60     (inst sub res (1- array-dimensions-offset))))
  61 \f
  62 ;;;; bounds checking routine
  63
  64 ;;; Note that the immediate SC for the index argument is disabled
  65 ;;; because it is not possible to generate a valid error code SC for
  66 ;;; an immediate value.
  67 ;;;
  68 ;;; FIXME: As per the KLUDGE note explaining the :IGNORE-FAILURE-P
  69 ;;; flag in build-order.lisp-expr, compiling this file causes warnings
  70 ;;;    Argument FOO to VOP CHECK-BOUND has SC restriction
  71 ;;;    DESCRIPTOR-REG which is not allowed by the operand type:
  72 ;;;      (:OR POSITIVE-FIXNUM)
  73 ;;; CSR's message "format ~/ /" on sbcl-devel 2002-03-12 contained
  74 ;;; a possible patch, described as
  75 ;;;   Another patch is included more for information than anything --
  76 ;;;   removing the descriptor-reg SCs from the CHECK-BOUND vop in
  77 ;;;   x86/array.lisp seems to allow that file to compile without error[*],
  78 ;;;   and build; I haven't tested rebuilding capability, but I'd be
  79 ;;;   surprised if there were a problem.  I'm not certain that this is the
  80 ;;;   correct fix, though, as the restrictions on the arguments to the VOP
  81 ;;;   aren't the same as in the sparc and alpha ports, where, incidentally,
  82 ;;;   the corresponding file builds without error currently.
  83 ;;; Since neither of us (CSR or WHN) was quite sure that this is the
  84 ;;; right thing, I've just recorded the patch here in hopes it might
  85 ;;; help when someone attacks this problem again:
  86 ;;;   diff -u -r1.7 array.lisp
  87 ;;;   --- src/compiler/x86/array.lisp 11 Oct 2001 14:05:26 -0000      1.7
  88 ;;;   +++ src/compiler/x86/array.lisp 12 Mar 2002 12:23:37 -0000
  89 ;;;   @@ -76,10 +76,10 @@
  90 ;;;      (:translate %check-bound)
  91 ;;;      (:policy :fast-safe)
  92 ;;;      (:args (array :scs (descriptor-reg))
  93 ;;;   -        (bound :scs (any-reg descriptor-reg))
  94 ;;;   -        (index :scs (any-reg descriptor-reg #+nil immediate) :target result))
  95 ;;;   +        (bound :scs (any-reg))
  96 ;;;   +        (index :scs (any-reg #+nil immediate) :target result))
  97 ;;;      (:arg-types * positive-fixnum tagged-num)
  98 ;;;   -  (:results (result :scs (any-reg descriptor-reg)))
  99 ;;;   +  (:results (result :scs (any-reg)))
 100 ;;;      (:result-types positive-fixnum)
 101 ;;;      (:vop-var vop)
 102 ;;;      (:save-p :compute-only)
 103 (define-vop (check-bound)
 104   (:translate %check-bound)
 105   (:policy :fast-safe)
 106   (:args (array :scs (descriptor-reg))
 107          (bound :scs (any-reg))
 108          (index :scs (any-reg #+nil immediate) :target result))
 109   (:arg-types * positive-fixnum tagged-num)
 110   (:results (result :scs (any-reg)))
 111   (:result-types positive-fixnum)
 112   (:vop-var vop)
 113   (:save-p :compute-only)
 114   (:generator 5
 115     (let ((error (generate-error-code vop invalid-array-index-error
 116                                       array bound index))
 117           (index (if (sc-is index immediate)
 118                    (fixnumize (tn-value index))
 119                    index)))
 120       (inst cmp bound index)
 121       ;; We use below-or-equal even though it's an unsigned test,
 122       ;; because negative indexes appear as large unsigned numbers.
 123       ;; Therefore, we get the <0 and >=bound test all rolled into one.
 124       (inst jmp :be error)
 125       (unless (and (tn-p index) (location= result index))
 126         (inst mov result index)))))
 127 \f
 128 ;;;; accessors/setters
 129
 130 ;;; variants built on top of WORD-INDEX-REF, etc. I.e., those vectors
 131 ;;; whose elements are represented in integer registers and are built
 132 ;;; out of 8, 16, or 32 bit elements.
 133 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
 134              `(progn
 135                 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
 136                   ,type vector-data-offset other-pointer-lowtag ,scs
 137                   ,element-type data-vector-ref)
 138                 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
 139                   ,type vector-data-offset other-pointer-lowtag ,scs
 140                   ,element-type data-vector-set))))
 141   (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
 142   (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
 143     unsigned-reg)
 144   (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
 145   (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg)
 146   (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
 147     signed-reg)
 148   (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
 149     unsigned-reg))
 150 \f
 151 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
 152 ;;;; bit, 2-bit, and 4-bit vectors
 153
 154 (macrolet ((def-small-data-vector-frobs (type bits)
 155              (let* ((elements-per-word (floor n-word-bits bits))
 156                     (bit-shift (1- (integer-length elements-per-word))))
 157     `(progn
 158        (define-vop (,(symbolicate 'data-vector-ref/ type))
 159          (:note "inline array access")
 160          (:translate data-vector-ref)
 161          (:policy :fast-safe)
 162          (:args (object :scs (descriptor-reg))
 163                 (index :scs (unsigned-reg)))
 164          (:arg-types ,type positive-fixnum)
 165          (:results (result :scs (unsigned-reg) :from (:argument 0)))
 166          (:result-types positive-fixnum)
 167          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
 168          (:generator 20
 169            (move ecx index)
 170            (inst shr ecx ,bit-shift)
 171            (inst mov result
 172                  (make-ea :dword :base object :index ecx :scale 4
 173                           :disp (- (* vector-data-offset n-word-bytes)
 174                                    other-pointer-lowtag)))
 175            (move ecx index)
 176            ;; We used to mask ECX for all values of ELEMENT-PER-WORD,
 177            ;; but since Intel's documentation says that the chip will
 178            ;; mask shift and rotate counts by 31 automatically, we can
 179            ;; safely move the masking operation under the protection of
 180            ;; this UNLESS in the bit-vector case.  --njf, 2006-07-14
 181            ,@(unless (= elements-per-word n-word-bits)
 182                `((inst and ecx ,(1- elements-per-word))
 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))
 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) old)
 214          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
 215          (:generator 25
 216            (move word-index index)
 217            (inst shr word-index ,bit-shift)
 218            (inst mov old
 219                  (make-ea :dword :base object :index word-index :scale 4
 220                           :disp (- (* vector-data-offset n-word-bytes)
 221                                    other-pointer-lowtag)))
 222            (move ecx index)
 223            ;; We used to mask ECX for all values of ELEMENT-PER-WORD,
 224            ;; but since Intel's documentation says that the chip will
 225            ;; mask shift and rotate counts by 31 automatically, we can
 226            ;; safely move the masking operation under the protection of
 227            ;; this UNLESS in the bit-vector case.  --njf, 2006-07-14
 228            ,@(unless (= elements-per-word n-word-bits)
 229                `((inst and ecx ,(1- elements-per-word))
 230                  (inst shl ecx ,(1- (integer-length bits)))))
 231            (inst ror old :cl)
 232            (unless (and (sc-is value immediate)
 233                         (= (tn-value value) ,(1- (ash 1 bits))))
 234              (inst and old ,(lognot (1- (ash 1 bits)))))
 235            (sc-case value
 236              (immediate
 237               (unless (zerop (tn-value value))
 238                 (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
 239              (unsigned-reg
 240               (inst or old value)))
 241            (inst rol old :cl)
 242            (inst mov (make-ea :dword :base object :index word-index :scale 4
 243                               :disp (- (* vector-data-offset n-word-bytes)
 244                                        other-pointer-lowtag))
 245                  old)
 246            (sc-case value
 247              (immediate
 248               (inst mov result (tn-value value)))
 249              (unsigned-reg
 250               (move result value)))))
 251        (define-vop (,(symbolicate 'data-vector-set-c/ type))
 252          (:translate data-vector-set)
 253          (:policy :fast-safe)
 254          (:args (object :scs (descriptor-reg))
 255                 (value :scs (unsigned-reg immediate) :target result))
 256          (:arg-types ,type (:constant index) positive-fixnum)
 257          (:info index)
 258          (:results (result :scs (unsigned-reg)))
 259          (:result-types positive-fixnum)
 260          (:temporary (:sc unsigned-reg :to (:result 0)) old)
 261          (:generator 20
 262            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 263              (inst mov old
 264                    (make-ea :dword :base object
 265                             :disp (- (* (+ word vector-data-offset)
 266                                         n-word-bytes)
 267                                      other-pointer-lowtag)))
 268              (sc-case value
 269                (immediate
 270                 (let* ((value (tn-value value))
 271                        (mask ,(1- (ash 1 bits)))
 272                        (shift (* extra ,bits)))
 273                   (unless (= value mask)
 274                     (inst and old (ldb (byte n-word-bits 0)
 275                                        (lognot (ash mask shift)))))
 276                   (unless (zerop value)
 277                     (inst or old (ash value shift)))))
 278                (unsigned-reg
 279                 (let ((shift (* extra ,bits)))
 280                   (unless (zerop shift)
 281                     (inst ror old shift))
 282                   (inst and old (lognot ,(1- (ash 1 bits))))
 283                   (inst or old value)
 284                   (unless (zerop shift)
 285                     (inst rol old shift)))))
 286              (inst mov (make-ea :dword :base object
 287                                 :disp (- (* (+ word vector-data-offset)
 288                                             n-word-bytes)
 289                                          other-pointer-lowtag))
 290                    old)
 291              (sc-case value
 292                (immediate
 293                 (inst mov result (tn-value value)))
 294                (unsigned-reg
 295                 (move result value))))))))))
 296   (def-small-data-vector-frobs simple-bit-vector 1)
 297   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 298   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 299
 300 ;;; And the float variants.
 301
 302 (define-vop (data-vector-ref/simple-array-single-float)
 303   (:note "inline array access")
 304   (:translate data-vector-ref)
 305   (:policy :fast-safe)
 306   (:args (object :scs (descriptor-reg))
 307          (index :scs (any-reg)))
 308   (:arg-types simple-array-single-float positive-fixnum)
 309   (:results (value :scs (single-reg)))
 310   (:result-types single-float)
 311   (:generator 5
 312    (with-empty-tn@fp-top(value)
 313      (inst fld (make-ea :dword :base object :index index :scale 1
 314                         :disp (- (* vector-data-offset
 315                                     n-word-bytes)
 316                                  other-pointer-lowtag))))))
 317
 318 (define-vop (data-vector-ref-c/simple-array-single-float)
 319   (:note "inline array access")
 320   (:translate data-vector-ref)
 321   (:policy :fast-safe)
 322   (:args (object :scs (descriptor-reg)))
 323   (:info index)
 324   (:arg-types simple-array-single-float (:constant (signed-byte 30)))
 325   (:results (value :scs (single-reg)))
 326   (:result-types single-float)
 327   (:generator 4
 328    (with-empty-tn@fp-top(value)
 329      (inst fld (make-ea :dword :base object
 330                         :disp (- (+ (* vector-data-offset
 331                                        n-word-bytes)
 332                                     (* 4 index))
 333                                  other-pointer-lowtag))))))
 334
 335 (define-vop (data-vector-set/simple-array-single-float)
 336   (:note "inline array store")
 337   (:translate data-vector-set)
 338   (:policy :fast-safe)
 339   (:args (object :scs (descriptor-reg))
 340          (index :scs (any-reg))
 341          (value :scs (single-reg) :target result))
 342   (:arg-types simple-array-single-float positive-fixnum single-float)
 343   (:results (result :scs (single-reg)))
 344   (:result-types single-float)
 345   (:generator 5
 346     (cond ((zerop (tn-offset value))
 347            ;; Value is in ST0.
 348            (inst fst (make-ea :dword :base object :index index :scale 1
 349                               :disp (- (* vector-data-offset
 350                                           n-word-bytes)
 351                                        other-pointer-lowtag)))
 352            (unless (zerop (tn-offset result))
 353                    ;; Value is in ST0 but not result.
 354                    (inst fst result)))
 355           (t
 356            ;; Value is not in ST0.
 357            (inst fxch value)
 358            (inst fst (make-ea :dword :base object :index index :scale 1
 359                               :disp (- (* vector-data-offset
 360                                           n-word-bytes)
 361                                        other-pointer-lowtag)))
 362            (cond ((zerop (tn-offset result))
 363                   ;; The result is in ST0.
 364                   (inst fst value))
 365                  (t
 366                   ;; Neither value or result are in ST0
 367                   (unless (location= value result)
 368                           (inst fst result))
 369                   (inst fxch value)))))))
 370
 371 (define-vop (data-vector-set-c/simple-array-single-float)
 372   (:note "inline array store")
 373   (:translate data-vector-set)
 374   (:policy :fast-safe)
 375   (:args (object :scs (descriptor-reg))
 376          (value :scs (single-reg) :target result))
 377   (:info index)
 378   (:arg-types simple-array-single-float (:constant (signed-byte 30))
 379               single-float)
 380   (:results (result :scs (single-reg)))
 381   (:result-types single-float)
 382   (:generator 4
 383     (cond ((zerop (tn-offset value))
 384            ;; Value is in ST0.
 385            (inst fst (make-ea :dword :base object
 386                               :disp (- (+ (* vector-data-offset
 387                                              n-word-bytes)
 388                                           (* 4 index))
 389                                        other-pointer-lowtag)))
 390            (unless (zerop (tn-offset result))
 391                    ;; Value is in ST0 but not result.
 392                    (inst fst result)))
 393           (t
 394            ;; Value is not in ST0.
 395            (inst fxch value)
 396            (inst fst (make-ea :dword :base object
 397                               :disp (- (+ (* vector-data-offset
 398                                              n-word-bytes)
 399                                           (* 4 index))
 400                                        other-pointer-lowtag)))
 401            (cond ((zerop (tn-offset result))
 402                   ;; The result is in ST0.
 403                   (inst fst value))
 404                  (t
 405                   ;; Neither value or result are in ST0
 406                   (unless (location= value result)
 407                           (inst fst result))
 408                   (inst fxch value)))))))
 409
 410 (define-vop (data-vector-ref/simple-array-double-float)
 411   (:note "inline array access")
 412   (:translate data-vector-ref)
 413   (:policy :fast-safe)
 414   (:args (object :scs (descriptor-reg))
 415          (index :scs (any-reg)))
 416   (:arg-types simple-array-double-float positive-fixnum)
 417   (:results (value :scs (double-reg)))
 418   (:result-types double-float)
 419   (:generator 7
 420    (with-empty-tn@fp-top(value)
 421      (inst fldd (make-ea :dword :base object :index index :scale 2
 422                          :disp (- (* vector-data-offset
 423                                      n-word-bytes)
 424                                   other-pointer-lowtag))))))
 425
 426 (define-vop (data-vector-ref-c/simple-array-double-float)
 427   (:note "inline array access")
 428   (:translate data-vector-ref)
 429   (:policy :fast-safe)
 430   (:args (object :scs (descriptor-reg)))
 431   (:info index)
 432   (:arg-types simple-array-double-float (:constant (signed-byte 30)))
 433   (:results (value :scs (double-reg)))
 434   (:result-types double-float)
 435   (:generator 6
 436    (with-empty-tn@fp-top(value)
 437      (inst fldd (make-ea :dword :base object
 438                          :disp (- (+ (* vector-data-offset
 439                                         n-word-bytes)
 440                                      (* 8 index))
 441                                   other-pointer-lowtag))))))
 442
 443 (define-vop (data-vector-set/simple-array-double-float)
 444   (:note "inline array store")
 445   (:translate data-vector-set)
 446   (:policy :fast-safe)
 447   (:args (object :scs (descriptor-reg))
 448          (index :scs (any-reg))
 449          (value :scs (double-reg) :target result))
 450   (:arg-types simple-array-double-float positive-fixnum double-float)
 451   (:results (result :scs (double-reg)))
 452   (:result-types double-float)
 453   (:generator 20
 454     (cond ((zerop (tn-offset value))
 455            ;; Value is in ST0.
 456            (inst fstd (make-ea :dword :base object :index index :scale 2
 457                                :disp (- (* vector-data-offset
 458                                            n-word-bytes)
 459                                         other-pointer-lowtag)))
 460            (unless (zerop (tn-offset result))
 461                    ;; Value is in ST0 but not result.
 462                    (inst fstd result)))
 463           (t
 464            ;; Value is not in ST0.
 465            (inst fxch value)
 466            (inst fstd (make-ea :dword :base object :index index :scale 2
 467                                :disp (- (* vector-data-offset
 468                                            n-word-bytes)
 469                                         other-pointer-lowtag)))
 470            (cond ((zerop (tn-offset result))
 471                   ;; The result is in ST0.
 472                   (inst fstd value))
 473                  (t
 474                   ;; Neither value or result are in ST0
 475                   (unless (location= value result)
 476                           (inst fstd result))
 477                   (inst fxch value)))))))
 478
 479 (define-vop (data-vector-set-c/simple-array-double-float)
 480   (:note "inline array store")
 481   (:translate data-vector-set)
 482   (:policy :fast-safe)
 483   (:args (object :scs (descriptor-reg))
 484          (value :scs (double-reg) :target result))
 485   (:info index)
 486   (:arg-types simple-array-double-float (:constant (signed-byte 30))
 487               double-float)
 488   (:results (result :scs (double-reg)))
 489   (:result-types double-float)
 490   (:generator 19
 491     (cond ((zerop (tn-offset value))
 492            ;; Value is in ST0.
 493            (inst fstd (make-ea :dword :base object
 494                                :disp (- (+ (* vector-data-offset
 495                                               n-word-bytes)
 496                                            (* 8 index))
 497                                         other-pointer-lowtag)))
 498            (unless (zerop (tn-offset result))
 499                    ;; Value is in ST0 but not result.
 500                    (inst fstd result)))
 501           (t
 502            ;; Value is not in ST0.
 503            (inst fxch value)
 504            (inst fstd (make-ea :dword :base object
 505                                :disp (- (+ (* vector-data-offset
 506                                               n-word-bytes)
 507                                            (* 8 index))
 508                                         other-pointer-lowtag)))
 509            (cond ((zerop (tn-offset result))
 510                   ;; The result is in ST0.
 511                   (inst fstd value))
 512                  (t
 513                   ;; Neither value or result are in ST0
 514                   (unless (location= value result)
 515                           (inst fstd result))
 516                   (inst fxch value)))))))
 517
 518
 519
 520 ;;; complex float variants
 521
 522 (define-vop (data-vector-ref/simple-array-complex-single-float)
 523   (:note "inline array access")
 524   (:translate data-vector-ref)
 525   (:policy :fast-safe)
 526   (:args (object :scs (descriptor-reg))
 527          (index :scs (any-reg)))
 528   (:arg-types simple-array-complex-single-float positive-fixnum)
 529   (:results (value :scs (complex-single-reg)))
 530   (:result-types complex-single-float)
 531   (:generator 5
 532     (let ((real-tn (complex-single-reg-real-tn value)))
 533       (with-empty-tn@fp-top (real-tn)
 534         (inst fld (make-ea :dword :base object :index index :scale 2
 535                            :disp (- (* vector-data-offset
 536                                        n-word-bytes)
 537                                     other-pointer-lowtag)))))
 538     (let ((imag-tn (complex-single-reg-imag-tn value)))
 539       (with-empty-tn@fp-top (imag-tn)
 540         (inst fld (make-ea :dword :base object :index index :scale 2
 541                            :disp (- (* (1+ vector-data-offset)
 542                                        n-word-bytes)
 543                                     other-pointer-lowtag)))))))
 544
 545 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
 546   (:note "inline array access")
 547   (:translate data-vector-ref)
 548   (:policy :fast-safe)
 549   (:args (object :scs (descriptor-reg)))
 550   (:info index)
 551   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
 552   (:results (value :scs (complex-single-reg)))
 553   (:result-types complex-single-float)
 554   (:generator 4
 555     (let ((real-tn (complex-single-reg-real-tn value)))
 556       (with-empty-tn@fp-top (real-tn)
 557         (inst fld (make-ea :dword :base object
 558                            :disp (- (+ (* vector-data-offset
 559                                           n-word-bytes)
 560                                        (* 8 index))
 561                                     other-pointer-lowtag)))))
 562     (let ((imag-tn (complex-single-reg-imag-tn value)))
 563       (with-empty-tn@fp-top (imag-tn)
 564         (inst fld (make-ea :dword :base object
 565                            :disp (- (+ (* vector-data-offset
 566                                           n-word-bytes)
 567                                        (* 8 index) 4)
 568                                     other-pointer-lowtag)))))))
 569
 570 (define-vop (data-vector-set/simple-array-complex-single-float)
 571   (:note "inline array store")
 572   (:translate data-vector-set)
 573   (:policy :fast-safe)
 574   (:args (object :scs (descriptor-reg))
 575          (index :scs (any-reg))
 576          (value :scs (complex-single-reg) :target result))
 577   (:arg-types simple-array-complex-single-float positive-fixnum
 578               complex-single-float)
 579   (:results (result :scs (complex-single-reg)))
 580   (:result-types complex-single-float)
 581   (:generator 5
 582     (let ((value-real (complex-single-reg-real-tn value))
 583           (result-real (complex-single-reg-real-tn result)))
 584       (cond ((zerop (tn-offset value-real))
 585              ;; Value is in ST0.
 586              (inst fst (make-ea :dword :base object :index index :scale 2
 587                                 :disp (- (* vector-data-offset
 588                                             n-word-bytes)
 589                                          other-pointer-lowtag)))
 590              (unless (zerop (tn-offset result-real))
 591                ;; Value is in ST0 but not result.
 592                (inst fst result-real)))
 593             (t
 594              ;; Value is not in ST0.
 595              (inst fxch value-real)
 596              (inst fst (make-ea :dword :base object :index index :scale 2
 597                                 :disp (- (* vector-data-offset
 598                                             n-word-bytes)
 599                                          other-pointer-lowtag)))
 600              (cond ((zerop (tn-offset result-real))
 601                     ;; The result is in ST0.
 602                     (inst fst value-real))
 603                    (t
 604                     ;; Neither value or result are in ST0
 605                     (unless (location= value-real result-real)
 606                       (inst fst result-real))
 607                     (inst fxch value-real))))))
 608     (let ((value-imag (complex-single-reg-imag-tn value))
 609           (result-imag (complex-single-reg-imag-tn result)))
 610       (inst fxch value-imag)
 611       (inst fst (make-ea :dword :base object :index index :scale 2
 612                          :disp (- (+ (* vector-data-offset
 613                                         n-word-bytes)
 614                                      4)
 615                                   other-pointer-lowtag)))
 616       (unless (location= value-imag result-imag)
 617         (inst fst result-imag))
 618       (inst fxch value-imag))))
 619
 620 (define-vop (data-vector-set-c/simple-array-complex-single-float)
 621   (:note "inline array store")
 622   (:translate data-vector-set)
 623   (:policy :fast-safe)
 624   (:args (object :scs (descriptor-reg))
 625          (value :scs (complex-single-reg) :target result))
 626   (:info index)
 627   (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
 628               complex-single-float)
 629   (:results (result :scs (complex-single-reg)))
 630   (:result-types complex-single-float)
 631   (:generator 4
 632     (let ((value-real (complex-single-reg-real-tn value))
 633           (result-real (complex-single-reg-real-tn result)))
 634       (cond ((zerop (tn-offset value-real))
 635              ;; Value is in ST0.
 636              (inst fst (make-ea :dword :base object
 637                                 :disp (- (+ (* vector-data-offset
 638                                                n-word-bytes)
 639                                             (* 8 index))
 640                                          other-pointer-lowtag)))
 641              (unless (zerop (tn-offset result-real))
 642                ;; Value is in ST0 but not result.
 643                (inst fst result-real)))
 644             (t
 645              ;; Value is not in ST0.
 646              (inst fxch value-real)
 647              (inst fst (make-ea :dword :base object
 648                                 :disp (- (+ (* vector-data-offset
 649                                                n-word-bytes)
 650                                             (* 8 index))
 651                                          other-pointer-lowtag)))
 652              (cond ((zerop (tn-offset result-real))
 653                     ;; The result is in ST0.
 654                     (inst fst value-real))
 655                    (t
 656                     ;; Neither value or result are in ST0
 657                     (unless (location= value-real result-real)
 658                       (inst fst result-real))
 659                     (inst fxch value-real))))))
 660     (let ((value-imag (complex-single-reg-imag-tn value))
 661           (result-imag (complex-single-reg-imag-tn result)))
 662       (inst fxch value-imag)
 663       (inst fst (make-ea :dword :base object
 664                          :disp (- (+ (* vector-data-offset
 665                                         n-word-bytes)
 666                                      (* 8 index) 4)
 667                                   other-pointer-lowtag)))
 668       (unless (location= value-imag result-imag)
 669         (inst fst result-imag))
 670       (inst fxch value-imag))))
 671
 672
 673 (define-vop (data-vector-ref/simple-array-complex-double-float)
 674   (:note "inline array access")
 675   (:translate data-vector-ref)
 676   (:policy :fast-safe)
 677   (:args (object :scs (descriptor-reg))
 678          (index :scs (any-reg)))
 679   (:arg-types simple-array-complex-double-float positive-fixnum)
 680   (:results (value :scs (complex-double-reg)))
 681   (:result-types complex-double-float)
 682   (:generator 7
 683     (let ((real-tn (complex-double-reg-real-tn value)))
 684       (with-empty-tn@fp-top (real-tn)
 685         (inst fldd (make-ea :dword :base object :index index :scale 4
 686                             :disp (- (* vector-data-offset
 687                                         n-word-bytes)
 688                                      other-pointer-lowtag)))))
 689     (let ((imag-tn (complex-double-reg-imag-tn value)))
 690       (with-empty-tn@fp-top (imag-tn)
 691         (inst fldd (make-ea :dword :base object :index index :scale 4
 692                             :disp (- (+ (* vector-data-offset
 693                                            n-word-bytes)
 694                                         8)
 695                                      other-pointer-lowtag)))))))
 696
 697 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
 698   (:note "inline array access")
 699   (:translate data-vector-ref)
 700   (:policy :fast-safe)
 701   (:args (object :scs (descriptor-reg)))
 702   (:info index)
 703   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
 704   (:results (value :scs (complex-double-reg)))
 705   (:result-types complex-double-float)
 706   (:generator 6
 707     (let ((real-tn (complex-double-reg-real-tn value)))
 708       (with-empty-tn@fp-top (real-tn)
 709         (inst fldd (make-ea :dword :base object
 710                             :disp (- (+ (* vector-data-offset
 711                                            n-word-bytes)
 712                                         (* 16 index))
 713                                      other-pointer-lowtag)))))
 714     (let ((imag-tn (complex-double-reg-imag-tn value)))
 715       (with-empty-tn@fp-top (imag-tn)
 716         (inst fldd (make-ea :dword :base object
 717                             :disp (- (+ (* vector-data-offset
 718                                            n-word-bytes)
 719                                         (* 16 index) 8)
 720                                      other-pointer-lowtag)))))))
 721
 722 (define-vop (data-vector-set/simple-array-complex-double-float)
 723   (:note "inline array store")
 724   (:translate data-vector-set)
 725   (:policy :fast-safe)
 726   (:args (object :scs (descriptor-reg))
 727          (index :scs (any-reg))
 728          (value :scs (complex-double-reg) :target result))
 729   (:arg-types simple-array-complex-double-float positive-fixnum
 730               complex-double-float)
 731   (:results (result :scs (complex-double-reg)))
 732   (:result-types complex-double-float)
 733   (:generator 20
 734     (let ((value-real (complex-double-reg-real-tn value))
 735           (result-real (complex-double-reg-real-tn result)))
 736       (cond ((zerop (tn-offset value-real))
 737              ;; Value is in ST0.
 738              (inst fstd (make-ea :dword :base object :index index :scale 4
 739                                  :disp (- (* vector-data-offset
 740                                              n-word-bytes)
 741                                           other-pointer-lowtag)))
 742              (unless (zerop (tn-offset result-real))
 743                ;; Value is in ST0 but not result.
 744                (inst fstd result-real)))
 745             (t
 746              ;; Value is not in ST0.
 747              (inst fxch value-real)
 748              (inst fstd (make-ea :dword :base object :index index :scale 4
 749                                  :disp (- (* vector-data-offset
 750                                              n-word-bytes)
 751                                           other-pointer-lowtag)))
 752              (cond ((zerop (tn-offset result-real))
 753                     ;; The result is in ST0.
 754                     (inst fstd value-real))
 755                    (t
 756                     ;; Neither value or result are in ST0
 757                     (unless (location= value-real result-real)
 758                       (inst fstd result-real))
 759                     (inst fxch value-real))))))
 760     (let ((value-imag (complex-double-reg-imag-tn value))
 761           (result-imag (complex-double-reg-imag-tn result)))
 762       (inst fxch value-imag)
 763       (inst fstd (make-ea :dword :base object :index index :scale 4
 764                           :disp (- (+ (* vector-data-offset
 765                                          n-word-bytes)
 766                                       8)
 767                                    other-pointer-lowtag)))
 768       (unless (location= value-imag result-imag)
 769         (inst fstd result-imag))
 770       (inst fxch value-imag))))
 771
 772 (define-vop (data-vector-set-c/simple-array-complex-double-float)
 773   (:note "inline array store")
 774   (:translate data-vector-set)
 775   (:policy :fast-safe)
 776   (:args (object :scs (descriptor-reg))
 777          (value :scs (complex-double-reg) :target result))
 778   (:info index)
 779   (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
 780               complex-double-float)
 781   (:results (result :scs (complex-double-reg)))
 782   (:result-types complex-double-float)
 783   (:generator 19
 784     (let ((value-real (complex-double-reg-real-tn value))
 785           (result-real (complex-double-reg-real-tn result)))
 786       (cond ((zerop (tn-offset value-real))
 787              ;; Value is in ST0.
 788              (inst fstd (make-ea :dword :base object
 789                                  :disp (- (+ (* vector-data-offset
 790                                                 n-word-bytes)
 791                                              (* 16 index))
 792                                           other-pointer-lowtag)))
 793              (unless (zerop (tn-offset result-real))
 794                ;; Value is in ST0 but not result.
 795                (inst fstd result-real)))
 796             (t
 797              ;; Value is not in ST0.
 798              (inst fxch value-real)
 799              (inst fstd (make-ea :dword :base object
 800                                  :disp (- (+ (* vector-data-offset
 801                                                 n-word-bytes)
 802                                              (* 16 index))
 803                                           other-pointer-lowtag)))
 804              (cond ((zerop (tn-offset result-real))
 805                     ;; The result is in ST0.
 806                     (inst fstd value-real))
 807                    (t
 808                     ;; Neither value or result are in ST0
 809                     (unless (location= value-real result-real)
 810                       (inst fstd result-real))
 811                     (inst fxch value-real))))))
 812     (let ((value-imag (complex-double-reg-imag-tn value))
 813           (result-imag (complex-double-reg-imag-tn result)))
 814       (inst fxch value-imag)
 815       (inst fstd (make-ea :dword :base object
 816                           :disp (- (+ (* vector-data-offset
 817                                          n-word-bytes)
 818                                       (* 16 index) 8)
 819                                    other-pointer-lowtag)))
 820       (unless (location= value-imag result-imag)
 821         (inst fstd result-imag))
 822       (inst fxch value-imag))))
 823
 824
 825
 826 \f
 827 ;;; unsigned-byte-8
 828 (macrolet ((define-data-vector-frobs (ptype)
 829   `(progn
 830     (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
 831       (:translate data-vector-ref)
 832       (:policy :fast-safe)
 833       (:args (object :scs (descriptor-reg))
 834              (index :scs (unsigned-reg)))
 835       (:arg-types ,ptype positive-fixnum)
 836       (:results (value :scs (unsigned-reg signed-reg)))
 837       (:result-types positive-fixnum)
 838       (:generator 5
 839         (inst movzx value
 840               (make-ea :byte :base object :index index :scale 1
 841                        :disp (- (* vector-data-offset n-word-bytes)
 842                                 other-pointer-lowtag)))))
 843     (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
 844       (:translate data-vector-ref)
 845       (:policy :fast-safe)
 846       (:args (object :scs (descriptor-reg)))
 847       (:info index)
 848       (:arg-types ,ptype (:constant (signed-byte 30)))
 849       (:results (value :scs (unsigned-reg signed-reg)))
 850       (:result-types positive-fixnum)
 851       (:generator 4
 852         (inst movzx value
 853               (make-ea :byte :base object
 854                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
 855                                 other-pointer-lowtag)))))
 856     (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
 857       (:translate data-vector-set)
 858       (:policy :fast-safe)
 859       (:args (object :scs (descriptor-reg) :to (:eval 0))
 860              (index :scs (unsigned-reg) :to (:eval 0))
 861              (value :scs (unsigned-reg signed-reg) :target eax))
 862       (:arg-types ,ptype positive-fixnum positive-fixnum)
 863       (:temporary (:sc unsigned-reg :offset eax-offset :target result
 864                        :from (:argument 2) :to (:result 0))
 865                   eax)
 866       (:results (result :scs (unsigned-reg signed-reg)))
 867       (:result-types positive-fixnum)
 868       (:generator 5
 869         (move eax value)
 870         (inst mov (make-ea :byte :base object :index index :scale 1
 871                            :disp (- (* vector-data-offset n-word-bytes)
 872                                     other-pointer-lowtag))
 873               al-tn)
 874         (move result eax)))
 875     (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
 876       (:translate data-vector-set)
 877       (:policy :fast-safe)
 878       (:args (object :scs (descriptor-reg) :to (:eval 0))
 879              (value :scs (unsigned-reg signed-reg) :target eax))
 880       (:info index)
 881       (:arg-types ,ptype (:constant (signed-byte 30))
 882                   positive-fixnum)
 883       (:temporary (:sc unsigned-reg :offset eax-offset :target result
 884                        :from (:argument 1) :to (:result 0))
 885                   eax)
 886       (:results (result :scs (unsigned-reg signed-reg)))
 887       (:result-types positive-fixnum)
 888       (:generator 4
 889         (move eax value)
 890         (inst mov (make-ea :byte :base object
 891                            :disp (- (+ (* vector-data-offset n-word-bytes) index)
 892                                     other-pointer-lowtag))
 893               al-tn)
 894         (move result eax))))))
 895   (define-data-vector-frobs simple-array-unsigned-byte-7)
 896   (define-data-vector-frobs simple-array-unsigned-byte-8))
 897
 898 ;;; unsigned-byte-16
 899 (macrolet ((define-data-vector-frobs (ptype)
 900     `(progn
 901       (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
 902         (:translate data-vector-ref)
 903         (:policy :fast-safe)
 904         (:args (object :scs (descriptor-reg))
 905                (index :scs (unsigned-reg)))
 906         (:arg-types ,ptype positive-fixnum)
 907         (:results (value :scs (unsigned-reg signed-reg)))
 908         (:result-types positive-fixnum)
 909         (:generator 5
 910           (inst movzx value
 911                 (make-ea :word :base object :index index :scale 2
 912                          :disp (- (* vector-data-offset n-word-bytes)
 913                                   other-pointer-lowtag)))))
 914       (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
 915         (:translate data-vector-ref)
 916         (:policy :fast-safe)
 917         (:args (object :scs (descriptor-reg)))
 918         (:info index)
 919         (:arg-types ,ptype (:constant (signed-byte 30)))
 920         (:results (value :scs (unsigned-reg signed-reg)))
 921         (:result-types positive-fixnum)
 922         (:generator 4
 923           (inst movzx value
 924                 (make-ea :word :base object
 925                          :disp (- (+ (* vector-data-offset n-word-bytes) (* 2 index))
 926                                   other-pointer-lowtag)))))
 927       (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
 928         (:translate data-vector-set)
 929         (:policy :fast-safe)
 930         (:args (object :scs (descriptor-reg) :to (:eval 0))
 931                (index :scs (unsigned-reg) :to (:eval 0))
 932                (value :scs (unsigned-reg signed-reg) :target eax))
 933         (:arg-types ,ptype positive-fixnum positive-fixnum)
 934         (:temporary (:sc unsigned-reg :offset eax-offset :target result
 935                          :from (:argument 2) :to (:result 0))
 936                     eax)
 937         (:results (result :scs (unsigned-reg signed-reg)))
 938         (:result-types positive-fixnum)
 939         (:generator 5
 940           (move eax value)
 941           (inst mov (make-ea :word :base object :index index :scale 2
 942                              :disp (- (* vector-data-offset n-word-bytes)
 943                                       other-pointer-lowtag))
 944                 ax-tn)
 945           (move result eax)))
 946
 947       (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
 948         (:translate data-vector-set)
 949         (:policy :fast-safe)
 950         (:args (object :scs (descriptor-reg) :to (:eval 0))
 951                (value :scs (unsigned-reg signed-reg) :target eax))
 952         (:info index)
 953         (:arg-types ,ptype (:constant (signed-byte 30))
 954                     positive-fixnum)
 955         (:temporary (:sc unsigned-reg :offset eax-offset :target result
 956                          :from (:argument 1) :to (:result 0))
 957                     eax)
 958         (:results (result :scs (unsigned-reg signed-reg)))
 959         (:result-types positive-fixnum)
 960         (:generator 4
 961           (move eax value)
 962           (inst mov (make-ea :word :base object
 963                              :disp (- (+ (* vector-data-offset n-word-bytes)
 964                                          (* 2 index))
 965                                       other-pointer-lowtag))
 966                 ax-tn)
 967           (move result eax))))))
 968   (define-data-vector-frobs simple-array-unsigned-byte-15)
 969   (define-data-vector-frobs simple-array-unsigned-byte-16))
 970
 971 ;;; simple-string
 972
 973 #!+sb-unicode
 974 (progn
 975 (define-vop (data-vector-ref/simple-base-string)
 976   (:translate data-vector-ref)
 977   (:policy :fast-safe)
 978   (:args (object :scs (descriptor-reg))
 979          (index :scs (unsigned-reg)))
 980   (:arg-types simple-base-string positive-fixnum)
 981   (:results (value :scs (character-reg)))
 982   (:result-types character)
 983   (:generator 5
 984     (inst movzx value
 985           (make-ea :byte :base object :index index :scale 1
 986                    :disp (- (* vector-data-offset n-word-bytes)
 987                             other-pointer-lowtag)))))
 988
 989 (define-vop (data-vector-ref-c/simple-base-string)
 990   (:translate data-vector-ref)
 991   (:policy :fast-safe)
 992   (:args (object :scs (descriptor-reg)))
 993   (:info index)
 994   (:arg-types simple-base-string (:constant (signed-byte 30)))
 995   (:results (value :scs (character-reg)))
 996   (:result-types character)
 997   (:generator 4
 998     (inst movzx value
 999           (make-ea :byte :base object
1000                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1001                             other-pointer-lowtag)))))
1002
1003 (define-vop (data-vector-set/simple-base-string)
1004   (:translate data-vector-set)
1005   (:policy :fast-safe)
1006   (:args (object :scs (descriptor-reg) :to (:eval 0))
1007          (index :scs (unsigned-reg) :to (:eval 0))
1008          (value :scs (character-reg) :target eax))
1009   (:arg-types simple-base-string positive-fixnum character)
1010   (:temporary (:sc character-reg :offset eax-offset :target result
1011                    :from (:argument 2) :to (:result 0))
1012               eax)
1013   (:results (result :scs (character-reg)))
1014   (:result-types character)
1015   (:generator 5
1016     (move eax value)
1017     (inst mov (make-ea :byte :base object :index index :scale 1
1018                        :disp (- (* vector-data-offset n-word-bytes)
1019                                 other-pointer-lowtag))
1020           al-tn)
1021     (move result eax)))
1022
1023 (define-vop (data-vector-set-c/simple-base-string)
1024   (:translate data-vector-set)
1025   (:policy :fast-safe)
1026   (:args (object :scs (descriptor-reg) :to (:eval 0))
1027          (value :scs (character-reg)))
1028   (:info index)
1029   (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1030   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1031                    :from (:argument 1) :to (:result 0))
1032               eax)
1033   (:results (result :scs (character-reg)))
1034   (:result-types character)
1035   (:generator 4
1036     (move eax value)
1037     (inst mov (make-ea :byte :base object
1038                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
1039                                 other-pointer-lowtag))
1040           al-tn)
1041     (move result eax)))
1042 ) ; PROGN
1043
1044 #!-sb-unicode
1045 (progn
1046 (define-vop (data-vector-ref/simple-base-string)
1047   (:translate data-vector-ref)
1048   (:policy :fast-safe)
1049   (:args (object :scs (descriptor-reg))
1050          (index :scs (unsigned-reg)))
1051   (:arg-types simple-base-string positive-fixnum)
1052   (:results (value :scs (character-reg)))
1053   (:result-types character)
1054   (:generator 5
1055     (inst mov value
1056           (make-ea :byte :base object :index index :scale 1
1057                    :disp (- (* vector-data-offset n-word-bytes)
1058                             other-pointer-lowtag)))))
1059
1060 (define-vop (data-vector-ref-c/simple-base-string)
1061   (:translate data-vector-ref)
1062   (:policy :fast-safe)
1063   (:args (object :scs (descriptor-reg)))
1064   (:info index)
1065   (:arg-types simple-base-string (:constant (signed-byte 30)))
1066   (:results (value :scs (character-reg)))
1067   (:result-types character)
1068   (:generator 4
1069     (inst mov value
1070           (make-ea :byte :base object
1071                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1072                             other-pointer-lowtag)))))
1073
1074 (define-vop (data-vector-set/simple-base-string)
1075   (:translate data-vector-set)
1076   (:policy :fast-safe)
1077   (:args (object :scs (descriptor-reg) :to (:eval 0))
1078          (index :scs (unsigned-reg) :to (:eval 0))
1079          (value :scs (character-reg) :target result))
1080   (:arg-types simple-base-string positive-fixnum character)
1081   (:results (result :scs (character-reg)))
1082   (:result-types character)
1083   (:generator 5
1084     (inst mov (make-ea :byte :base object :index index :scale 1
1085                        :disp (- (* vector-data-offset n-word-bytes)
1086                                 other-pointer-lowtag))
1087           value)
1088     (move result value)))
1089
1090 (define-vop (data-vector-set-c/simple-base-string)
1091   (:translate data-vector-set)
1092   (:policy :fast-safe)
1093   (:args (object :scs (descriptor-reg) :to (:eval 0))
1094          (value :scs (character-reg)))
1095   (:info index)
1096   (:arg-types simple-base-string (:constant (signed-byte 30)) character)
1097   (:results (result :scs (character-reg)))
1098   (:result-types character)
1099   (:generator 4
1100    (inst mov (make-ea :byte :base object
1101                       :disp (- (+ (* vector-data-offset n-word-bytes) index)
1102                                other-pointer-lowtag))
1103          value)
1104    (move result value)))
1105 ) ; PROGN
1106
1107 #!+sb-unicode
1108 (define-full-reffer data-vector-ref/simple-character-string
1109     simple-character-string vector-data-offset other-pointer-lowtag
1110     (character-reg) character data-vector-ref)
1111 #!+sb-unicode
1112 (define-full-setter data-vector-set/simple-character-string
1113     simple-character-string vector-data-offset other-pointer-lowtag
1114     (character-reg) character data-vector-set)
1115
1116 ;;; signed-byte-8
1117
1118 (define-vop (data-vector-ref/simple-array-signed-byte-8)
1119   (:translate data-vector-ref)
1120   (:policy :fast-safe)
1121   (:args (object :scs (descriptor-reg))
1122          (index :scs (unsigned-reg)))
1123   (:arg-types simple-array-signed-byte-8 positive-fixnum)
1124   (:results (value :scs (signed-reg)))
1125   (:result-types tagged-num)
1126   (:generator 5
1127     (inst movsx value
1128           (make-ea :byte :base object :index index :scale 1
1129                    :disp (- (* vector-data-offset n-word-bytes)
1130                             other-pointer-lowtag)))))
1131
1132 (define-vop (data-vector-ref-c/simple-array-signed-byte-8)
1133   (:translate data-vector-ref)
1134   (:policy :fast-safe)
1135   (:args (object :scs (descriptor-reg)))
1136   (:info index)
1137   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
1138   (:results (value :scs (signed-reg)))
1139   (:result-types tagged-num)
1140   (:generator 4
1141     (inst movsx value
1142           (make-ea :byte :base object
1143                    :disp (- (+ (* vector-data-offset n-word-bytes) index)
1144                             other-pointer-lowtag)))))
1145
1146 (define-vop (data-vector-set/simple-array-signed-byte-8)
1147   (:translate data-vector-set)
1148   (:policy :fast-safe)
1149   (:args (object :scs (descriptor-reg) :to (:eval 0))
1150          (index :scs (unsigned-reg) :to (:eval 0))
1151          (value :scs (signed-reg) :target eax))
1152   (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
1153   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1154                    :from (:argument 2) :to (:result 0))
1155               eax)
1156   (:results (result :scs (signed-reg)))
1157   (:result-types tagged-num)
1158   (:generator 5
1159     (move eax value)
1160     (inst mov (make-ea :byte :base object :index index :scale 1
1161                        :disp (- (* vector-data-offset n-word-bytes)
1162                                 other-pointer-lowtag))
1163           al-tn)
1164     (move result eax)))
1165
1166 (define-vop (data-vector-set-c/simple-array-signed-byte-8)
1167   (:translate data-vector-set)
1168   (:policy :fast-safe)
1169   (:args (object :scs (descriptor-reg) :to (:eval 0))
1170          (value :scs (signed-reg) :target eax))
1171   (:info index)
1172   (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
1173               tagged-num)
1174   (:temporary (:sc unsigned-reg :offset eax-offset :target result
1175                    :from (:argument 1) :to (:result 0))
1176               eax)
1177   (:results (result :scs (signed-reg)))
1178   (:result-types tagged-num)
1179   (:generator 4
1180     (move eax value)
1181     (inst mov (make-ea :byte :base object
1182                        :disp (- (+ (* vector-data-offset n-word-bytes) index)
1183                                 other-pointer-lowtag))
1184           al-tn)
1185     (move result eax)))
1186
1187 ;;; signed-byte-16
1188
1189 (define-vop (data-vector-ref/simple-array-signed-byte-16)
1190   (:translate data-vector-ref)
1191   (:policy :fast-safe)
1192   (:args (object :scs (descriptor-reg))
1193          (index :scs (unsigned-reg)))
1194   (:arg-types simple-array-signed-byte-16 positive-fixnum)
1195   (:results (value :scs (signed-reg)))
1196   (:result-types tagged-num)
1197   (:generator 5
1198     (inst movsx value
1199           (make-ea :word :base object :index index :scale 2
1200                    :disp (- (* vector-data-offset n-word-bytes)
1201                             other-pointer-lowtag)))))
1202
1203 (define-vop (data-vector-ref-c/simple-array-signed-byte-16)
1204   (:translate data-vector-ref)
1205   (:policy :fast-safe)
1206   (:args (object :scs (descriptor-reg)))
1207   (:info index)
1208   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
1209   (:results (value :scs (signed-reg)))
1210   (:result-types tagged-num)
1211   (:generator 4
1212     (inst movsx value
1213           (make-ea :word :base object
1214                    :disp (- (+ (* vector-data-offset n-word-bytes)
1215                                (* 2 index))
1216                             other-pointer-lowtag)))))
1217
1218 (define-vop (data-vector-set/simple-array-signed-byte-16)
1219   (:translate data-vector-set)
1220   (:policy :fast-safe)
1221   (:args (object :scs (descriptor-reg) :to (:eval 0))
1222          (index :scs (unsigned-reg) :to (:eval 0))
1223          (value :scs (signed-reg) :target eax))
1224   (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
1225   (:temporary (:sc signed-reg :offset eax-offset :target result
1226                    :from (:argument 2) :to (:result 0))
1227               eax)
1228   (:results (result :scs (signed-reg)))
1229   (:result-types tagged-num)
1230   (:generator 5
1231     (move eax value)
1232     (inst mov (make-ea :word :base object :index index :scale 2
1233                        :disp (- (* vector-data-offset n-word-bytes)
1234                                 other-pointer-lowtag))
1235           ax-tn)
1236     (move result eax)))
1237
1238 (define-vop (data-vector-set-c/simple-array-signed-byte-16)
1239   (:translate data-vector-set)
1240   (:policy :fast-safe)
1241   (:args (object :scs (descriptor-reg) :to (:eval 0))
1242          (value :scs (signed-reg) :target eax))
1243   (:info index)
1244   (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
1245   (:temporary (:sc signed-reg :offset eax-offset :target result
1246                    :from (:argument 1) :to (:result 0))
1247               eax)
1248   (:results (result :scs (signed-reg)))
1249   (:result-types tagged-num)
1250   (:generator 4
1251     (move eax value)
1252     (inst mov
1253           (make-ea :word :base object
1254                    :disp (- (+ (* vector-data-offset n-word-bytes)
1255                                (* 2 index))
1256                             other-pointer-lowtag))
1257           ax-tn)
1258     (move result eax)))
1259 \f
1260 ;;; These vops are useful for accessing the bits of a vector
1261 ;;; irrespective of what type of vector it is.
1262 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1263   unsigned-num %raw-bits)
1264 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
1265   unsigned-num %set-raw-bits)
1266 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
1267   (unsigned-reg) unsigned-num %vector-raw-bits)
1268 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
1269   (unsigned-reg) unsigned-num %set-vector-raw-bits)
1270 \f
1271 ;;;; miscellaneous array VOPs
1272
1273 (define-vop (get-vector-subtype get-header-data))
1274 (define-vop (set-vector-subtype set-header-data))