src/compiler/mips/array.lisp

   1 ;;;; the MIPS definitions for array operations
   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 (define-vop (make-array-header)
  16   (:policy :fast-safe)
  17   (:translate make-array-header)
  18   (:args (type :scs (any-reg))
  19          (rank :scs (any-reg)))
  20   (:arg-types positive-fixnum positive-fixnum)
  21   (:temporary (:scs (non-descriptor-reg)) bytes header)
  22   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
  23   (:results (result :scs (descriptor-reg)))
  24   (:generator 13
  25     (inst addu bytes rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
  26                              lowtag-mask))
  27     (inst srl bytes n-lowtag-bits)
  28     (inst sll bytes n-lowtag-bits)
  29     (inst addu header rank (fixnumize (1- array-dimensions-offset)))
  30     (inst sll header n-widetag-bits)
  31     (inst or header type)
  32     ;; Remove the extraneous fixnum tag bits because TYPE and RANK
  33     ;; were fixnums
  34     (inst srl header n-fixnum-tag-bits)
  35     (pseudo-atomic (pa-flag)
  36       (inst or result alloc-tn other-pointer-lowtag)
  37       (storew header result 0 other-pointer-lowtag)
  38       (inst addu alloc-tn bytes))))
  39 \f
  40 ;;;; Additional accessors and setters for the array header.
  41 (define-full-reffer %array-dimension *
  42   array-dimensions-offset other-pointer-lowtag
  43   (any-reg) positive-fixnum sb!kernel:%array-dimension)
  44
  45 (define-full-setter %set-array-dimension *
  46   array-dimensions-offset other-pointer-lowtag
  47   (any-reg) positive-fixnum sb!kernel:%set-array-dimension)
  48
  49 (define-vop (array-rank-vop)
  50   (:translate sb!kernel:%array-rank)
  51   (:policy :fast-safe)
  52   (:args (x :scs (descriptor-reg)))
  53   (:temporary (:scs (non-descriptor-reg)) temp)
  54   (:results (res :scs (any-reg descriptor-reg)))
  55   (:generator 6
  56     (loadw temp x 0 other-pointer-lowtag)
  57     (inst sra temp n-widetag-bits)
  58     (inst subu temp (1- array-dimensions-offset))
  59     (inst sll res temp n-fixnum-tag-bits)))
  60 \f
  61 ;;;; Bounds checking routine.
  62 (define-vop (check-bound)
  63   (:translate %check-bound)
  64   (:policy :fast-safe)
  65   (:args (array :scs (descriptor-reg))
  66          (bound :scs (any-reg descriptor-reg))
  67          (index :scs (any-reg descriptor-reg) :target result))
  68   (:results (result :scs (any-reg descriptor-reg)))
  69   (:temporary (:scs (non-descriptor-reg)) temp)
  70   (:vop-var vop)
  71   (:save-p :compute-only)
  72   (:generator 5
  73     (let ((error (generate-error-code vop invalid-array-index-error
  74                                       array bound index)))
  75       (inst sltu temp index bound)
  76       (inst beq temp error)
  77       (inst nop)
  78       (move result index))))
  79 \f
  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 zero))) 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 zero)
 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-byte-29 positive-fixnum
 135     any-reg)
 136   (def-full-data-vector-frobs simple-array-signed-byte-30 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            (inst srl temp index ,bit-shift)
 161            (inst sll temp n-fixnum-tag-bits)
 162            (inst addu lip object temp)
 163            (inst lw result lip
 164                  (- (* vector-data-offset n-word-bytes)
 165                     other-pointer-lowtag))
 166            (inst and temp index ,(1- elements-per-word))
 167            ,@(when (eq *backend-byte-order* :big-endian)
 168                `((inst xor temp ,(1- elements-per-word))))
 169            ,@(unless (= bits 1)
 170                `((inst sll temp ,(1- (integer-length bits)))))
 171            (inst srl result temp)
 172            (inst and result ,(1- (ash 1 bits)))
 173            (inst sll value result n-fixnum-tag-bits)))
 174        (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" type))
 175          (:translate data-vector-ref)
 176          (:policy :fast-safe)
 177          (:args (object :scs (descriptor-reg)))
 178          (:arg-types ,type
 179                      (:constant
 180                       (integer 0
 181                                ,(1- (* (1+ (- (floor (+ #x7fff
 182                                                         other-pointer-lowtag)
 183                                                      n-word-bytes)
 184                                               vector-data-offset))
 185                                        elements-per-word)))))
 186          (:info index)
 187          (:results (result :scs (unsigned-reg)))
 188          (:result-types positive-fixnum)
 189          (:generator 15
 190            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 191              ,@(when (eq *backend-byte-order* :big-endian)
 192                  `((setf extra (logxor extra (1- ,elements-per-word)))))
 193              (loadw result object (+ word vector-data-offset)
 194                     other-pointer-lowtag)
 195              (unless (zerop extra)
 196                (inst srl result (* extra ,bits)))
 197              (unless (= extra ,(1- elements-per-word))
 198                (inst and result ,(1- (ash 1 bits)))))))
 199        (define-vop (,(symbolicate "DATA-VECTOR-SET/" type))
 200          (:note "inline array store")
 201          (:translate data-vector-set)
 202          (:policy :fast-safe)
 203          (:args (object :scs (descriptor-reg))
 204                 (index :scs (unsigned-reg) :target shift)
 205                 (value :scs (unsigned-reg zero immediate) :target result))
 206          (:arg-types ,type positive-fixnum positive-fixnum)
 207          (:results (result :scs (unsigned-reg)))
 208          (:result-types positive-fixnum)
 209          (:temporary (:scs (interior-reg)) lip)
 210          (:temporary (:scs (non-descriptor-reg)) temp old)
 211          (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
 212          (:generator 25
 213            (inst srl temp index ,bit-shift)
 214            (inst sll temp n-fixnum-tag-bits)
 215            (inst addu lip object temp)
 216            (inst lw old lip
 217                  (- (* vector-data-offset n-word-bytes)
 218                     other-pointer-lowtag))
 219            (inst and shift index ,(1- elements-per-word))
 220            ,@(when (eq *backend-byte-order* :big-endian)
 221                `((inst xor shift ,(1- elements-per-word))))
 222            ,@(unless (= bits 1)
 223                `((inst sll shift ,(1- (integer-length bits)))))
 224            (unless (and (sc-is value immediate)
 225                         (= (tn-value value) ,(1- (ash 1 bits))))
 226              (inst li temp ,(1- (ash 1 bits)))
 227              (inst sll temp shift)
 228              (inst nor temp temp zero-tn)
 229              (inst and old temp))
 230            (unless (sc-is value zero)
 231              (sc-case value
 232                (immediate
 233                 (inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
 234                (unsigned-reg
 235                 (inst and temp value ,(1- (ash 1 bits)))))
 236              (inst sll temp shift)
 237              (inst or old temp))
 238            (inst sw old lip
 239                  (- (* vector-data-offset n-word-bytes)
 240                     other-pointer-lowtag))
 241            (sc-case value
 242              (immediate
 243               (inst li result (tn-value value)))
 244              (zero
 245               (move result zero-tn))
 246              (unsigned-reg
 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
 255                       (integer 0
 256                                ,(1- (* (1+ (- (floor (+ #x7fff
 257                                                         other-pointer-lowtag)
 258                                                      n-word-bytes)
 259                                               vector-data-offset))
 260                                        elements-per-word))))
 261                      positive-fixnum)
 262          (:info index)
 263          (:results (result :scs (unsigned-reg)))
 264          (:result-types positive-fixnum)
 265          (:temporary (:scs (non-descriptor-reg)) temp old)
 266          (:generator 20
 267            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 268              ,@(when (eq *backend-byte-order* :big-endian)
 269                  `((setf extra (logxor extra (1- ,elements-per-word)))))
 270              (inst lw old object
 271                    (- (* (+ word vector-data-offset) n-word-bytes)
 272                       other-pointer-lowtag))
 273              (unless (and (sc-is value immediate)
 274                           (= (tn-value value) ,(1- (ash 1 bits))))
 275                (cond ((= extra ,(1- elements-per-word))
 276                       (inst sll old ,bits)
 277                       (inst srl old ,bits))
 278                      (t
 279                       (inst li temp
 280                             (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))))
 281                       (inst and old temp))))
 282              (sc-case value
 283                (zero)
 284                (immediate
 285                 (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
 286                                   (* extra ,bits))))
 287                   (cond ((< value #x10000)
 288                          (inst or old value))
 289                         (t
 290                          (inst li temp value)
 291                          (inst or old temp)))))
 292                (unsigned-reg
 293                 (inst sll temp value (* extra ,bits))
 294                 (inst or old temp)))
 295              (inst sw old object
 296                    (- (* (+ word vector-data-offset) n-word-bytes)
 297                       other-pointer-lowtag))
 298              (sc-case value
 299                (immediate
 300                 (inst li result (tn-value value)))
 301                (zero
 302                 (move result zero-tn))
 303                (unsigned-reg
 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 ;;; And the float variants.
 310 (define-vop (data-vector-ref/simple-array-single-float)
 311   (:note "inline array access")
 312   (:translate data-vector-ref)
 313   (:policy :fast-safe)
 314   (:args (object :scs (descriptor-reg))
 315          (index :scs (any-reg)))
 316   (:arg-types simple-array-single-float positive-fixnum)
 317   (:results (value :scs (single-reg)))
 318   (:result-types single-float)
 319   (:temporary (:scs (interior-reg)) lip)
 320   (:generator 20
 321     (inst addu lip object index)
 322     (inst lwc1 value lip
 323           (- (* vector-data-offset n-word-bytes)
 324              other-pointer-lowtag))
 325     (inst nop)))
 326
 327 (define-vop (data-vector-set/simple-array-single-float)
 328   (:note "inline array store")
 329   (:translate data-vector-set)
 330   (:policy :fast-safe)
 331   (:args (object :scs (descriptor-reg))
 332          (index :scs (any-reg))
 333          (value :scs (single-reg) :target result))
 334   (:arg-types simple-array-single-float positive-fixnum single-float)
 335   (:results (result :scs (single-reg)))
 336   (:result-types single-float)
 337   (:temporary (:scs (interior-reg)) lip)
 338   (:generator 20
 339     (inst addu lip object index)
 340     (inst swc1 value lip
 341           (- (* vector-data-offset n-word-bytes)
 342              other-pointer-lowtag))
 343     (unless (location= result value)
 344       (inst fmove :single result value))))
 345
 346 (define-vop (data-vector-ref/simple-array-double-float)
 347   (:note "inline array access")
 348   (:translate data-vector-ref)
 349   (:policy :fast-safe)
 350   (:args (object :scs (descriptor-reg))
 351          (index :scs (any-reg)))
 352   (:arg-types simple-array-double-float positive-fixnum)
 353   (:results (value :scs (double-reg)))
 354   (:result-types double-float)
 355   (:temporary (:scs (interior-reg)) lip)
 356   (:generator 20
 357     (inst addu lip object index)
 358     (inst addu lip index)
 359     (ecase *backend-byte-order*
 360       (:big-endian
 361        (inst lwc1 value lip
 362              (+ (- (* vector-data-offset n-word-bytes)
 363                    other-pointer-lowtag)
 364                 n-word-bytes))
 365        (inst lwc1-odd value lip
 366              (- (* vector-data-offset n-word-bytes)
 367                 other-pointer-lowtag)))
 368       (:little-endian
 369        (inst lwc1 value lip
 370              (- (* vector-data-offset n-word-bytes)
 371                 other-pointer-lowtag))
 372        (inst lwc1-odd value lip
 373              (+ (- (* vector-data-offset n-word-bytes)
 374                    other-pointer-lowtag)
 375                 n-word-bytes))))
 376     (inst nop)))
 377
 378 (define-vop (data-vector-set/simple-array-double-float)
 379   (:note "inline array store")
 380   (:translate data-vector-set)
 381   (:policy :fast-safe)
 382   (:args (object :scs (descriptor-reg))
 383          (index :scs (any-reg))
 384          (value :scs (double-reg) :target result))
 385   (:arg-types simple-array-double-float positive-fixnum double-float)
 386   (:results (result :scs (double-reg)))
 387   (:result-types double-float)
 388   (:temporary (:scs (interior-reg)) lip)
 389   (:generator 20
 390     (inst addu lip object index)
 391     (inst addu lip index)
 392     (ecase *backend-byte-order*
 393       (:big-endian
 394        (inst swc1 value lip
 395              (+ (- (* vector-data-offset n-word-bytes)
 396                    other-pointer-lowtag)
 397                 n-word-bytes))
 398        (inst swc1-odd value lip
 399              (- (* vector-data-offset n-word-bytes)
 400                 other-pointer-lowtag)))
 401       (:little-endian
 402        (inst swc1 value lip
 403              (- (* vector-data-offset n-word-bytes)
 404                 other-pointer-lowtag))
 405        (inst swc1-odd value lip
 406              (+ (- (* vector-data-offset n-word-bytes)
 407                    other-pointer-lowtag)
 408                 n-word-bytes))))
 409     (unless (location= result value)
 410       (inst fmove :double result value))))
 411 \f
 412 ;;; Complex float arrays.
 413 (define-vop (data-vector-ref/simple-array-complex-single-float)
 414   (:note "inline array access")
 415   (:translate data-vector-ref)
 416   (:policy :fast-safe)
 417   (:args (object :scs (descriptor-reg))
 418          (index :scs (any-reg)))
 419   (:arg-types simple-array-complex-single-float positive-fixnum)
 420   (:results (value :scs (complex-single-reg)))
 421   (:temporary (:scs (interior-reg)) lip)
 422   (:result-types complex-single-float)
 423   (:generator 5
 424     (inst addu lip object index)
 425     (inst addu lip index)
 426     (let ((real-tn (complex-single-reg-real-tn value)))
 427       (inst lwc1 real-tn lip (- (* vector-data-offset n-word-bytes)
 428                                 other-pointer-lowtag)))
 429     (let ((imag-tn (complex-single-reg-imag-tn value)))
 430       (inst lwc1 imag-tn lip (- (* (1+ vector-data-offset) n-word-bytes)
 431                                 other-pointer-lowtag)))
 432     (inst nop)))
 433
 434 (define-vop (data-vector-set/simple-array-complex-single-float)
 435   (:note "inline array store")
 436   (:translate data-vector-set)
 437   (:policy :fast-safe)
 438   (:args (object :scs (descriptor-reg))
 439          (index :scs (any-reg))
 440          (value :scs (complex-single-reg) :target result))
 441   (:arg-types simple-array-complex-single-float positive-fixnum
 442               complex-single-float)
 443   (:results (result :scs (complex-single-reg)))
 444   (:result-types complex-single-float)
 445   (:temporary (:scs (interior-reg)) lip)
 446   (:generator 5
 447     (inst addu lip object index)
 448     (inst addu lip index)
 449     (let ((value-real (complex-single-reg-real-tn value))
 450           (result-real (complex-single-reg-real-tn result)))
 451       (inst swc1 value-real lip (- (* vector-data-offset n-word-bytes)
 452                                    other-pointer-lowtag))
 453       (unless (location= result-real value-real)
 454         (inst fmove :single result-real value-real)))
 455     (let ((value-imag (complex-single-reg-imag-tn value))
 456           (result-imag (complex-single-reg-imag-tn result)))
 457       (inst swc1 value-imag lip (- (* (1+ vector-data-offset) n-word-bytes)
 458                                    other-pointer-lowtag))
 459       (unless (location= result-imag value-imag)
 460         (inst fmove :single result-imag value-imag)))))
 461
 462 (define-vop (data-vector-ref/simple-array-complex-double-float)
 463   (:note "inline array access")
 464   (:translate data-vector-ref)
 465   (:policy :fast-safe)
 466   (:args (object :scs (descriptor-reg))
 467          (index :scs (any-reg) :target shift))
 468   (:arg-types simple-array-complex-double-float positive-fixnum)
 469   (:results (value :scs (complex-double-reg)))
 470   (:result-types complex-double-float)
 471   (:temporary (:scs (interior-reg)) lip)
 472   (:temporary (:scs (any-reg) :from (:argument 1)) shift)
 473   (:generator 6
 474     (inst sll shift index n-fixnum-tag-bits)
 475     (inst addu lip object shift)
 476     (let ((real-tn (complex-double-reg-real-tn value)))
 477       (ld-double real-tn lip (- (* vector-data-offset n-word-bytes)
 478                                 other-pointer-lowtag)))
 479     (let ((imag-tn (complex-double-reg-imag-tn value)))
 480       (ld-double imag-tn lip (- (* (+ vector-data-offset 2) n-word-bytes)
 481                                 other-pointer-lowtag)))
 482     (inst nop)))
 483
 484 (define-vop (data-vector-set/simple-array-complex-double-float)
 485   (:note "inline array store")
 486   (:translate data-vector-set)
 487   (:policy :fast-safe)
 488   (:args (object :scs (descriptor-reg))
 489          (index :scs (any-reg) :target shift)
 490          (value :scs (complex-double-reg) :target result))
 491   (:arg-types simple-array-complex-double-float positive-fixnum
 492               complex-double-float)
 493   (:results (result :scs (complex-double-reg)))
 494   (:result-types complex-double-float)
 495   (:temporary (:scs (interior-reg)) lip)
 496   (:temporary (:scs (any-reg) :from (:argument 1)) shift)
 497   (:generator 6
 498     (inst sll shift index n-fixnum-tag-bits)
 499     (inst addu lip object shift)
 500     (let ((value-real (complex-double-reg-real-tn value))
 501           (result-real (complex-double-reg-real-tn result)))
 502       (str-double value-real lip (- (* vector-data-offset n-word-bytes)
 503                                     other-pointer-lowtag))
 504       (unless (location= result-real value-real)
 505         (inst fmove :double result-real value-real)))
 506     (let ((value-imag (complex-double-reg-imag-tn value))
 507           (result-imag (complex-double-reg-imag-tn result)))
 508       (str-double value-imag lip (- (* (+ vector-data-offset 2) n-word-bytes)
 509                                     other-pointer-lowtag))
 510       (unless (location= result-imag value-imag)
 511         (inst fmove :double result-imag value-imag)))))
 512
 513 \f
 514 ;;; These vops are useful for accessing the bits of a vector irrespective of
 515 ;;; what type of vector it is.
 516 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
 517   (unsigned-reg) unsigned-num %vector-raw-bits)
 518 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
 519   (unsigned-reg) unsigned-num %set-vector-raw-bits)
 520 \f
 521 ;;;; Misc. Array VOPs.
 522 (define-vop (get-vector-subtype get-header-data))
 523 (define-vop (set-vector-subtype set-header-data))