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 (1- n-lowtag-bits))
  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 :eq 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 \f
 233 ;;; These vops are useful for accessing the bits of a vector irrespective of
 234 ;;; what type of vector it is.
 235 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
 236   (unsigned-reg) unsigned-num %vector-raw-bits)
 237 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
 238   (unsigned-reg) unsigned-num %set-vector-raw-bits)