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