src/compiler/arm/array.lisp

   1 ;;;; array operations for the ARM 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 ocfp-offset) pa-flag)
  25   (:temporary (:scs (non-descriptor-reg)) ndescr)
  26   (:results (result :scs (descriptor-reg)))
  27   (:generator 0
  28     ;; Compute the allocation size.
  29     (inst add ndescr rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
  30                              lowtag-mask))
  31     (inst bic ndescr ndescr lowtag-mask)
  32     (pseudo-atomic (pa-flag)
  33       (allocation header ndescr other-pointer-lowtag :flag-tn pa-flag)
  34       ;; Now that we have the space allocated, compute the header
  35       ;; value.
  36       (inst add ndescr rank (fixnumize (1- array-dimensions-offset)))
  37       (inst mov ndescr (lsl ndescr (- n-widetag-bits n-fixnum-tag-bits)))
  38       (inst orr ndescr ndescr (lsr type n-fixnum-tag-bits))
  39       ;; And store the header value.
  40       (storew ndescr header 0 other-pointer-lowtag))
  41     (move result header)))
  42 \f
  43 ;;;; Additional accessors and setters for the array header.
  44 (define-full-reffer %array-dimension *
  45   array-dimensions-offset other-pointer-lowtag
  46   (any-reg) positive-fixnum sb!kernel:%array-dimension)
  47
  48 (define-full-setter %set-array-dimension *
  49   array-dimensions-offset other-pointer-lowtag
  50   (any-reg) positive-fixnum sb!kernel:%set-array-dimension)
  51
  52 (define-vop (array-rank-vop)
  53   (:translate sb!kernel:%array-rank)
  54   (:policy :fast-safe)
  55   (:args (x :scs (descriptor-reg)))
  56   (:temporary (:scs (non-descriptor-reg)) temp)
  57   (:results (res :scs (any-reg descriptor-reg)))
  58   (:generator 6
  59     (loadw temp x 0 other-pointer-lowtag)
  60     (inst mov temp (asr temp n-widetag-bits))
  61     (inst sub temp temp (1- array-dimensions-offset))
  62     (inst mov res (lsl temp n-fixnum-tag-bits))))
  63 ;;;; Bounds checking routine.
  64 (define-vop (check-bound)
  65   (:translate %check-bound)
  66   (:policy :fast-safe)
  67   (:args (array :scs (descriptor-reg))
  68          (bound :scs (any-reg descriptor-reg))
  69          (index :scs (any-reg descriptor-reg) :target result))
  70   (:temporary (:scs (non-descriptor-reg) :offset ocfp-offset) temp)
  71   (:results (result :scs (any-reg descriptor-reg)))
  72   (:vop-var vop)
  73   (:save-p :compute-only)
  74   (:generator 5
  75     (let ((error (generate-error-code vop temp 'invalid-array-index-error array bound index)))
  76       (inst cmp index bound)
  77       (inst b :ge error)
  78       (move result index))))
  79
  80 ;;;; Accessors/Setters
  81
  82 ;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whos
  83 ;;; elements are represented in integer registers and are built out of
  84 ;;; 8, 16, or 32 bit elements.
  85 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
  86   `(progn
  87      (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
  88        vector-data-offset other-pointer-lowtag
  89        ,(remove-if #'(lambda (x) (member x '(null))) scs)
  90        ,element-type
  91        data-vector-ref)
  92      (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
  93        vector-data-offset other-pointer-lowtag ,scs ,element-type
  94        data-vector-set)))
  95
  96            (def-partial-data-vector-frobs (type element-type size signed &rest scs)
  97   `(progn
  98      (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
  99        ,size ,signed vector-data-offset other-pointer-lowtag ,scs
 100        ,element-type data-vector-ref)
 101      (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
 102        ,size vector-data-offset other-pointer-lowtag ,scs
 103        ,element-type data-vector-set))))
 104
 105   (def-full-data-vector-frobs simple-vector *
 106     descriptor-reg any-reg null)
 107
 108   (def-partial-data-vector-frobs simple-base-string character
 109     :byte nil character-reg)
 110   #!+sb-unicode
 111   (def-full-data-vector-frobs simple-character-string character character-reg)
 112
 113   (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
 114     :byte nil unsigned-reg signed-reg)
 115   (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
 116     :byte nil unsigned-reg signed-reg)
 117
 118   (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
 119     :short nil unsigned-reg signed-reg)
 120   (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
 121     :short nil unsigned-reg signed-reg)
 122
 123   (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
 124     unsigned-reg)
 125   (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
 126     unsigned-reg)
 127
 128   (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
 129     :byte t signed-reg)
 130
 131   (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
 132     :short t signed-reg)
 133
 134   (def-full-data-vector-frobs simple-array-unsigned-fixnum positive-fixnum
 135     any-reg)
 136   (def-full-data-vector-frobs simple-array-fixnum tagged-num
 137     any-reg)
 138
 139   (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
 140     signed-reg))
 141
 142 ;;; Integer vectors whose elements are smaller than a byte.  I.e. bit, 2-bit,
 143 ;;; and 4-bit vectors.
 144 (macrolet ((def-small-data-vector-frobs (type bits)
 145   (let* ((elements-per-word (floor n-word-bits bits))
 146          (bit-shift (1- (integer-length elements-per-word))))
 147     `(progn
 148        (define-vop (,(symbolicate "DATA-VECTOR-REF/" type))
 149          (:note "inline array access")
 150          (:translate data-vector-ref)
 151          (:policy :fast-safe)
 152          (:args (object :scs (descriptor-reg))
 153                 (index :scs (unsigned-reg)))
 154          (:arg-types ,type positive-fixnum)
 155          (:results (value :scs (any-reg)))
 156          (:result-types positive-fixnum)
 157          (:temporary (:scs (interior-reg)) lip)
 158          (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
 159          (:generator 20
 160            ;; Compute the offset for the word we're interested in.
 161            (inst mov temp (lsr index ,bit-shift))
 162            ;; Load the word in question.
 163            (inst add lip object (lsl temp word-shift))
 164            (inst ldr result (@ lip
 165                                (- (* vector-data-offset n-word-bytes)
 166                                   other-pointer-lowtag)))
 167            ;; Compute the position of the bitfield we need.
 168            (inst and temp index ,(1- elements-per-word))
 169            ,@(when (eq *backend-byte-order* :big-endian)
 170                `((inst eor temp temp ,(1- elements-per-word))))
 171            ,@(unless (= bits 1)
 172                `((inst mov temp (lsl temp ,(1- (integer-length bits))))))
 173            ;; Shift the field we need to the low bits of RESULT.
 174            (inst mov result (lsr result temp))
 175            ;; Mask out the field we're interested in.
 176            (inst and result result ,(1- (ash 1 bits)))
 177            ;; And fixnum-tag the result.
 178            (inst mov value (lsl result n-fixnum-tag-bits))))
 179        (define-vop (,(symbolicate "DATA-VECTOR-SET/" type))
 180          (:note "inline array store")
 181          (:translate data-vector-set)
 182          (:policy :fast-safe)
 183          (:args (object :scs (descriptor-reg))
 184                 (index :scs (unsigned-reg) :target shift)
 185                 (value :scs (unsigned-reg immediate) :target result))
 186          (:arg-types ,type positive-fixnum positive-fixnum)
 187          (:results (result :scs (unsigned-reg)))
 188          (:result-types positive-fixnum)
 189          (:temporary (:scs (interior-reg)) lip)
 190          (:temporary (:scs (non-descriptor-reg)) temp old)
 191          (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
 192          (:generator 25
 193            ;; Compute the offset for the word we're interested in.
 194            (inst mov temp (lsr index ,bit-shift))
 195            (inst mov temp (lsl temp n-fixnum-tag-bits))
 196            ;; Load the word in question.
 197            (inst add lip object temp)
 198            (inst ldr old (@ lip
 199                             (- (* vector-data-offset n-word-bytes)
 200                                other-pointer-lowtag)))
 201            ;; Compute the position of the bitfield we need.
 202            (inst and shift index ,(1- elements-per-word))
 203            ,@(when (eq *backend-byte-order* :big-endian)
 204                `((inst eor shift ,(1- elements-per-word))))
 205            ,@(unless (= bits 1)
 206                `((inst mov shift  (lsl shift ,(1- (integer-length bits))))))
 207            ;; Clear the target bitfield.
 208            (unless (and (sc-is value immediate)
 209                         (= (tn-value value) ,(1- (ash 1 bits))))
 210              (inst mov temp ,(1- (ash 1 bits)))
 211              (inst bic old old (lsl temp shift)))
 212            ;; LOGIOR in the new value (shifted appropriatly).
 213            (sc-case value
 214              (immediate
 215               (inst mov temp (logand (tn-value value) ,(1- (ash 1 bits)))))
 216              (unsigned-reg
 217               (inst and temp value ,(1- (ash 1 bits)))))
 218            (inst orr old old (lsl temp shift))
 219            ;; Write the altered word back to the array.
 220            (inst str old (@ lip
 221                             (- (* vector-data-offset n-word-bytes)
 222                                other-pointer-lowtag)))
 223            ;; And present the result properly.
 224            (sc-case value
 225              (immediate
 226               (inst mov result (tn-value value)))
 227              (unsigned-reg
 228               (move result value)))))))))
 229   (def-small-data-vector-frobs simple-bit-vector 1)
 230   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 231   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 232
 233 ;;; And the float variants.
 234 (define-vop (data-vector-ref/simple-array-single-float)
 235   (:note "inline array access")
 236   (:translate data-vector-ref)
 237   (:policy :fast-safe)
 238   (:args (object :scs (descriptor-reg))
 239          (index :scs (any-reg)))
 240   (:arg-types simple-array-single-float positive-fixnum)
 241   (:results (value :scs (single-reg)))
 242   (:temporary (:scs (interior-reg)) lip)
 243   (:result-types single-float)
 244   (:generator 5
 245     (inst add lip object (- (* vector-data-offset n-word-bytes)
 246                               other-pointer-lowtag))
 247     (inst add lip lip index)
 248     (inst flds value (@ lip))))
 249
 250
 251 (define-vop (data-vector-set/simple-array-single-float)
 252   (:note "inline array store")
 253   (:translate data-vector-set)
 254   (:policy :fast-safe)
 255   (:args (object :scs (descriptor-reg))
 256          (index :scs (any-reg))
 257          (value :scs (single-reg) :target result))
 258   (:arg-types simple-array-single-float positive-fixnum single-float)
 259   (:results (result :scs (single-reg)))
 260   (:result-types single-float)
 261   (:temporary (:scs (interior-reg)) lip)
 262   (:generator 5
 263     (inst add lip object (- (* vector-data-offset n-word-bytes)
 264                             other-pointer-lowtag))
 265     (inst add lip lip index)
 266     (inst fsts value (@ lip))
 267     (unless (location= result value)
 268       (inst fcpys result value))))
 269
 270 (define-vop (data-vector-ref/simple-array-double-float)
 271   (:note "inline array access")
 272   (:translate data-vector-ref)
 273   (:policy :fast-safe)
 274   (:args (object :scs (descriptor-reg))
 275          (index :scs (any-reg)))
 276   (:arg-types simple-array-double-float positive-fixnum)
 277   (:results (value :scs (double-reg)))
 278   (:result-types double-float)
 279   (:temporary (:scs (interior-reg)) lip)
 280   (:generator 7
 281     (inst add lip object (- (* vector-data-offset n-word-bytes)
 282                             other-pointer-lowtag))
 283     (inst add lip lip (lsl index 1))
 284     (inst fldd value (@ lip))))
 285
 286 (define-vop (data-vector-set/simple-array-double-float)
 287   (:note "inline array store")
 288   (:translate data-vector-set)
 289   (:policy :fast-safe)
 290   (:args (object :scs (descriptor-reg))
 291          (index :scs (any-reg))
 292          (value :scs (double-reg) :target result))
 293   (:arg-types simple-array-double-float positive-fixnum double-float)
 294   (:results (result :scs (double-reg)))
 295   (:result-types double-float)
 296   (:temporary (:scs (interior-reg)) lip)
 297   (:generator 20
 298     (inst add lip object (- (* vector-data-offset n-word-bytes)
 299                                other-pointer-lowtag))
 300     (inst add lip lip (lsl index 1))
 301     (inst fstd value (@ lip))
 302     (unless (location= result value)
 303       (inst fcpyd result value))))
 304 \f
 305 ;;; Complex float arrays.
 306
 307 (define-vop (data-vector-ref/simple-array-complex-single-float)
 308   (:note "inline array access")
 309   (:translate data-vector-ref)
 310   (:policy :fast-safe)
 311   (:args (object :scs (descriptor-reg) :to :result)
 312          (index :scs (any-reg)))
 313   (:arg-types simple-array-complex-single-float positive-fixnum)
 314   (:results (value :scs (complex-single-reg)))
 315   (:temporary (:scs (interior-reg)) lip)
 316   (:result-types complex-single-float)
 317   (:generator 5
 318     (let ((real-tn (complex-single-reg-real-tn value)))
 319       (inst add lip object (- (* vector-data-offset n-word-bytes)
 320                               other-pointer-lowtag))
 321       (inst add lip lip (lsl index 1))
 322       (inst flds real-tn (@ lip)))
 323     (let ((imag-tn (complex-single-reg-imag-tn value)))
 324       (inst flds imag-tn (@ lip n-word-bytes)))))
 325
 326 (define-vop (data-vector-set/simple-array-complex-single-float)
 327   (:note "inline array store")
 328   (:translate data-vector-set)
 329   (:policy :fast-safe)
 330   (:args (object :scs (descriptor-reg) :to :result)
 331          (index :scs (any-reg))
 332          (value :scs (complex-single-reg) :target result))
 333   (:arg-types simple-array-complex-single-float positive-fixnum
 334               complex-single-float)
 335   (:results (result :scs (complex-single-reg)))
 336   (:result-types complex-single-float)
 337   (:temporary (:scs (interior-reg)) lip)
 338   (:generator 5
 339     (let ((value-real (complex-single-reg-real-tn value))
 340           (result-real (complex-single-reg-real-tn result)))
 341       (inst add lip object (- (* vector-data-offset n-word-bytes)
 342                                  other-pointer-lowtag))
 343       (inst add lip lip (lsl index 1))
 344       (inst fsts value-real (@ lip))
 345       (unless (location= result-real value-real)
 346         (inst fcpys result-real value-real)))
 347     (let ((value-imag (complex-single-reg-imag-tn value))
 348           (result-imag (complex-single-reg-imag-tn result)))
 349       (inst fsts value-imag (@ lip n-word-bytes))
 350       (unless (location= result-imag value-imag)
 351         (inst fcpys result-imag value-imag)))))
 352
 353 (define-vop (data-vector-ref/simple-array-complex-double-float)
 354   (:note "inline array access")
 355   (:translate data-vector-ref)
 356   (:policy :fast-safe)
 357   (:args (object :scs (descriptor-reg) :to :result)
 358          (index :scs (any-reg)))
 359   (:arg-types simple-array-complex-double-float positive-fixnum)
 360   (:results (value :scs (complex-double-reg)))
 361   (:result-types complex-double-float)
 362   (:temporary (:scs (interior-reg)) lip)
 363   (:generator 7
 364     (let ((real-tn (complex-double-reg-real-tn value)))
 365       (inst add lip object (- (* vector-data-offset n-word-bytes)
 366                               other-pointer-lowtag))
 367       (inst add lip lip (lsl index 2))
 368       (inst fldd real-tn (@ lip)))
 369     (let ((imag-tn (complex-double-reg-imag-tn value)))
 370       (inst fldd imag-tn (@ lip (* 2 n-word-bytes))))))
 371
 372 (define-vop (data-vector-set/simple-array-complex-double-float)
 373   (:note "inline array store")
 374   (:translate data-vector-set)
 375   (:policy :fast-safe)
 376   (:args (object :scs (descriptor-reg) :to :result)
 377          (index :scs (any-reg))
 378          (value :scs (complex-double-reg) :target result))
 379   (:arg-types simple-array-complex-double-float positive-fixnum
 380               complex-double-float)
 381   (:results (result :scs (complex-double-reg)))
 382   (:result-types complex-double-float)
 383   (:temporary (:scs (interior-reg)) lip)
 384   (:generator 20
 385     (let ((value-real (complex-double-reg-real-tn value))
 386           (result-real (complex-double-reg-real-tn result)))
 387       (inst add lip object (- (* vector-data-offset n-word-bytes)
 388                               other-pointer-lowtag))
 389       (inst add lip lip (lsl index 2))
 390       (inst fstd value-real (@ lip))
 391       (unless (location= result-real value-real)
 392         (inst fcpyd result-real value-real)))
 393     (let ((value-imag (complex-double-reg-imag-tn value))
 394           (result-imag (complex-double-reg-imag-tn result)))
 395       (inst fstd value-imag (@ lip (* 2 n-word-bytes)))
 396       (unless (location= result-imag value-imag)
 397         (inst fcpyd result-imag value-imag)))))
 398 \f
 399 ;;; These vops are useful for accessing the bits of a vector irrespective of
 400 ;;; what type of vector it is.
 401 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
 402   (unsigned-reg) unsigned-num %vector-raw-bits)
 403 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
 404   (unsigned-reg) unsigned-num %set-vector-raw-bits)