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