src/compiler/alpha/array.lisp

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