src/compiler/hppa/array.lisp

   1 (in-package "SB!VM")
   2
   3 \f
   4 ;;;; Allocator for the array header.
   5
   6 (define-vop (make-array-header)
   7   (:translate make-array-header)
   8   (:policy :fast-safe)
   9   (:args (type :scs (any-reg))
  10          (rank :scs (any-reg)))
  11   (:arg-types tagged-num tagged-num)
  12   (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
  13   (:temporary (:scs (non-descriptor-reg) :type random) ndescr)
  14   (:results (result :scs (descriptor-reg)))
  15   (:generator 0
  16     (pseudo-atomic ()
  17       (inst move alloc-tn header)
  18       (inst dep other-pointer-lowtag 31 3 header)
  19       (inst addi (* (1+ array-dimensions-offset) n-word-bytes) rank ndescr)
  20       (inst dep 0 31 3 ndescr)
  21       (inst add alloc-tn ndescr alloc-tn)
  22       (inst addi (fixnumize (1- array-dimensions-offset)) rank ndescr)
  23       (inst sll ndescr n-widetag-bits ndescr)
  24       (inst or ndescr type ndescr)
  25       (inst srl ndescr 2 ndescr)
  26       (storew ndescr header 0 other-pointer-lowtag))
  27     (move header result)))
  28
  29 \f
  30 ;;;; Additional accessors and setters for the array header.
  31
  32 (defknown sb!impl::%array-dimension (t index) index
  33   (flushable))
  34 (defknown sb!impl::%set-array-dimension (t index index) index
  35   ())
  36
  37 (define-full-reffer %array-dimension *
  38   array-dimensions-offset other-pointer-lowtag
  39   (any-reg) positive-fixnum sb!impl::%array-dimension)
  40
  41 (define-full-setter %set-array-dimension *
  42   array-dimensions-offset other-pointer-lowtag
  43   (any-reg) positive-fixnum sb!impl::%set-array-dimension)
  44
  45
  46 (defknown sb!impl::%array-rank (t) index (flushable))
  47
  48 (define-vop (array-rank-vop)
  49   (:translate sb!impl::%array-rank)
  50   (:policy :fast-safe)
  51   (:args (x :scs (descriptor-reg)))
  52   (:results (res :scs (unsigned-reg)))
  53   (:result-types positive-fixnum)
  54   (:generator 6
  55     (loadw res x 0 other-pointer-lowtag)
  56     (inst srl res n-widetag-bits res)
  57     (inst addi (- (1- array-dimensions-offset)) res res)))
  58
  59
  60 \f
  61 ;;;; Bounds checking routine.
  62
  63
  64 (define-vop (check-bound)
  65   (:translate %check-bound)
  66   (:policy :fast-safe)
  67   (:args (array :scs (descriptor-reg))
  68          (bound :scs (any-reg descriptor-reg))
  69          (index :scs (any-reg descriptor-reg) :target result))
  70   (:results (result :scs (any-reg descriptor-reg)))
  71   (:vop-var vop)
  72   (:save-p :compute-only)
  73   (:generator 5
  74     (let ((error (generate-error-code vop invalid-array-index-error
  75                                       array bound index)))
  76       (inst bc :>= nil index bound error))
  77     (move index result)))
  78
  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
  86 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
  87   `(progn
  88      (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
  89        vector-data-offset other-pointer-lowtag ,scs ,element-type
  90        data-vector-ref)
  91      (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
  92        vector-data-offset other-pointer-lowtag ,scs ,element-type
  93        data-vector-set)))
  94
  95            (def-partial-data-vector-frobs
  96                (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 * descriptor-reg any-reg)
 106
 107   (def-partial-data-vector-frobs simple-base-string base-char :byte nil base-char-reg)
 108
 109   (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
 110     :byte nil unsigned-reg signed-reg)
 111   (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
 112     :byte nil unsigned-reg signed-reg)
 113
 114   (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
 115     :short nil unsigned-reg signed-reg)
 116   (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
 117     :short nil unsigned-reg signed-reg)
 118
 119   (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
 120     unsigned-reg)
 121   (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
 122     unsigned-reg)
 123
 124   (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
 125     :byte t signed-reg)
 126
 127   (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
 128     :short t signed-reg)
 129
 130   (def-full-data-vector-frobs simple-array-signed-byte-29 positive-fixnum any-reg)
 131   (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
 132
 133   (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num signed-reg))
 134
 135
 136 ;;; Integer vectors whos elements are smaller than a byte.  I.e. bit, 2-bit,
 137 ;;; and 4-bit vectors.
 138 ;;;
 139
 140 (macrolet ((def-small-data-vector-frobs (type bits)
 141   (let* ((elements-per-word (floor n-word-bits bits))
 142          (bit-shift (1- (integer-length elements-per-word))))
 143     `(progn
 144        (define-vop (,(symbolicate 'data-vector-ref/ type))
 145          (:note "inline array access")
 146          (:translate data-vector-ref)
 147          (:policy :fast-safe)
 148          (:args (object :scs (descriptor-reg))
 149                 (index :scs (unsigned-reg)))
 150          (:arg-types ,type positive-fixnum)
 151          (:results (result :scs (unsigned-reg) :from (:argument 0)))
 152          (:result-types positive-fixnum)
 153          (:temporary (:scs (non-descriptor-reg)) temp)
 154          (:temporary (:scs (interior-reg)) lip)
 155          (:generator 20
 156            (inst srl index ,bit-shift temp)
 157            (inst sh2add temp object lip)
 158            (loadw result lip vector-data-offset other-pointer-lowtag)
 159            (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
 160            ,@(unless (= bits 1)
 161                `((inst addi ,(1- bits) temp temp)))
 162            (inst mtctl temp :sar)
 163            (inst extru result :variable ,bits result)))
 164        (define-vop (,(symbolicate 'data-vector-ref-c/ type))
 165          (:translate data-vector-ref)
 166          (:policy :fast-safe)
 167          (:args (object :scs (descriptor-reg)))
 168          (:arg-types ,type (:constant index))
 169          (:info index)
 170          (:results (result :scs (unsigned-reg)))
 171          (:result-types positive-fixnum)
 172          (:temporary (:scs (non-descriptor-reg)) temp)
 173          (:generator 15
 174            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 175              (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
 176                               other-pointer-lowtag)))
 177                (cond ((typep offset '(signed-byte 14))
 178                       (inst ldw offset object result))
 179                      (t
 180                       (inst ldil (ldb (byte 21 11) offset) temp)
 181                       (inst ldw (ldb (byte 11 0) offset) temp result))))
 182              (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result))))
 183        (define-vop (,(symbolicate 'data-vector-set/ type))
 184          (:note "inline array store")
 185          (:translate data-vector-set)
 186          (:policy :fast-safe)
 187          (:args (object :scs (descriptor-reg))
 188                 (index :scs (unsigned-reg))
 189                 (value :scs (unsigned-reg zero immediate) :target result))
 190          (:arg-types ,type positive-fixnum positive-fixnum)
 191          (:results (result :scs (unsigned-reg)))
 192          (:result-types positive-fixnum)
 193          (:temporary (:scs (non-descriptor-reg)) temp old)
 194          (:temporary (:scs (interior-reg)) lip)
 195          (:generator 25
 196            (inst srl index ,bit-shift temp)
 197            (inst sh2add temp object lip)
 198            (loadw old lip vector-data-offset other-pointer-lowtag)
 199            (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
 200            ,@(unless (= bits 1)
 201                `((inst addi ,(1- bits) temp temp)))
 202            (inst mtctl temp :sar)
 203            (inst dep (sc-case value (immediate (tn-value value)) (t value))
 204                  :variable ,bits old)
 205            (storew old lip vector-data-offset other-pointer-lowtag)
 206            (sc-case value
 207              (immediate
 208               (inst li (tn-value value) result))
 209              (t
 210               (move value result)))))
 211        (define-vop (,(symbolicate 'data-vector-set-c/ type))
 212          (:translate data-vector-set)
 213          (:policy :fast-safe)
 214          (:args (object :scs (descriptor-reg))
 215                 (value :scs (unsigned-reg zero immediate) :target result))
 216          (:arg-types ,type
 217                      (:constant index)
 218                      positive-fixnum)
 219          (:info index)
 220          (:results (result :scs (unsigned-reg)))
 221          (:result-types positive-fixnum)
 222          (:temporary (:scs (non-descriptor-reg)) old)
 223          (:temporary (:scs (interior-reg)) lip)
 224          (:generator 20
 225            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 226              (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
 227                               other-pointer-lowtag)))
 228                (cond ((typep offset '(signed-byte 14))
 229                       (inst ldw offset object old))
 230                      (t
 231                       (inst move object lip)
 232                       (inst addil (ldb (byte 21 11) offset) lip)
 233                       (inst ldw (ldb (byte 11 0) offset) lip old)))
 234                (inst dep (sc-case value
 235                            (immediate (tn-value value))
 236                            (t value))
 237                      (+ (* extra ,bits) ,(1- bits))
 238                      ,bits
 239                      old)
 240                (if (typep offset '(signed-byte 14))
 241                    (inst stw old offset object)
 242                    (inst stw old (ldb (byte 11 0) offset) lip)))
 243              (sc-case value
 244                (immediate
 245                 (inst li (tn-value value) result))
 246                (t
 247                 (move value result))))))))))
 248   (def-small-data-vector-frobs simple-bit-vector 1)
 249   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 250   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 251
 252 ;;; And the float variants.
 253 ;;;
 254
 255 (define-vop (data-vector-ref/simple-array-single-float)
 256   (:note "inline array access")
 257   (:translate data-vector-ref)
 258   (:policy :fast-safe)
 259   (:args (object :scs (descriptor-reg) :to (:argument 1))
 260          (index :scs (any-reg) :to (:argument 0) :target offset))
 261   (:arg-types simple-array-single-float positive-fixnum)
 262   (:results (value :scs (single-reg)))
 263   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
 264   (:result-types single-float)
 265   (:generator 5
 266     (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 267           index offset)
 268     (inst fldx offset object value)))
 269
 270 (define-vop (data-vector-set/simple-array-single-float)
 271   (:note "inline array store")
 272   (:translate data-vector-set)
 273   (:policy :fast-safe)
 274   (:args (object :scs (descriptor-reg) :to (:argument 1))
 275          (index :scs (any-reg) :to (:argument 0) :target offset)
 276          (value :scs (single-reg) :target result))
 277   (:arg-types simple-array-single-float positive-fixnum single-float)
 278   (:results (result :scs (single-reg)))
 279   (:result-types single-float)
 280   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
 281   (:generator 5
 282     (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 283           index offset)
 284     (inst fstx value offset object)
 285     (unless (location= result value)
 286       (inst funop :copy value result))))
 287
 288 (define-vop (data-vector-ref/simple-array-double-float)
 289   (:note "inline array access")
 290   (:translate data-vector-ref)
 291   (:policy :fast-safe)
 292   (:args (object :scs (descriptor-reg) :to (:argument 1))
 293          (index :scs (any-reg) :to (:argument 0) :target offset))
 294   (:arg-types simple-array-double-float positive-fixnum)
 295   (:results (value :scs (double-reg)))
 296   (:result-types double-float)
 297   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
 298   (:generator 7
 299     (inst sll index 1 offset)
 300     (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 301           offset offset)
 302     (inst fldx offset object value)))
 303
 304 (define-vop (data-vector-set/simple-array-double-float)
 305   (:note "inline array store")
 306   (:translate data-vector-set)
 307   (:policy :fast-safe)
 308   (:args (object :scs (descriptor-reg) :to (:argument 1))
 309          (index :scs (any-reg) :to (:argument 0) :target offset)
 310          (value :scs (double-reg) :target result))
 311   (:arg-types simple-array-double-float positive-fixnum double-float)
 312   (:results (result :scs (double-reg)))
 313   (:result-types double-float)
 314   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
 315   (:generator 20
 316     (inst sll index 1 offset)
 317     (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 318           offset offset)
 319     (inst fstx value offset object)
 320     (unless (location= result value)
 321       (inst funop :copy value result))))
 322
 323 \f
 324 ;;; Complex float arrays.
 325
 326 (define-vop (data-vector-ref/simple-array-complex-single-float)
 327   (:note "inline array access")
 328   (:translate data-vector-ref)
 329   (:policy :fast-safe)
 330   (:args (object :scs (descriptor-reg) :to :result)
 331          (index :scs (any-reg)))
 332   (:arg-types simple-array-complex-single-float positive-fixnum)
 333   (:results (value :scs (complex-single-reg)))
 334   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 335   (:result-types complex-single-float)
 336   (:generator 5
 337     (inst sll index 1 offset)
 338     (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 339           offset offset)
 340     (let ((real-tn (complex-single-reg-real-tn value)))
 341       (inst fldx offset object real-tn))
 342     (let ((imag-tn (complex-single-reg-imag-tn value)))
 343       (inst addi n-word-bytes offset offset)
 344       (inst fldx offset object imag-tn))))
 345
 346 (define-vop (data-vector-set/simple-array-complex-single-float)
 347   (:note "inline array store")
 348   (:translate data-vector-set)
 349   (:policy :fast-safe)
 350   (:args (object :scs (descriptor-reg) :to :result)
 351          (index :scs (any-reg))
 352          (value :scs (complex-single-reg) :target result))
 353   (:arg-types simple-array-complex-single-float positive-fixnum
 354               complex-single-float)
 355   (:results (result :scs (complex-single-reg)))
 356   (:result-types complex-single-float)
 357   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 358   (:generator 5
 359     (inst sll index 1 offset)
 360     (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 361           offset offset)
 362     (let ((value-real (complex-single-reg-real-tn value))
 363           (result-real (complex-single-reg-real-tn result)))
 364       (inst fstx value-real offset object)
 365       (unless (location= result-real value-real)
 366         (inst funop :copy value-real result-real)))
 367     (let ((value-imag (complex-single-reg-imag-tn value))
 368           (result-imag (complex-single-reg-imag-tn result)))
 369       (inst addi n-word-bytes offset offset)
 370       (inst fstx value-imag offset object)
 371       (unless (location= result-imag value-imag)
 372         (inst funop :copy value-imag result-imag)))))
 373
 374 (define-vop (data-vector-ref/simple-array-complex-double-float)
 375   (:note "inline array access")
 376   (:translate data-vector-ref)
 377   (:policy :fast-safe)
 378   (:args (object :scs (descriptor-reg) :to :result)
 379          (index :scs (any-reg)))
 380   (:arg-types simple-array-complex-double-float positive-fixnum)
 381   (:results (value :scs (complex-double-reg)))
 382   (:result-types complex-double-float)
 383   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 384   (:generator 7
 385     (inst sll index 2 offset)
 386     (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 387           offset offset)
 388     (let ((real-tn (complex-double-reg-real-tn value)))
 389       (inst fldx offset object real-tn))
 390     (let ((imag-tn (complex-double-reg-imag-tn value)))
 391       (inst addi (* 2 n-word-bytes) offset offset)
 392       (inst fldx offset object imag-tn))))
 393
 394 (define-vop (data-vector-set/simple-array-complex-double-float)
 395   (:note "inline array store")
 396   (:translate data-vector-set)
 397   (:policy :fast-safe)
 398   (:args (object :scs (descriptor-reg) :to :result)
 399          (index :scs (any-reg))
 400          (value :scs (complex-double-reg) :target result))
 401   (:arg-types simple-array-complex-double-float positive-fixnum
 402               complex-double-float)
 403   (:results (result :scs (complex-double-reg)))
 404   (:result-types complex-double-float)
 405   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 406   (:generator 20
 407     (inst sll index 2 offset)
 408     (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
 409           offset offset)
 410     (let ((value-real (complex-double-reg-real-tn value))
 411           (result-real (complex-double-reg-real-tn result)))
 412       (inst fstx value-real offset object)
 413       (unless (location= result-real value-real)
 414         (inst funop :copy value-real result-real)))
 415     (let ((value-imag (complex-double-reg-imag-tn value))
 416           (result-imag (complex-double-reg-imag-tn result)))
 417       (inst addi (* 2 n-word-bytes) offset offset)
 418       (inst fstx value-imag offset object)
 419       (unless (location= result-imag value-imag)
 420         (inst funop :copy value-imag result-imag)))))
 421
 422 \f
 423 ;;; These VOPs are used for implementing float slots in structures (whose raw
 424 ;;; data is an unsigned-32 vector.
 425 ;;;
 426 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
 427   (:translate %raw-ref-single)
 428   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
 429 ;;;
 430 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
 431   (:translate %raw-set-single)
 432   (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
 433 ;;;
 434 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
 435   (:translate %raw-ref-double)
 436   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
 437 ;;;
 438 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
 439   (:translate %raw-set-double)
 440   (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
 441
 442 (define-vop (raw-ref-complex-single
 443              data-vector-ref/simple-array-complex-single-float)
 444   (:translate %raw-ref-complex-single)
 445   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
 446 ;;;
 447 (define-vop (raw-set-complex-single
 448              data-vector-set/simple-array-complex-single-float)
 449   (:translate %raw-set-complex-single)
 450   (:arg-types simple-array-unsigned-byte-32 positive-fixnum
 451               complex-single-float))
 452 ;;;
 453 (define-vop (raw-ref-complex-double
 454              data-vector-ref/simple-array-complex-double-float)
 455   (:translate %raw-ref-complex-double)
 456   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
 457 ;;;
 458 (define-vop (raw-set-complex-double
 459              data-vector-set/simple-array-complex-double-float)
 460   (:translate %raw-set-complex-double)
 461   (:arg-types simple-array-unsigned-byte-32 positive-fixnum
 462               complex-double-float))
 463
 464 ;;; These vops are useful for accessing the bits of a vector irrespective of
 465 ;;; what type of vector it is.
 466 ;;;
 467
 468 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num
 469   %raw-bits)
 470 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
 471   unsigned-num %set-raw-bits)
 472
 473
 474 \f
 475 ;;;; Misc. Array VOPs.
 476
 477 (define-vop (get-vector-subtype get-header-data))
 478 (define-vop (set-vector-subtype set-header-data))
 479