1.0.29.38: better DESCRIBE
[sbcl.git] / src / compiler / mips / array.lisp
1 ;;;; the MIPS 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   (:policy :fast-safe)
17   (: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 (non-descriptor-reg)) bytes header)
22   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
23   (:results (result :scs (descriptor-reg)))
24   (:generator 13
25     (inst addu bytes rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
26                              lowtag-mask))
27     (inst srl bytes n-lowtag-bits)
28     (inst sll bytes n-lowtag-bits)
29     (inst addu header rank (fixnumize (1- array-dimensions-offset)))
30     (inst sll header n-widetag-bits)
31     (inst or header type)
32     ;; Remove the extraneous fixnum tag bits because TYPE and RANK
33     ;; were fixnums
34     (inst srl header n-fixnum-tag-bits)
35     (pseudo-atomic (pa-flag)
36       (inst or result alloc-tn other-pointer-lowtag)
37       (storew header result 0 other-pointer-lowtag)
38       (inst addu alloc-tn bytes))))
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   (:temporary (:scs (non-descriptor-reg)) temp)
54   (:results (res :scs (any-reg descriptor-reg)))
55   (:generator 6
56     (loadw temp x 0 other-pointer-lowtag)
57     (inst sra temp n-widetag-bits)
58     (inst subu temp (1- array-dimensions-offset))
59     (inst sll res temp n-fixnum-tag-bits)))
60 \f
61 ;;;; Bounds checking routine.
62 (define-vop (check-bound)
63   (:translate %check-bound)
64   (:policy :fast-safe)
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)))
69   (:temporary (:scs (non-descriptor-reg)) temp)
70   (:vop-var vop)
71   (:save-p :compute-only)
72   (:generator 5
73     (let ((error (generate-error-code vop invalid-array-index-error
74                                       array bound index)))
75       (inst sltu temp index bound)
76       (inst beq temp error)
77       (inst nop)
78       (move result index))))
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 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
86   `(progn
87      (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
88        vector-data-offset other-pointer-lowtag
89        ,(remove-if #'(lambda (x) (member x '(null zero))) scs)
90        ,element-type
91        data-vector-ref)
92      (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
93        vector-data-offset other-pointer-lowtag ,scs ,element-type
94        data-vector-set)))
95
96            (def-partial-data-vector-frobs (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 *
106     descriptor-reg any-reg null zero)
107
108   (def-partial-data-vector-frobs simple-base-string character
109     :byte nil character-reg)
110   #!+sb-unicode
111   (def-full-data-vector-frobs simple-character-string character character-reg)
112
113   (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
114     :byte nil unsigned-reg signed-reg)
115   (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
116     :byte nil unsigned-reg signed-reg)
117
118   (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
119     :short nil unsigned-reg signed-reg)
120   (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
121     :short nil unsigned-reg signed-reg)
122
123   (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
124     unsigned-reg)
125   (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
126     unsigned-reg)
127
128   (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
129     :byte t signed-reg)
130
131   (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
132     :short t signed-reg)
133
134   (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum
135     any-reg)
136   (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num
137     any-reg)
138
139   (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
140     signed-reg))
141
142 ;;; Integer vectors whose elements are smaller than a byte.  I.e. bit, 2-bit,
143 ;;; and 4-bit vectors.
144 (macrolet ((def-small-data-vector-frobs (type bits)
145   (let* ((elements-per-word (floor n-word-bits bits))
146          (bit-shift (1- (integer-length elements-per-word))))
147     `(progn
148        (define-vop (,(symbolicate "DATA-VECTOR-REF/" type))
149          (:note "inline array access")
150          (:translate data-vector-ref)
151          (:policy :fast-safe)
152          (:args (object :scs (descriptor-reg))
153                 (index :scs (unsigned-reg)))
154          (:arg-types ,type positive-fixnum)
155          (:results (value :scs (any-reg)))
156          (:result-types positive-fixnum)
157          (:temporary (:scs (interior-reg)) lip)
158          (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
159          (:generator 20
160            (inst srl temp index ,bit-shift)
161            (inst sll temp n-fixnum-tag-bits)
162            (inst addu lip object temp)
163            (inst lw result lip
164                  (- (* vector-data-offset n-word-bytes)
165                     other-pointer-lowtag))
166            (inst and temp index ,(1- elements-per-word))
167            ,@(when (eq *backend-byte-order* :big-endian)
168                `((inst xor temp ,(1- elements-per-word))))
169            ,@(unless (= bits 1)
170                `((inst sll temp ,(1- (integer-length bits)))))
171            (inst srl result temp)
172            (inst and result ,(1- (ash 1 bits)))
173            (inst sll value result n-fixnum-tag-bits)))
174        (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" type))
175          (:translate data-vector-ref)
176          (:policy :fast-safe)
177          (:args (object :scs (descriptor-reg)))
178          (:arg-types ,type
179                      (:constant
180                       (integer 0
181                                ,(1- (* (1+ (- (floor (+ #x7fff
182                                                         other-pointer-lowtag)
183                                                      n-word-bytes)
184                                               vector-data-offset))
185                                        elements-per-word)))))
186          (:info index)
187          (:results (result :scs (unsigned-reg)))
188          (:result-types positive-fixnum)
189          (:generator 15
190            (multiple-value-bind (word extra) (floor index ,elements-per-word)
191              ,@(when (eq *backend-byte-order* :big-endian)
192                  `((setf extra (logxor extra (1- ,elements-per-word)))))
193              (loadw result object (+ word vector-data-offset)
194                     other-pointer-lowtag)
195              (unless (zerop extra)
196                (inst srl result (* extra ,bits)))
197              (unless (= extra ,(1- elements-per-word))
198                (inst and result ,(1- (ash 1 bits)))))))
199        (define-vop (,(symbolicate "DATA-VECTOR-SET/" type))
200          (:note "inline array store")
201          (:translate data-vector-set)
202          (:policy :fast-safe)
203          (:args (object :scs (descriptor-reg))
204                 (index :scs (unsigned-reg) :target shift)
205                 (value :scs (unsigned-reg zero immediate) :target result))
206          (:arg-types ,type positive-fixnum positive-fixnum)
207          (:results (result :scs (unsigned-reg)))
208          (:result-types positive-fixnum)
209          (:temporary (:scs (interior-reg)) lip)
210          (:temporary (:scs (non-descriptor-reg)) temp old)
211          (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
212          (:generator 25
213            (inst srl temp index ,bit-shift)
214            (inst sll temp n-fixnum-tag-bits)
215            (inst addu lip object temp)
216            (inst lw old lip
217                  (- (* vector-data-offset n-word-bytes)
218                     other-pointer-lowtag))
219            (inst and shift index ,(1- elements-per-word))
220            ,@(when (eq *backend-byte-order* :big-endian)
221                `((inst xor shift ,(1- elements-per-word))))
222            ,@(unless (= bits 1)
223                `((inst sll shift ,(1- (integer-length bits)))))
224            (unless (and (sc-is value immediate)
225                         (= (tn-value value) ,(1- (ash 1 bits))))
226              (inst li temp ,(1- (ash 1 bits)))
227              (inst sll temp shift)
228              (inst nor temp temp zero-tn)
229              (inst and old temp))
230            (unless (sc-is value zero)
231              (sc-case value
232                (immediate
233                 (inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
234                (unsigned-reg
235                 (inst and temp value ,(1- (ash 1 bits)))))
236              (inst sll temp shift)
237              (inst or old temp))
238            (inst sw old lip
239                  (- (* vector-data-offset n-word-bytes)
240                     other-pointer-lowtag))
241            (sc-case value
242              (immediate
243               (inst li result (tn-value value)))
244              (zero
245               (move result zero-tn))
246              (unsigned-reg
247               (move result value)))))
248        (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" type))
249          (:translate data-vector-set)
250          (:policy :fast-safe)
251          (:args (object :scs (descriptor-reg))
252                 (value :scs (unsigned-reg zero immediate) :target result))
253          (:arg-types ,type
254                      (:constant
255                       (integer 0
256                                ,(1- (* (1+ (- (floor (+ #x7fff
257                                                         other-pointer-lowtag)
258                                                      n-word-bytes)
259                                               vector-data-offset))
260                                        elements-per-word))))
261                      positive-fixnum)
262          (:info index)
263          (:results (result :scs (unsigned-reg)))
264          (:result-types positive-fixnum)
265          (:temporary (:scs (non-descriptor-reg)) temp old)
266          (:generator 20
267            (multiple-value-bind (word extra) (floor index ,elements-per-word)
268              ,@(when (eq *backend-byte-order* :big-endian)
269                  `((setf extra (logxor extra (1- ,elements-per-word)))))
270              (inst lw old object
271                    (- (* (+ word vector-data-offset) n-word-bytes)
272                       other-pointer-lowtag))
273              (unless (and (sc-is value immediate)
274                           (= (tn-value value) ,(1- (ash 1 bits))))
275                (cond ((= extra ,(1- elements-per-word))
276                       (inst sll old ,bits)
277                       (inst srl old ,bits))
278                      (t
279                       (inst li temp
280                             (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits))))
281                       (inst and old temp))))
282              (sc-case value
283                (zero)
284                (immediate
285                 (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
286                                   (* extra ,bits))))
287                   (cond ((< value #x10000)
288                          (inst or old value))
289                         (t
290                          (inst li temp value)
291                          (inst or old temp)))))
292                (unsigned-reg
293                 (inst sll temp value (* extra ,bits))
294                 (inst or old temp)))
295              (inst sw old object
296                    (- (* (+ word vector-data-offset) n-word-bytes)
297                       other-pointer-lowtag))
298              (sc-case value
299                (immediate
300                 (inst li result (tn-value value)))
301                (zero
302                 (move result zero-tn))
303                (unsigned-reg
304                 (move result value))))))))))
305   (def-small-data-vector-frobs simple-bit-vector 1)
306   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
307   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
308
309 ;;; And the float variants.
310 (define-vop (data-vector-ref/simple-array-single-float)
311   (:note "inline array access")
312   (:translate data-vector-ref)
313   (:policy :fast-safe)
314   (:args (object :scs (descriptor-reg))
315          (index :scs (any-reg)))
316   (:arg-types simple-array-single-float positive-fixnum)
317   (:results (value :scs (single-reg)))
318   (:result-types single-float)
319   (:temporary (:scs (interior-reg)) lip)
320   (:generator 20
321     (inst addu lip object index)
322     (inst lwc1 value lip
323           (- (* vector-data-offset n-word-bytes)
324              other-pointer-lowtag))
325     (inst nop)))
326
327 (define-vop (data-vector-set/simple-array-single-float)
328   (:note "inline array store")
329   (:translate data-vector-set)
330   (:policy :fast-safe)
331   (:args (object :scs (descriptor-reg))
332          (index :scs (any-reg))
333          (value :scs (single-reg) :target result))
334   (:arg-types simple-array-single-float positive-fixnum single-float)
335   (:results (result :scs (single-reg)))
336   (:result-types single-float)
337   (:temporary (:scs (interior-reg)) lip)
338   (:generator 20
339     (inst addu lip object index)
340     (inst swc1 value lip
341           (- (* vector-data-offset n-word-bytes)
342              other-pointer-lowtag))
343     (unless (location= result value)
344       (inst fmove :single result value))))
345
346 (define-vop (data-vector-ref/simple-array-double-float)
347   (:note "inline array access")
348   (:translate data-vector-ref)
349   (:policy :fast-safe)
350   (:args (object :scs (descriptor-reg))
351          (index :scs (any-reg)))
352   (:arg-types simple-array-double-float positive-fixnum)
353   (:results (value :scs (double-reg)))
354   (:result-types double-float)
355   (:temporary (:scs (interior-reg)) lip)
356   (:generator 20
357     (inst addu lip object index)
358     (inst addu lip index)
359     (ecase *backend-byte-order*
360       (:big-endian
361        (inst lwc1 value lip
362              (+ (- (* vector-data-offset n-word-bytes)
363                    other-pointer-lowtag)
364                 n-word-bytes))
365        (inst lwc1-odd value lip
366              (- (* vector-data-offset n-word-bytes)
367                 other-pointer-lowtag)))
368       (:little-endian
369        (inst lwc1 value lip
370              (- (* vector-data-offset n-word-bytes)
371                 other-pointer-lowtag))
372        (inst lwc1-odd value lip
373              (+ (- (* vector-data-offset n-word-bytes)
374                    other-pointer-lowtag)
375                 n-word-bytes))))
376     (inst nop)))
377
378 (define-vop (data-vector-set/simple-array-double-float)
379   (:note "inline array store")
380   (:translate data-vector-set)
381   (:policy :fast-safe)
382   (:args (object :scs (descriptor-reg))
383          (index :scs (any-reg))
384          (value :scs (double-reg) :target result))
385   (:arg-types simple-array-double-float positive-fixnum double-float)
386   (:results (result :scs (double-reg)))
387   (:result-types double-float)
388   (:temporary (:scs (interior-reg)) lip)
389   (:generator 20
390     (inst addu lip object index)
391     (inst addu lip index)
392     (ecase *backend-byte-order*
393       (:big-endian
394        (inst swc1 value lip
395              (+ (- (* vector-data-offset n-word-bytes)
396                    other-pointer-lowtag)
397                 n-word-bytes))
398        (inst swc1-odd value lip
399              (- (* vector-data-offset n-word-bytes)
400                 other-pointer-lowtag)))
401       (:little-endian
402        (inst swc1 value lip
403              (- (* vector-data-offset n-word-bytes)
404                 other-pointer-lowtag))
405        (inst swc1-odd value lip
406              (+ (- (* vector-data-offset n-word-bytes)
407                    other-pointer-lowtag)
408                 n-word-bytes))))
409     (unless (location= result value)
410       (inst fmove :double result value))))
411 \f
412 ;;; Complex float arrays.
413 (define-vop (data-vector-ref/simple-array-complex-single-float)
414   (:note "inline array access")
415   (:translate data-vector-ref)
416   (:policy :fast-safe)
417   (:args (object :scs (descriptor-reg))
418          (index :scs (any-reg)))
419   (:arg-types simple-array-complex-single-float positive-fixnum)
420   (:results (value :scs (complex-single-reg)))
421   (:temporary (:scs (interior-reg)) lip)
422   (:result-types complex-single-float)
423   (:generator 5
424     (inst addu lip object index)
425     (inst addu lip index)
426     (let ((real-tn (complex-single-reg-real-tn value)))
427       (inst lwc1 real-tn lip (- (* vector-data-offset n-word-bytes)
428                                 other-pointer-lowtag)))
429     (let ((imag-tn (complex-single-reg-imag-tn value)))
430       (inst lwc1 imag-tn lip (- (* (1+ vector-data-offset) n-word-bytes)
431                                 other-pointer-lowtag)))
432     (inst nop)))
433
434 (define-vop (data-vector-set/simple-array-complex-single-float)
435   (:note "inline array store")
436   (:translate data-vector-set)
437   (:policy :fast-safe)
438   (:args (object :scs (descriptor-reg))
439          (index :scs (any-reg))
440          (value :scs (complex-single-reg) :target result))
441   (:arg-types simple-array-complex-single-float positive-fixnum
442               complex-single-float)
443   (:results (result :scs (complex-single-reg)))
444   (:result-types complex-single-float)
445   (:temporary (:scs (interior-reg)) lip)
446   (:generator 5
447     (inst addu lip object index)
448     (inst addu lip index)
449     (let ((value-real (complex-single-reg-real-tn value))
450           (result-real (complex-single-reg-real-tn result)))
451       (inst swc1 value-real lip (- (* vector-data-offset n-word-bytes)
452                                    other-pointer-lowtag))
453       (unless (location= result-real value-real)
454         (inst fmove :single result-real value-real)))
455     (let ((value-imag (complex-single-reg-imag-tn value))
456           (result-imag (complex-single-reg-imag-tn result)))
457       (inst swc1 value-imag lip (- (* (1+ vector-data-offset) n-word-bytes)
458                                    other-pointer-lowtag))
459       (unless (location= result-imag value-imag)
460         (inst fmove :single result-imag value-imag)))))
461
462 (define-vop (data-vector-ref/simple-array-complex-double-float)
463   (:note "inline array access")
464   (:translate data-vector-ref)
465   (:policy :fast-safe)
466   (:args (object :scs (descriptor-reg))
467          (index :scs (any-reg) :target shift))
468   (:arg-types simple-array-complex-double-float positive-fixnum)
469   (:results (value :scs (complex-double-reg)))
470   (:result-types complex-double-float)
471   (:temporary (:scs (interior-reg)) lip)
472   (:temporary (:scs (any-reg) :from (:argument 1)) shift)
473   (:generator 6
474     (inst sll shift index n-fixnum-tag-bits)
475     (inst addu lip object shift)
476     (let ((real-tn (complex-double-reg-real-tn value)))
477       (ld-double real-tn lip (- (* vector-data-offset n-word-bytes)
478                                 other-pointer-lowtag)))
479     (let ((imag-tn (complex-double-reg-imag-tn value)))
480       (ld-double imag-tn lip (- (* (+ vector-data-offset 2) n-word-bytes)
481                                 other-pointer-lowtag)))
482     (inst nop)))
483
484 (define-vop (data-vector-set/simple-array-complex-double-float)
485   (:note "inline array store")
486   (:translate data-vector-set)
487   (:policy :fast-safe)
488   (:args (object :scs (descriptor-reg))
489          (index :scs (any-reg) :target shift)
490          (value :scs (complex-double-reg) :target result))
491   (:arg-types simple-array-complex-double-float positive-fixnum
492               complex-double-float)
493   (:results (result :scs (complex-double-reg)))
494   (:result-types complex-double-float)
495   (:temporary (:scs (interior-reg)) lip)
496   (:temporary (:scs (any-reg) :from (:argument 1)) shift)
497   (:generator 6
498     (inst sll shift index n-fixnum-tag-bits)
499     (inst addu lip object shift)
500     (let ((value-real (complex-double-reg-real-tn value))
501           (result-real (complex-double-reg-real-tn result)))
502       (str-double value-real lip (- (* vector-data-offset n-word-bytes)
503                                     other-pointer-lowtag))
504       (unless (location= result-real value-real)
505         (inst fmove :double result-real value-real)))
506     (let ((value-imag (complex-double-reg-imag-tn value))
507           (result-imag (complex-double-reg-imag-tn result)))
508       (str-double value-imag lip (- (* (+ vector-data-offset 2) n-word-bytes)
509                                     other-pointer-lowtag))
510       (unless (location= result-imag value-imag)
511         (inst fmove :double result-imag value-imag)))))
512
513 \f
514 ;;; These vops are useful for accessing the bits of a vector irrespective of
515 ;;; what type of vector it is.
516 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
517   (unsigned-reg) unsigned-num %vector-raw-bits)
518 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
519   (unsigned-reg) unsigned-num %set-vector-raw-bits)
520 \f
521 ;;;; Misc. Array VOPs.
522 (define-vop (get-vector-subtype get-header-data))
523 (define-vop (set-vector-subtype set-header-data))