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