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