src/compiler/hppa/array.lisp

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