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 (+ (* 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-byte-29 positive-fixnum any-reg)
 329   (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
 330
 331   (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
 332     signed-reg)
 333
 334   ;; Integer vectors whos elements are smaller than a byte. I.e. bit,
 335   ;; 2-bit, and 4-bit vectors.
 336   (def-small-data-vector-frobs simple-bit-vector 1)
 337   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 338   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 339
 340 ;;; and the float variants..
 341
 342 (define-vop (data-vector-ref/simple-array-single-float)
 343   (:note "inline array access")
 344   (:translate data-vector-ref)
 345   (:policy :fast-safe)
 346   (:args (object :scs (descriptor-reg))
 347          (index :scs (any-reg)))
 348   (:arg-types simple-array-single-float positive-fixnum)
 349   (:results (value :scs (single-reg)))
 350   (:result-types single-float)
 351   (:temporary (:scs (interior-reg)) lip)
 352   (:generator 20
 353     (inst addq object index lip)
 354     (inst lds value
 355           (- (* vector-data-offset n-word-bytes)
 356              other-pointer-lowtag)
 357            lip)))
 358
 359 (define-vop (data-vector-set/simple-array-single-float)
 360   (:note "inline array store")
 361   (:translate data-vector-set)
 362   (:policy :fast-safe)
 363   (:args (object :scs (descriptor-reg))
 364          (index :scs (any-reg))
 365          (value :scs (single-reg) :target result))
 366   (:arg-types simple-array-single-float positive-fixnum single-float)
 367   (:results (result :scs (single-reg)))
 368   (:result-types single-float)
 369   (:temporary (:scs (interior-reg)) lip)
 370   (:generator 20
 371     (inst addq object index lip)
 372     (inst sts value
 373           (- (* vector-data-offset n-word-bytes)
 374              other-pointer-lowtag)
 375           lip)
 376     (unless (location= result value)
 377       (inst fmove value result))))
 378
 379 (define-vop (data-vector-ref/simple-array-double-float)
 380   (:note "inline array access")
 381   (:translate data-vector-ref)
 382   (:policy :fast-safe)
 383   (:args (object :scs (descriptor-reg))
 384          (index :scs (any-reg)))
 385   (:arg-types simple-array-double-float positive-fixnum)
 386   (:results (value :scs (double-reg)))
 387   (:result-types double-float)
 388   (:temporary (:scs (interior-reg)) lip)
 389   (:generator 20
 390     (inst addq object index lip)
 391     (inst addq lip index lip)
 392     (inst ldt value
 393           (- (* vector-data-offset n-word-bytes)
 394              other-pointer-lowtag)
 395           lip)))
 396
 397 (define-vop (data-vector-set/simple-array-double-float)
 398   (:note "inline array store")
 399   (:translate data-vector-set)
 400   (:policy :fast-safe)
 401   (:args (object :scs (descriptor-reg))
 402          (index :scs (any-reg))
 403          (value :scs (double-reg) :target result))
 404   (:arg-types simple-array-double-float positive-fixnum double-float)
 405   (:results (result :scs (double-reg)))
 406   (:result-types double-float)
 407   (:temporary (:scs (interior-reg)) lip)
 408   (:generator 20
 409     (inst addq object index lip)
 410     (inst addq lip index lip)
 411     (inst stt value
 412           (- (* vector-data-offset n-word-bytes)
 413              other-pointer-lowtag) lip)
 414     (unless (location= result value)
 415       (inst fmove value result))))
 416 \f
 417 ;;; complex float arrays
 418
 419 (define-vop (data-vector-ref/simple-array-complex-single-float)
 420   (:note "inline array access")
 421   (:translate data-vector-ref)
 422   (:policy :fast-safe)
 423   (:args (object :scs (descriptor-reg))
 424          (index :scs (any-reg)))
 425   (:arg-types simple-array-complex-single-float positive-fixnum)
 426   (:results (value :scs (complex-single-reg)))
 427   (:temporary (:scs (interior-reg)) lip)
 428   (:result-types complex-single-float)
 429   (:generator 5
 430     (let ((real-tn (complex-single-reg-real-tn value)))
 431       (inst addq object index lip)
 432       (inst addq lip index lip)
 433       (inst lds real-tn
 434             (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 435             lip))
 436     (let ((imag-tn (complex-single-reg-imag-tn value)))
 437       (inst lds imag-tn
 438             (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag)
 439             lip))))
 440
 441 (define-vop (data-vector-set/simple-array-complex-single-float)
 442   (:note "inline array store")
 443   (:translate data-vector-set)
 444   (:policy :fast-safe)
 445   (:args (object :scs (descriptor-reg))
 446          (index :scs (any-reg))
 447          (value :scs (complex-single-reg) :target result))
 448   (:arg-types simple-array-complex-single-float positive-fixnum
 449               complex-single-float)
 450   (:results (result :scs (complex-single-reg)))
 451   (:result-types complex-single-float)
 452   (:temporary (:scs (interior-reg)) lip)
 453   (:generator 5
 454     (let ((value-real (complex-single-reg-real-tn value))
 455           (result-real (complex-single-reg-real-tn result)))
 456       (inst addq object index lip)
 457       (inst addq lip index lip)
 458       (inst sts value-real
 459             (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 460             lip)
 461       (unless (location= result-real value-real)
 462         (inst fmove value-real result-real)))
 463     (let ((value-imag (complex-single-reg-imag-tn value))
 464           (result-imag (complex-single-reg-imag-tn result)))
 465       (inst sts value-imag
 466             (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag)
 467             lip)
 468       (unless (location= result-imag value-imag)
 469         (inst fmove value-imag result-imag)))))
 470
 471 (define-vop (data-vector-ref/simple-array-complex-double-float)
 472   (:note "inline array access")
 473   (:translate data-vector-ref)
 474   (:policy :fast-safe)
 475   (:args (object :scs (descriptor-reg))
 476          (index :scs (any-reg)))
 477   (:arg-types simple-array-complex-double-float positive-fixnum)
 478   (:results (value :scs (complex-double-reg)))
 479   (:result-types complex-double-float)
 480   (:temporary (:scs (interior-reg)) lip)
 481   (:generator 7
 482     (let ((real-tn (complex-double-reg-real-tn value)))
 483       (inst addq object index lip)
 484       (inst addq lip index lip)
 485       (inst addq lip index lip)
 486       (inst addq lip index lip)
 487       (inst ldt real-tn
 488             (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 489             lip))
 490     (let ((imag-tn (complex-double-reg-imag-tn value)))
 491       (inst ldt imag-tn
 492             (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag)
 493             lip))))
 494
 495 (define-vop (data-vector-set/simple-array-complex-double-float)
 496   (:note "inline array store")
 497   (:translate data-vector-set)
 498   (:policy :fast-safe)
 499   (:args (object :scs (descriptor-reg))
 500          (index :scs (any-reg))
 501          (value :scs (complex-double-reg) :target result))
 502   (:arg-types simple-array-complex-double-float positive-fixnum
 503               complex-double-float)
 504   (:results (result :scs (complex-double-reg)))
 505   (:result-types complex-double-float)
 506   (:temporary (:scs (interior-reg)) lip)
 507   (:generator 20
 508     (let ((value-real (complex-double-reg-real-tn value))
 509           (result-real (complex-double-reg-real-tn result)))
 510       (inst addq object index lip)
 511       (inst addq lip index lip)
 512       (inst addq lip index lip)
 513       (inst addq lip index lip)
 514       (inst stt value-real
 515             (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 516             lip)
 517       (unless (location= result-real value-real)
 518         (inst fmove value-real result-real)))
 519     (let ((value-imag (complex-double-reg-imag-tn value))
 520           (result-imag (complex-double-reg-imag-tn result)))
 521       (inst stt value-imag
 522             (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag)
 523             lip)
 524       (unless (location= result-imag value-imag)
 525         (inst fmove value-imag result-imag)))))
 526
 527 \f
 528 ;;; These vops are useful for accessing the bits of a vector irrespective of
 529 ;;; what type of vector it is.
 530 ;;;
 531 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num
 532   %raw-bits)
 533 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
 534   unsigned-num %set-raw-bits)
 535 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
 536   (unsigned-reg) unsigned-num %vector-raw-bits)
 537 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
 538   (unsigned-reg) unsigned-num %set-vector-raw-bits)
 539
 540 \f
 541 ;;;; misc. array VOPs
 542
 543 (define-vop (get-vector-subtype get-header-data))
 544 (define-vop (set-vector-subtype set-header-data))