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