src/compiler/alpha/array.lisp

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