src/compiler/ppc/array.lisp

   1 ;;;; array operations for the PPC 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 \f
  15 ;;;; Allocator for the array header.
  16
  17 (define-vop (make-array-header)
  18   (:translate make-array-header)
  19   (:policy :fast-safe)
  20   (:args (type :scs (any-reg))
  21          (rank :scs (any-reg)))
  22   (:arg-types tagged-num tagged-num)
  23   (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
  24   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
  25   (:temporary (:scs (non-descriptor-reg)) ndescr)
  26   (:temporary (:scs (non-descriptor-reg)) gc-temp)
  27   #!-gencgc (:ignore gc-temp)
  28   (:results (result :scs (descriptor-reg)))
  29   (:generator 0
  30     (pseudo-atomic (pa-flag)
  31       (inst addi ndescr rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
  32                                 lowtag-mask))
  33       (inst clrrwi ndescr ndescr n-lowtag-bits)
  34       (allocation header ndescr other-pointer-lowtag
  35                   :temp-tn gc-temp
  36                   :flag-tn pa-flag)
  37       (inst addi ndescr rank (fixnumize (1- array-dimensions-offset)))
  38       (inst slwi ndescr ndescr n-widetag-bits)
  39       (inst or ndescr ndescr type)
  40       (inst srwi ndescr ndescr n-fixnum-tag-bits)
  41       (storew ndescr header 0 other-pointer-lowtag))
  42     (move result header)))
  43
  44 \f
  45 ;;;; Additional accessors and setters for the array header.
  46 (define-vop (%array-dimension word-index-ref)
  47   (:translate sb!kernel:%array-dimension)
  48   (:policy :fast-safe)
  49   (:variant array-dimensions-offset other-pointer-lowtag))
  50
  51 (define-vop (%set-array-dimension word-index-set)
  52   (:translate sb!kernel:%set-array-dimension)
  53   (:policy :fast-safe)
  54   (:variant array-dimensions-offset other-pointer-lowtag))
  55
  56 (define-vop (array-rank-vop)
  57   (:translate sb!kernel:%array-rank)
  58   (:policy :fast-safe)
  59   (:args (x :scs (descriptor-reg)))
  60   (:temporary (:scs (non-descriptor-reg)) temp)
  61   (:results (res :scs (any-reg descriptor-reg)))
  62   (:generator 6
  63     (loadw temp x 0 other-pointer-lowtag)
  64     (inst srawi temp temp n-widetag-bits)
  65     (inst subi temp temp (1- array-dimensions-offset))
  66     (inst slwi res temp n-fixnum-tag-bits)))
  67 \f
  68 ;;;; Bounds checking routine.
  69
  70
  71 (define-vop (check-bound)
  72   (:translate %check-bound)
  73   (:policy :fast-safe)
  74   (:args (array :scs (descriptor-reg))
  75          (bound :scs (any-reg descriptor-reg))
  76          (index :scs (any-reg descriptor-reg) :target result))
  77   (:results (result :scs (any-reg descriptor-reg)))
  78   (:vop-var vop)
  79   (:save-p :compute-only)
  80   (:generator 5
  81     (let ((error (generate-error-code vop 'invalid-array-index-error
  82                                       array bound index)))
  83       (inst cmplw index bound)
  84       (inst bge error)
  85       (move result index))))
  86
  87
  88 \f
  89 ;;;; Accessors/Setters
  90
  91 ;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whos
  92 ;;; elements are represented in integer registers and are built out of
  93 ;;; 8, 16, or 32 bit elements.
  94
  95 (macrolet ((def-data-vector-frobs (type variant element-type &rest scs)
  96   `(progn
  97      (define-vop (,(symbolicate "DATA-VECTOR-REF/" (string type))
  98                   ,(symbolicate (string variant) "-REF"))
  99        (:note "inline array access")
 100        (:variant vector-data-offset other-pointer-lowtag)
 101        (:translate data-vector-ref)
 102        (:arg-types ,type positive-fixnum)
 103        (:results (value :scs ,scs))
 104        (:result-types ,element-type))
 105      (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type))
 106                   ,(symbolicate (string variant) "-SET"))
 107        (:note "inline array store")
 108        (:variant vector-data-offset other-pointer-lowtag)
 109        (:translate data-vector-set)
 110        (:arg-types ,type positive-fixnum ,element-type)
 111        (:args (object :scs (descriptor-reg))
 112               (index :scs (any-reg zero immediate))
 113               (value :scs ,scs))
 114        (:results (result :scs ,scs))
 115        (:result-types ,element-type)))))
 116   (def-data-vector-frobs simple-base-string byte-index
 117     character character-reg)
 118   #!+sb-unicode
 119   (def-data-vector-frobs simple-character-string word-index
 120     character character-reg)
 121   (def-data-vector-frobs simple-vector word-index
 122     * descriptor-reg any-reg)
 123   (def-data-vector-frobs simple-array-unsigned-byte-7 byte-index
 124     positive-fixnum unsigned-reg)
 125   (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
 126     positive-fixnum unsigned-reg)
 127   (def-data-vector-frobs simple-array-unsigned-byte-15 halfword-index
 128     positive-fixnum unsigned-reg)
 129   (def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
 130     positive-fixnum unsigned-reg)
 131   (def-data-vector-frobs simple-array-unsigned-byte-31 word-index
 132     unsigned-num unsigned-reg)
 133   (def-data-vector-frobs simple-array-unsigned-byte-32 word-index
 134     unsigned-num unsigned-reg)
 135
 136   (def-data-vector-frobs simple-array-unsigned-fixnum word-index
 137     positive-fixnum any-reg)
 138   (def-data-vector-frobs simple-array-fixnum word-index
 139     tagged-num any-reg)
 140   (def-data-vector-frobs simple-array-signed-byte-32 word-index
 141     signed-num signed-reg))
 142
 143 #!+compare-and-swap-vops
 144 (define-vop (%compare-and-swap-svref word-index-cas)
 145   (:note "inline array compare-and-swap")
 146   (:policy :fast-safe)
 147   (:variant vector-data-offset other-pointer-lowtag)
 148   (:translate %compare-and-swap-svref)
 149   (:arg-types simple-vector positive-fixnum * *))
 150
 151 ;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
 152 ;;; and 4-bit vectors.
 153 ;;;
 154
 155 (macrolet ((def-small-data-vector-frobs (type bits)
 156   (let* ((elements-per-word (floor n-word-bits bits))
 157          (bit-shift (1- (integer-length elements-per-word))))
 158     `(progn
 159        (define-vop (,(symbolicate 'data-vector-ref/ type))
 160          (:note "inline array access")
 161          (:translate data-vector-ref)
 162          (:policy :fast-safe)
 163          (:args (object :scs (descriptor-reg))
 164                 (index :scs (unsigned-reg)))
 165          (:arg-types ,type positive-fixnum)
 166          (:results (value :scs (any-reg)))
 167          (:result-types positive-fixnum)
 168          (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
 169          (:generator 20
 170            ;; temp = (index >> bit-shift) << 2)
 171            (inst rlwinm temp index ,(- 32 (- bit-shift 2)) ,(- bit-shift 2) 29)
 172            (inst addi temp temp (- (* vector-data-offset n-word-bytes)
 173                                    other-pointer-lowtag))
 174            (inst lwzx result object temp)
 175            (inst andi. temp index ,(1- elements-per-word))
 176            (inst xori temp temp ,(1- elements-per-word))
 177            ,@(unless (= bits 1)
 178                `((inst slwi temp temp ,(1- (integer-length bits)))))
 179            (inst srw result result temp)
 180            (inst andi. result result ,(1- (ash 1 bits)))
 181            (inst slwi value result n-fixnum-tag-bits)))
 182        (define-vop (,(symbolicate 'data-vector-ref-c/ type))
 183          (:translate data-vector-ref)
 184          (:policy :fast-safe)
 185          (:args (object :scs (descriptor-reg)))
 186          (:arg-types ,type (:constant index))
 187          (:info index)
 188          (:results (result :scs (unsigned-reg)))
 189          (:result-types positive-fixnum)
 190          (:temporary (:scs (non-descriptor-reg)) temp)
 191          (:generator 15
 192            (multiple-value-bind (word extra)
 193                (floor index ,elements-per-word)
 194              (setf extra (logxor extra (1- ,elements-per-word)))
 195              (let ((offset (- (* (+ word vector-data-offset)
 196                                  n-word-bytes)
 197                               other-pointer-lowtag)))
 198                (cond ((typep offset '(signed-byte 16))
 199                       (inst lwz result object offset))
 200                      (t
 201                       (inst lr temp offset)
 202                       (inst lwzx result object temp))))
 203              (unless (zerop extra)
 204                (inst srwi result result (* ,bits extra)))
 205              (unless (= extra ,(1- elements-per-word))
 206                (inst andi. result result ,(1- (ash 1 bits)))))))
 207        (define-vop (,(symbolicate 'data-vector-set/ type))
 208          (:note "inline array store")
 209          (:translate data-vector-set)
 210          (:policy :fast-safe)
 211          (:args (object :scs (descriptor-reg))
 212                 (index :scs (unsigned-reg) :target shift)
 213                 (value :scs (unsigned-reg zero immediate) :target result))
 214          (:arg-types ,type positive-fixnum positive-fixnum)
 215          (:results (result :scs (unsigned-reg)))
 216          (:result-types positive-fixnum)
 217          (:temporary (:scs (non-descriptor-reg)) temp old offset)
 218          (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
 219          (:generator 25
 220            ;; offset = (index >> bit-shift) << 2)
 221            (inst rlwinm offset index ,(- 32 (- bit-shift 2)) ,(- bit-shift 2) 29)
 222            (inst addi offset offset (- (* vector-data-offset n-word-bytes)
 223                                        other-pointer-lowtag))
 224            (inst lwzx old object offset)
 225            (inst andi. shift index ,(1- elements-per-word))
 226            (inst xori shift shift ,(1- elements-per-word))
 227            ,@(unless (= bits 1)
 228                `((inst slwi shift shift ,(1- (integer-length bits)))))
 229            (unless (and (sc-is value immediate)
 230                         (= (tn-value value) ,(1- (ash 1 bits))))
 231              (inst lr temp ,(1- (ash 1 bits)))
 232              (inst slw temp temp shift)
 233              (inst andc old old temp))
 234            (unless (sc-is value zero)
 235              (sc-case value
 236                (immediate
 237                 (inst lr temp (logand (tn-value value) ,(1- (ash 1 bits)))))
 238                (unsigned-reg
 239                 (inst andi. temp value ,(1- (ash 1 bits)))))
 240              (inst slw temp temp shift)
 241              (inst or old old temp))
 242            (inst stwx old object offset)
 243            (sc-case value
 244              (immediate
 245               (inst lr result (tn-value value)))
 246              (t
 247               (move result value)))))
 248        (define-vop (,(symbolicate 'data-vector-set-c/ type))
 249          (:translate data-vector-set)
 250          (:policy :fast-safe)
 251          (:args (object :scs (descriptor-reg))
 252                 (value :scs (unsigned-reg zero immediate) :target result))
 253          (:arg-types ,type
 254                      (:constant index)
 255                      positive-fixnum)
 256          (:info index)
 257          (:results (result :scs (unsigned-reg)))
 258          (:result-types positive-fixnum)
 259          (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
 260          (:generator 20
 261            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 262              (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
 263                               other-pointer-lowtag)))
 264                (cond ((typep offset '(signed-byte 16))
 265                       (inst lwz old object offset))
 266                      (t
 267                       (inst lr offset-reg offset)
 268                       (inst lwzx old object offset-reg)))
 269                (unless (and (sc-is value immediate)
 270                             (= (tn-value value) ,(1- (ash 1 bits))))
 271                  (cond ((zerop extra)
 272                         (inst clrlwi old old ,bits))
 273                        (t
 274                         (inst lr temp
 275                               (lognot (ash ,(1- (ash 1 bits))
 276                                            (* (logxor extra
 277                                                       ,(1- elements-per-word))
 278                                               ,bits))))
 279                         (inst and old old temp))))
 280                (sc-case value
 281                  (zero)
 282                  (immediate
 283                   (let ((value (ash (logand (tn-value value)
 284                                             ,(1- (ash 1 bits)))
 285                                     (* (logxor extra
 286                                                ,(1- elements-per-word))
 287                                        ,bits))))
 288                     (cond ((typep value '(unsigned-byte 16))
 289                            (inst ori old old value))
 290                           (t
 291                            (inst lr temp value)
 292                            (inst or old old temp)))))
 293                  (unsigned-reg
 294                   (inst slwi temp value
 295                         (* (logxor extra ,(1- elements-per-word)) ,bits))
 296                   (inst or old old temp)))
 297                (if (typep offset '(signed-byte 16))
 298                    (inst stw old object offset)
 299                    (inst stwx old object offset-reg)))
 300              (sc-case value
 301                (immediate
 302                 (inst lr result (tn-value value)))
 303                (t
 304                 (move result value))))))))))
 305   (def-small-data-vector-frobs simple-bit-vector 1)
 306   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 307   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 308
 309
 310 ;;; And the float variants.
 311 ;;;
 312
 313 (define-vop (data-vector-ref/simple-array-single-float)
 314   (:note "inline array access")
 315   (:translate data-vector-ref)
 316   (:policy :fast-safe)
 317   (:args (object :scs (descriptor-reg))
 318          (index :scs (any-reg)))
 319   (:arg-types simple-array-single-float positive-fixnum)
 320   (:results (value :scs (single-reg)))
 321   (:temporary (:scs (non-descriptor-reg)) offset)
 322   (:result-types single-float)
 323   (:generator 5
 324     (inst addi offset index (- (* vector-data-offset n-word-bytes)
 325                               other-pointer-lowtag))
 326     (inst lfsx value object offset)))
 327
 328
 329 (define-vop (data-vector-set/simple-array-single-float)
 330   (:note "inline array store")
 331   (:translate data-vector-set)
 332   (:policy :fast-safe)
 333   (:args (object :scs (descriptor-reg))
 334          (index :scs (any-reg))
 335          (value :scs (single-reg) :target result))
 336   (:arg-types simple-array-single-float positive-fixnum single-float)
 337   (:results (result :scs (single-reg)))
 338   (:result-types single-float)
 339   (:temporary (:scs (non-descriptor-reg)) offset)
 340   (:generator 5
 341     (inst addi offset index
 342           (- (* vector-data-offset n-word-bytes)
 343              other-pointer-lowtag))
 344     (inst stfsx value object offset)
 345     (unless (location= result value)
 346       (inst frsp result value))))
 347
 348 (define-vop (data-vector-ref/simple-array-double-float)
 349   (:note "inline array access")
 350   (:translate data-vector-ref)
 351   (:policy :fast-safe)
 352   (:args (object :scs (descriptor-reg))
 353          (index :scs (any-reg)))
 354   (:arg-types simple-array-double-float positive-fixnum)
 355   (:results (value :scs (double-reg)))
 356   (:result-types double-float)
 357   (:temporary (:scs (non-descriptor-reg)) offset)
 358   (:generator 7
 359     (inst slwi offset index 1)
 360     (inst addi offset offset (- (* vector-data-offset n-word-bytes)
 361                                 other-pointer-lowtag))
 362     (inst lfdx value object offset)))
 363
 364 (define-vop (data-vector-set/simple-array-double-float)
 365   (:note "inline array store")
 366   (:translate data-vector-set)
 367   (:policy :fast-safe)
 368   (:args (object :scs (descriptor-reg))
 369          (index :scs (any-reg))
 370          (value :scs (double-reg) :target result))
 371   (:arg-types simple-array-double-float positive-fixnum double-float)
 372   (:results (result :scs (double-reg)))
 373   (:result-types double-float)
 374   (:temporary (:scs (non-descriptor-reg)) offset)
 375   (:generator 20
 376     (inst slwi offset index 1)
 377     (inst addi offset offset (- (* vector-data-offset n-word-bytes)
 378                         other-pointer-lowtag))
 379     (inst stfdx value object offset)
 380     (unless (location= result value)
 381       (inst fmr result value))))
 382
 383 \f
 384 ;;; Complex float arrays.
 385
 386 (define-vop (data-vector-ref/simple-array-complex-single-float)
 387   (:note "inline array access")
 388   (:translate data-vector-ref)
 389   (:policy :fast-safe)
 390   (:args (object :scs (descriptor-reg))
 391          (index :scs (any-reg)))
 392   (:arg-types simple-array-complex-single-float positive-fixnum)
 393   (:results (value :scs (complex-single-reg)))
 394   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 395   (:result-types complex-single-float)
 396   (:generator 5
 397     (let ((real-tn (complex-single-reg-real-tn value)))
 398       (inst slwi offset index 1)
 399       (inst addi offset offset (- (* vector-data-offset n-word-bytes)
 400                                   other-pointer-lowtag))
 401       (inst lfsx real-tn object offset))
 402     (let ((imag-tn (complex-single-reg-imag-tn value)))
 403       (inst addi offset offset n-word-bytes)
 404       (inst lfsx imag-tn object offset))))
 405
 406 (define-vop (data-vector-set/simple-array-complex-single-float)
 407   (:note "inline array store")
 408   (:translate data-vector-set)
 409   (:policy :fast-safe)
 410   (:args (object :scs (descriptor-reg))
 411          (index :scs (any-reg))
 412          (value :scs (complex-single-reg) :target result))
 413   (:arg-types simple-array-complex-single-float positive-fixnum
 414               complex-single-float)
 415   (:results (result :scs (complex-single-reg)))
 416   (:result-types complex-single-float)
 417   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 418   (:generator 5
 419     (let ((value-real (complex-single-reg-real-tn value))
 420           (result-real (complex-single-reg-real-tn result)))
 421       (inst slwi offset index 1)
 422       (inst addi offset offset (- (* vector-data-offset n-word-bytes)
 423                                   other-pointer-lowtag))
 424       (inst stfsx value-real object offset)
 425       (unless (location= result-real value-real)
 426         (inst frsp result-real value-real)))
 427     (let ((value-imag (complex-single-reg-imag-tn value))
 428           (result-imag (complex-single-reg-imag-tn result)))
 429       (inst addi offset offset n-word-bytes)
 430       (inst stfsx value-imag object offset)
 431       (unless (location= result-imag value-imag)
 432         (inst frsp result-imag value-imag)))))
 433
 434
 435 (define-vop (data-vector-ref/simple-array-complex-double-float)
 436   (:note "inline array access")
 437   (:translate data-vector-ref)
 438   (:policy :fast-safe)
 439   (:args (object :scs (descriptor-reg) :to :result)
 440          (index :scs (any-reg)))
 441   (:arg-types simple-array-complex-double-float positive-fixnum)
 442   (:results (value :scs (complex-double-reg)))
 443   (:result-types complex-double-float)
 444   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 445   (:generator 7
 446     (let ((real-tn (complex-double-reg-real-tn value)))
 447       (inst slwi offset index 2)
 448       (inst addi offset offset (- (* vector-data-offset n-word-bytes)
 449                                   other-pointer-lowtag))
 450       (inst lfdx real-tn object offset))
 451     (let ((imag-tn (complex-double-reg-imag-tn value)))
 452       (inst addi offset offset (* 2 n-word-bytes))
 453       (inst lfdx imag-tn object offset))))
 454
 455 (define-vop (data-vector-set/simple-array-complex-double-float)
 456   (:note "inline array store")
 457   (:translate data-vector-set)
 458   (:policy :fast-safe)
 459   (:args (object :scs (descriptor-reg) :to :result)
 460          (index :scs (any-reg))
 461          (value :scs (complex-double-reg) :target result))
 462   (:arg-types simple-array-complex-double-float positive-fixnum
 463               complex-double-float)
 464   (:results (result :scs (complex-double-reg)))
 465   (:result-types complex-double-float)
 466   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 467   (:generator 20
 468     (let ((value-real (complex-double-reg-real-tn value))
 469           (result-real (complex-double-reg-real-tn result)))
 470       (inst slwi offset index 2)
 471       (inst addi offset offset (- (* vector-data-offset n-word-bytes)
 472                                   other-pointer-lowtag))
 473       (inst stfdx value-real object offset)
 474       (unless (location= result-real value-real)
 475         (inst fmr result-real value-real)))
 476     (let ((value-imag (complex-double-reg-imag-tn value))
 477           (result-imag (complex-double-reg-imag-tn result)))
 478       (inst addi offset offset (* 2 n-word-bytes))
 479       (inst stfdx value-imag object offset)
 480       (unless (location= result-imag value-imag)
 481         (inst fmr result-imag value-imag)))))
 482
 483 \f
 484 ;;; These vops are useful for accessing the bits of a vector irrespective of
 485 ;;; what type of vector it is.
 486 ;;;
 487
 488 (define-vop (vector-raw-bits word-index-ref)
 489   (:note "vector-raw-bits VOP")
 490   (:translate %vector-raw-bits)
 491   (:results (value :scs (unsigned-reg)))
 492   (:result-types unsigned-num)
 493   (:variant vector-data-offset other-pointer-lowtag))
 494
 495 (define-vop (set-vector-raw-bits word-index-set)
 496   (:note "setf vector-raw-bits VOP")
 497   (:translate %set-vector-raw-bits)
 498   (:args (object :scs (descriptor-reg))
 499          (index :scs (any-reg zero immediate))
 500          (value :scs (unsigned-reg)))
 501   (:arg-types * positive-fixnum unsigned-num)
 502   (:results (result :scs (unsigned-reg)))
 503   (:result-types unsigned-num)
 504   (:variant vector-data-offset other-pointer-lowtag))
 505 \f
 506 ;;;; Misc. Array VOPs.
 507
 508
 509 #+nil
 510 (define-vop (vector-word-length)
 511   (:args (vec :scs (descriptor-reg)))
 512   (:results (res :scs (any-reg descriptor-reg)))
 513   (:generator 6
 514     (loadw res vec clc::g-vector-header-words)
 515     (inst niuo res res clc::g-vector-words-mask-16)))
 516
 517 (define-vop (get-vector-subtype get-header-data))
 518 (define-vop (set-vector-subtype set-header-data))
 519
 520 \f
 521 ;;;
 522
 523 (define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref)
 524   (:note "inline array access")
 525   (:variant vector-data-offset other-pointer-lowtag)
 526   (:translate data-vector-ref)
 527   (:arg-types simple-array-signed-byte-8 positive-fixnum)
 528   (:results (value :scs (signed-reg)))
 529   (:result-types tagged-num))
 530
 531 (define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set)
 532   (:note "inline array store")
 533   (:variant vector-data-offset other-pointer-lowtag)
 534   (:translate data-vector-set)
 535   (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
 536   (:args (object :scs (descriptor-reg))
 537          (index :scs (any-reg zero immediate))
 538          (value :scs (signed-reg)))
 539   (:results (result :scs (signed-reg)))
 540   (:result-types tagged-num))
 541
 542 (define-vop (data-vector-ref/simple-array-signed-byte-16
 543              signed-halfword-index-ref)
 544   (:note "inline array access")
 545   (:variant vector-data-offset other-pointer-lowtag)
 546   (:translate data-vector-ref)
 547   (:arg-types simple-array-signed-byte-16 positive-fixnum)
 548   (:results (value :scs (signed-reg)))
 549   (:result-types tagged-num))
 550
 551 (define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set)
 552   (:note "inline array store")
 553   (:variant vector-data-offset other-pointer-lowtag)
 554   (:translate data-vector-set)
 555   (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
 556   (:args (object :scs (descriptor-reg))
 557          (index :scs (any-reg zero immediate))
 558          (value :scs (signed-reg)))
 559   (:results (result :scs (signed-reg)))
 560   (:result-types tagged-num))
 561 \f
 562 ;;;; ATOMIC-INCF for arrays
 563
 564 (define-vop (array-atomic-incf/word)
 565   (:translate %array-atomic-incf/word)
 566   (:policy :fast-safe)
 567   (:args (object :scs (descriptor-reg))
 568          (index :scs (any-reg) :target offset)
 569          (diff :scs (unsigned-reg)))
 570   (:arg-types * positive-fixnum unsigned-num)
 571   (:results (result :scs (unsigned-reg) :from :load))
 572   (:result-types unsigned-num)
 573   (:temporary (:sc unsigned-reg :from (:argument 1)) offset)
 574   (:temporary (:sc non-descriptor-reg) sum)
 575   (:generator 4
 576     (inst addi offset index
 577           (- (* vector-data-offset n-word-bytes)
 578              other-pointer-lowtag))
 579     ;; load the slot value, add DIFF, write the sum back, and return
 580     ;; the original slot value, atomically, and include a memory
 581     ;; barrier.
 582     (inst sync)
 583     LOOP
 584     (inst lwarx result offset object)
 585     (inst add sum result diff)
 586     (inst stwcx. sum offset object)
 587     (inst bne LOOP)
 588     (inst isync)))