1 ;;;; the HPPA definitions for array operations
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 ;;;; Allocator for the array header.
15 (define-vop (make-array-header)
16 (:translate make-array-header)
18 (:args (type :scs (any-reg))
19 (rank :scs (any-reg)))
20 (:arg-types positive-fixnum positive-fixnum)
21 (:temporary (:scs (any-reg)) bytes)
22 (:temporary (:scs (non-descriptor-reg)) header)
23 (:results (result :scs (descriptor-reg)))
25 ;; Note: Cant use addi, the immediate is too large
26 (inst li (+ (* (1+ array-dimensions-offset) n-word-bytes)
28 (inst add header rank bytes)
29 (inst li (lognot lowtag-mask) header)
30 (inst and bytes header bytes)
31 (inst addi (fixnumize (1- array-dimensions-offset)) rank header)
32 (inst sll header n-widetag-bits header)
33 (inst or header type header)
34 (inst srl header n-fixnum-tag-bits header)
36 (set-lowtag other-pointer-lowtag alloc-tn result)
37 (storew header result 0 other-pointer-lowtag)
38 (inst add bytes alloc-tn alloc-tn))))
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)
46 (define-full-setter %set-array-dimension *
47 array-dimensions-offset other-pointer-lowtag
48 (any-reg) positive-fixnum sb!kernel:%set-array-dimension)
50 (define-vop (array-rank-vop)
51 (:translate sb!kernel:%array-rank)
53 (:args (x :scs (descriptor-reg)))
54 (:results (res :scs (any-reg descriptor-reg)))
56 (loadw res x 0 other-pointer-lowtag)
57 (inst sra res n-widetag-bits res)
58 (inst addi (- (1- array-dimensions-offset)) res res)
59 (inst sll res n-fixnum-tag-bits res)))
61 ;;;; Bounds checking routine.
62 (define-vop (check-bound)
63 (:translate %check-bound)
65 (:args (array :scs (descriptor-reg))
66 (bound :scs (any-reg descriptor-reg))
67 (index :scs (any-reg descriptor-reg) :target result))
68 (:results (result :scs (any-reg descriptor-reg)))
70 (:save-p :compute-only)
72 (let ((error (generate-error-code vop invalid-array-index-error
74 (inst bc :>= nil index bound error))
78 ;;;; Accessors/Setters
80 ;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
81 ;;; elements are represented in integer registers and are built out of
82 ;;; 8, 16, or 32 bit elements.
83 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
85 (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
86 vector-data-offset other-pointer-lowtag
87 ,(remove-if (lambda (x) (member x '(null zero))) scs)
90 (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
91 vector-data-offset other-pointer-lowtag ,scs ,element-type
94 (def-partial-data-vector-frobs
95 (type element-type size signed &rest scs)
97 (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
98 ,size ,signed vector-data-offset other-pointer-lowtag ,scs
99 ,element-type data-vector-ref)
100 (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
101 ,size vector-data-offset other-pointer-lowtag ,scs
102 ,element-type data-vector-set))))
104 (def-full-data-vector-frobs simple-vector *
105 descriptor-reg any-reg null zero)
107 (def-partial-data-vector-frobs simple-base-string character
108 :byte nil character-reg)
110 (def-full-data-vector-frobs simple-character-string character character-reg)
112 (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
113 :byte nil unsigned-reg signed-reg)
114 (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
115 :byte nil unsigned-reg signed-reg)
117 (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
118 :short nil unsigned-reg signed-reg)
119 (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
120 :short nil unsigned-reg signed-reg)
122 (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
124 (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
127 (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
130 (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
133 (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum
135 (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num
138 (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
141 ;;; Integer vectors whose elements are smaller than a byte. I.e. bit, 2-bit,
142 ;;; and 4-bit vectors.
143 (macrolet ((def-small-data-vector-frobs (type bits)
144 (let* ((elements-per-word (floor n-word-bits bits))
145 (bit-shift (1- (integer-length elements-per-word))))
147 (define-vop (,(symbolicate 'data-vector-ref/ type))
148 (:translate data-vector-ref)
149 (:note "inline array access")
151 (:args (object :scs (descriptor-reg))
152 (index :scs (unsigned-reg)))
153 (:arg-types ,type positive-fixnum)
154 (:results (result :scs (any-reg)))
155 (:result-types positive-fixnum)
156 (:temporary (:scs (interior-reg)) lip)
157 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
159 (inst srl index ,bit-shift temp)
160 (inst sh2add temp object lip)
161 (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
163 `((inst addi ,(1- bits) temp temp)))
164 (inst mtctl temp :sar)
165 (loadw result lip vector-data-offset other-pointer-lowtag)
166 (inst extru result :variable ,bits result)
167 (inst sll result n-fixnum-tag-bits result)))
168 (define-vop (,(symbolicate 'data-vector-ref-c/ type))
169 (:translate data-vector-ref)
171 (:args (object :scs (descriptor-reg)))
172 (:arg-types ,type (:constant index))
174 (:results (result :scs (unsigned-reg)))
175 (:result-types positive-fixnum)
176 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
178 (multiple-value-bind (word extra) (floor index ,elements-per-word)
179 (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
180 other-pointer-lowtag)))
181 (cond ((typep offset '(signed-byte 14))
182 (inst ldw offset object result))
184 (inst ldil offset temp)
185 (inst ldw (ldb (byte 11 0) offset) temp result))))
186 (inst extru result (+ (* extra ,bits) ,(1- bits)) ,bits result))))
187 (define-vop (,(symbolicate 'data-vector-set/ type))
188 (:note "inline array store")
189 (:translate data-vector-set)
191 (:args (object :scs (descriptor-reg))
192 (index :scs (unsigned-reg))
193 (value :scs (unsigned-reg zero immediate) :target result))
194 (:arg-types ,type positive-fixnum positive-fixnum)
195 (:results (result :scs (unsigned-reg)))
196 (:result-types positive-fixnum)
197 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
198 (:temporary (:scs (non-descriptor-reg)) old)
199 (:temporary (:scs (interior-reg)) lip)
201 (inst srl index ,bit-shift temp)
202 (inst sh2add temp object lip)
203 (inst zdep index ,(- 32 (integer-length bits)) ,bit-shift temp)
205 `((inst addi ,(1- bits) temp temp)))
206 (inst mtctl temp :sar)
207 (loadw old lip vector-data-offset other-pointer-lowtag)
208 (inst dep (sc-case value (immediate (tn-value value)) (t value))
210 (storew old lip vector-data-offset other-pointer-lowtag)
213 (inst li (tn-value value) result))
215 (move value result)))))
216 (define-vop (,(symbolicate 'data-vector-set-c/ type))
217 (:translate data-vector-set)
219 (:args (object :scs (descriptor-reg))
220 (value :scs (unsigned-reg zero immediate) :target result))
225 (:results (result :scs (unsigned-reg)))
226 (:result-types positive-fixnum)
227 (:temporary (:scs (non-descriptor-reg)) old)
228 (:temporary (:scs (interior-reg)) lip)
230 (multiple-value-bind (word extra) (floor index ,elements-per-word)
231 (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
232 other-pointer-lowtag)))
233 (cond ((typep offset '(signed-byte 14))
234 (inst ldw offset object old))
237 (inst add object lip lip)
238 (inst ldw 0 lip old)))
239 (inst dep (sc-case value
240 (immediate (tn-value value))
242 (+ (* extra ,bits) ,(1- bits))
245 (if (typep offset '(signed-byte 14))
246 (inst stw old offset object)
247 (inst stw old (ldb (byte 11 0) offset) lip)))
250 (inst li (tn-value value) result))
252 (move value result))))))))))
253 (def-small-data-vector-frobs simple-bit-vector 1)
254 (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
255 (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
257 ;;; And the float variants.
259 ((data-vector ((type set cost) &body body)
260 (let* ((typen (case type (single 'single-float)
261 (double 'double-float)
263 (name (symbolicate "DATA-VECTOR-" (if set "SET" "REF")
264 "/SIMPLE-ARRAY-" typen))
265 (reg-type (symbolicate type "-REG")))
267 (:translate ,(symbolicate "DATA-VECTOR-" (if set "SET" "REF")))
268 (:note ,(concatenate 'string "inline array "
269 (if set "store" "access")))
271 (:args (object :scs (descriptor-reg) :to (:argument 1))
272 (index :scs (any-reg) :to (:argument 0) :target offset)
273 ,@(if set `((value :scs (,reg-type) :target result))))
274 (:arg-types ,(symbolicate "SIMPLE-ARRAY-" typen) positive-fixnum
275 ,@(if set `(,typen)))
276 (:results (,(if set 'result 'value) :scs (,reg-type)))
277 (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) offset)
278 (:result-types ,typen)
281 (data-vector (single nil 5)
282 (inst addi (- (* vector-data-offset n-word-bytes)
283 other-pointer-lowtag)
285 (inst fldx offset object value))
286 (data-vector (single t 5)
287 (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
289 (inst fstx value offset object)
290 (unless (location= result value)
291 (inst funop :copy value result)))
292 (data-vector (double nil 7)
293 (inst sll index 1 offset)
294 (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
296 (inst fldx offset object value))
297 (data-vector (double t 7)
298 (inst sll index 1 offset)
299 (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
301 (inst fstx value offset object)
302 (unless (location= result value)
303 (inst funop :copy value result))))
306 ((data-vector ((type set cost) &body body)
307 (let* ((typen (case type (complex-single 'complex-single-float)
308 (complex-double 'complex-double-float)
310 (name (symbolicate "DATA-VECTOR-" (if set "SET" "REF")
311 "/SIMPLE-ARRAY-" typen))
312 (reg-type (symbolicate type "-REG")))
314 (:translate ,(symbolicate "DATA-VECTOR-" (if set "SET" "REF")))
315 (:note ,(concatenate 'string "inline array "
316 (if set "store" "access")))
318 (:args (object :scs (descriptor-reg) :to :result)
319 (index :scs (any-reg))
320 ,@(if set `((value :scs (,reg-type) :target result))))
321 (:arg-types ,(symbolicate "SIMPLE-ARRAY-" typen) positive-fixnum
322 ,@(if set `(,typen)))
323 (:results (,(if set 'result 'value) :scs (,reg-type)))
324 (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
325 (:result-types ,typen)
328 (data-vector (complex-single nil 5)
329 (inst sll index 1 offset)
330 (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
332 (let ((real-tn (complex-single-reg-real-tn value)))
333 (inst fldx offset object real-tn))
334 (let ((imag-tn (complex-single-reg-imag-tn value)))
335 (inst addi n-word-bytes offset offset)
336 (inst fldx offset object imag-tn)))
337 (data-vector (complex-single t 5)
338 (inst sll index 1 offset)
339 (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
341 (let ((value-real (complex-single-reg-real-tn value))
342 (result-real (complex-single-reg-real-tn result)))
343 (inst fstx value-real offset object)
344 (unless (location= result-real value-real)
345 (inst funop :copy value-real result-real)))
346 (let ((value-imag (complex-single-reg-imag-tn value))
347 (result-imag (complex-single-reg-imag-tn result)))
348 (inst addi n-word-bytes offset offset)
349 (inst fstx value-imag offset object)
350 (unless (location= result-imag value-imag)
351 (inst funop :copy value-imag result-imag))))
352 (data-vector (complex-double nil 7)
353 (inst sll index 2 offset)
354 (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
356 (let ((real-tn (complex-double-reg-real-tn value)))
357 (inst fldx offset object real-tn))
358 (let ((imag-tn (complex-double-reg-imag-tn value)))
359 (inst addi (* 2 n-word-bytes) offset offset)
360 (inst fldx offset object imag-tn)))
361 (data-vector (complex-double t 20)
362 (inst sll index 2 offset)
363 (inst addi (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
365 (let ((value-real (complex-double-reg-real-tn value))
366 (result-real (complex-double-reg-real-tn result)))
367 (inst fstx value-real offset object)
368 (unless (location= result-real value-real)
369 (inst funop :copy value-real result-real)))
370 (let ((value-imag (complex-double-reg-imag-tn value))
371 (result-imag (complex-double-reg-imag-tn result)))
372 (inst addi (* 2 n-word-bytes) offset offset)
373 (inst fstx value-imag offset object)
374 (unless (location= result-imag value-imag)
375 (inst funop :copy value-imag result-imag)))))
378 ;;; These vops are useful for accessing the bits of a vector irrespective of
379 ;;; what type of vector it is.
380 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
381 (unsigned-reg) unsigned-num %vector-raw-bits)
382 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
383 (unsigned-reg) unsigned-num %set-vector-raw-bits)
385 ;;;; Misc. Array VOPs.
386 (define-vop (get-vector-subtype get-header-data))
387 (define-vop (set-vector-subtype set-header-data))