source: trunk/source/level-0/l0-array.lisp

Last change on this file was 16805, checked in by wws, 3 years ago

Fix SUBTAG-BYTES for x8632, x8664, ppc32, & arm, so
that fasl dump and load work correctly for complex single-float and
double-float vectors.

I did NOT fix the PPC64 case. Somebody with that hardware will have to
do that.

Addresses #1396.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 35.5 KB
Line 
1;;; -*- Mode: Lisp; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
16
17(in-package "CCL")
18
19
20
21
22; Return T if array or vector header, NIL if (simple-array * *), else
23; error.
24
25(defun %array-is-header (array)
26  (if (typep array 'array)
27    (let* ((typecode (typecode array)))
28      (declare (fixnum typecode))
29      (or (= typecode target::subtag-arrayH)
30          (= typecode target::subtag-vectorH)))
31    (report-bad-arg array 'array)))
32
33(defun %set-fill-pointer (vectorh new)
34  (setf (%svref vectorh target::vectorh.logsize-cell) new))
35
36(defun %array-header-subtype (header)
37  (the fixnum 
38    (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref header target::arrayH.flags-cell)))))
39
40(defun array-element-subtype (array)
41  (if (%array-is-header array)
42    (%array-header-subtype array)
43    (typecode array)))
44 
45#+ppc32-target
46(defconstant ppc32::*immheader-array-types*
47  '#(short-float
48     (unsigned-byte 32)
49     (signed-byte 32)
50     fixnum
51     character
52     (unsigned-byte 8)
53     (signed-byte 8)
54     (unsigned-byte 16)
55     (signed-byte 16)
56     double-float
57     (complex single-float)
58     (complex double-float)
59     bit))
60
61#+ppc64-target
62(defconstant ppc64::*immheader-array-types*
63  '#(unused
64     unused
65     unused
66     unused
67     (signed-byte 8)
68     (signed-byte 16)
69     (signed-byte 32)
70     (signed-byte 64)
71     (unsigned-byte 8)
72     (unsigned-byte 16)
73     (unsigned-byte 32)
74     (unsigned-byte 64)
75     unused
76     (complex double-float)
77     short-float
78     fixnum
79     unused
80     unused
81     unused
82     double-float
83     unused
84     unused
85     character
86     (complex single-float)
87     unused
88     unused
89     unused
90     unused
91     unused
92     bit
93     unused
94     unused))
95
96#+x8632-target
97(defconstant x8632::*immheader-array-types*
98  '#(short-float
99     (unsigned-byte 32)
100     (signed-byte 32)
101     fixnum
102     character
103     (unsigned-byte 8)
104     (signed-byte 8)
105     (unsigned-byte 16)
106     (signed-byte 16)
107     double-float
108     (complex single-float)
109     (complex double-float)
110     bit))
111
112#+x8664-target
113(progn
114(defconstant x8664::*immheader-0-array-types*
115  ;; ivector-class-other-bit
116  #(unused
117    unused
118    unused
119    unused
120    unused
121    unused
122    unused
123    unused
124    unused
125    (complex double-float)
126    (signed-byte 16)
127    (unsigned-byte 16)
128    character
129    (signed-byte 8)
130    (unsigned-byte 8)
131    bit
132    ))
133
134(defconstant x8664::*immheader-1-array-types*
135    ;; ivector-class-32-bit
136  #(
137    unused
138    unused
139    unused
140    unused
141    unused
142    unused
143    unused
144    unused
145    unused
146    unused
147    unused
148    unused
149    character
150    (signed-byte 32)
151    (unsigned-byte 32)
152    single-float))
153
154(defconstant x8664::*immheader-2-array-types*
155  ;; ivector-class-64-bit
156  #(
157    unused
158    unused
159    unused
160    unused
161    unused
162    unused
163    unused
164    unused
165    unused
166    unused
167    unused
168    (complex single-float)
169    fixnum
170    (signed-byte 64)
171    (unsigned-byte 64)
172    double-float))
173   
174)
175
176#+arm-target
177(defconstant arm::*immheader-array-types*
178  '#(short-float
179     (unsigned-byte 32)
180     (signed-byte 32)
181     fixnum
182     character
183     (unsigned-byte 8)
184     (signed-byte 8)
185     (unsigned-byte 16)
186     (signed-byte 16)
187     double-float
188     (complex single-float)
189     (complex double-float)
190     bit))
191
192
193(defun array-element-type (array)
194  "Return the type of the elements of the array"
195  (let* ((subtag (if (%array-is-header array)
196                   (%array-header-subtype array)
197                   (typecode array))))
198    (declare (fixnum subtag))
199    (if (= subtag target::subtag-simple-vector)
200      t                                 ; only node CL array type
201      #+ppc-target
202      (svref target::*immheader-array-types*
203             #+ppc32-target
204             (ash (the fixnum (- subtag ppc32::min-cl-ivector-subtag)) -3)
205             #+ppc64-target
206             (ash (the fixnum (logand subtag #x7f)) (- ppc64::nlowtagbits)))
207      #+x8632-target
208      (svref x8632::*immheader-array-types*
209             (ash (the fixnum (- subtag x8632::min-cl-ivector-subtag))
210                  (- x8632::ntagbits)))
211      #+x8664-target
212      (let* ((class (logand subtag x8664::fulltagmask))
213             (idx (ash subtag (- x8664::ntagbits))))
214        (declare (fixnum class idx))
215        (cond ((= class x8664::ivector-class-64-bit)
216               (%svref x8664::*immheader-2-array-types* idx))
217              ((= class x8664::ivector-class-32-bit)
218               (%svref x8664::*immheader-1-array-types* idx))
219              (t
220               (%svref x8664::*immheader-0-array-types* idx))))
221      #+arm-target
222      (svref arm::*immheader-array-types*
223             (ash (the fixnum (- subtag arm::min-cl-ivector-subtag)) -3))
224      )))
225
226
227
228(defun adjustable-array-p (array)
229  "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
230   to the argument, this happens for complex arrays."
231  (let* ((typecode (typecode array)))
232    (declare (fixnum typecode))
233    (if (or (>= (the (unsigned-byte 8) (gvector-typecode-p typecode))
234                target::subtag-arrayH)
235            (>= (the (unsigned-byte 8) (ivector-typecode-p typecode))
236                target::min-cl-ivector-subtag))
237      (if (or (= typecode target::subtag-arrayH)
238              (= typecode target::subtag-vectorH))
239        (logbitp $arh_adjp_bit (the fixnum (%svref array target::arrayH.flags-cell))))
240      (report-bad-arg array 'array))))
241
242(defun array-displacement (array)
243  "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
244   options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
245  (let* ((typecode (typecode array)))
246    (declare (fixnum typecode))
247    (if (and (or (= typecode target::subtag-arrayH)
248                 (= typecode target::subtag-vectorH))
249             (logbitp $arh_exp_disp_bit
250                      (the fixnum (%svref array target::arrayH.flags-cell))))
251      (values (%svref array target::arrayH.data-vector-cell)
252              (%svref array target::arrayH.displacement-cell))
253      (if (array-typecode-p typecode)
254        (values nil 0)
255        (report-bad-arg array 'array)))))
256
257(defun array-data-and-offset (array)
258  (let* ((typecode (typecode array)))
259    (declare (fixnum typecode))
260    (if (or (= typecode target::subtag-arrayH)
261            (= typecode target::subtag-vectorH))
262      (%array-header-data-and-offset array)
263      (if (or (= typecode target::subtag-simple-vector)
264              (>= (the (unsigned-byte 8) (ivector-typecode-p typecode))
265                  target::min-cl-ivector-subtag))
266        (values array 0)
267        (report-bad-arg array 'array)))))
268
269(defun array-data-offset-subtype (array)
270  (let* ((typecode (typecode array)))
271    (declare (fixnum typecode))
272    (if (or (= typecode target::subtag-vectorH)
273            (= typecode target::subtag-arrayH))
274      (do* ((header array data)
275            (offset (%svref header target::arrayH.displacement-cell)
276                    (+ offset 
277                       (the fixnum 
278                         (%svref header target::arrayH.displacement-cell))))
279            (data (%svref header target::arrayH.data-vector-cell)
280                  (%svref header target::arrayH.data-vector-cell)))
281           ((> (the fixnum (typecode data)) target::subtag-vectorH)
282            (values data offset (typecode data)))
283        (declare (fixnum offset)))
284      (if (or (= typecode target::subtag-simple-vector)
285              (>= (the (unsigned-byte 8) (ivector-typecode-p typecode))
286                  target::min-cl-ivector-subtag))
287        (values array 0 typecode)
288        (report-bad-arg array 'array)))))
289 
290
291(defun array-has-fill-pointer-p (array)
292  "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
293  (let* ((typecode (typecode array)))
294    (declare (fixnum typecode))
295    (if (= typecode target::subtag-vectorH)
296      (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell)))
297      (unless (array-typecode-p typecode)
298        (report-bad-arg array 'array)))))
299
300
301(defun fill-pointer (array)
302  "Return the FILL-POINTER of the given VECTOR."
303  (let* ((typecode (typecode array)))
304    (declare (fixnum typecode))
305    (if (and (= typecode target::subtag-vectorH)
306             (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell))))
307      (%svref array target::vectorH.logsize-cell)
308      (report-bad-arg array '(and array (satisfies array-has-fill-pointer-p))))))
309
310(defun set-fill-pointer (array value)
311  (let* ((typecode (typecode array)))
312    (declare (fixnum typecode))
313    (if (and (= typecode target::subtag-vectorH)
314             (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell))))
315      (let* ((vlen (%svref array target::vectorH.physsize-cell)))
316        (declare (fixnum vlen))
317        (if (eq value t)
318          (setq value vlen)
319          (unless (and (fixnump value)
320                     (>= (the fixnum value) 0)
321                     (<= (the fixnum value) vlen))
322            (%err-disp $XARROOB value array)))
323        (setf (%svref array target::vectorH.logsize-cell) value))
324      (%err-disp $XNOFILLPTR array))))
325
326(eval-when (:compile-toplevel)
327  (assert (eql target::vectorH.physsize-cell target::arrayH.physsize-cell)))
328
329(defun array-total-size (array)
330  "Return the total number of elements in the Array."
331  (let* ((typecode (typecode array)))
332    (declare (fixnum typecode))
333    (if (or (= typecode target::subtag-arrayH)
334              (= typecode target::subtag-vectorH))
335        (%svref array target::vectorH.physsize-cell)
336      (if (or (= typecode target::subtag-simple-vector)
337            (>= (the (unsigned-byte 8) (ivector-typecode-p typecode))
338                target::min-cl-ivector-subtag))
339        (uvsize array)
340        (report-bad-arg array 'array)))))
341
342     
343
344(defun array-dimension (array axis-number)
345  "Return the length of dimension AXIS-NUMBER of ARRAY."
346  (unless (typep axis-number 'fixnum) (report-bad-arg axis-number 'fixnum))
347  (locally
348    (declare (fixnum axis-number))
349    (let* ((typecode (typecode array)))
350      (declare (fixnum typecode))
351      (if (array-typecode-p typecode)
352        (if (= typecode target::subtag-arrayH)
353          (let* ((rank (%svref array target::arrayH.rank-cell)))
354            (declare (fixnum rank))
355            (unless (and (>= axis-number 0)
356                         (< axis-number rank))
357              (%err-disp $XNDIMS array axis-number))
358            (%svref array (the fixnum (+ target::arrayH.dim0-cell axis-number))))
359          (if (neq axis-number 0)
360            (%err-disp $XNDIMS array axis-number)
361            (if (= typecode target::subtag-vectorH)
362              (%svref array target::vectorH.physsize-cell)
363              (uvsize array))))
364        (report-bad-arg array 'array)))))
365
366(defun array-dimensions (array)
367  "Return a list whose elements are the dimensions of the array"
368  (let* ((typecode (typecode array)))
369    (declare (fixnum typecode))
370    (if (array-typecode-p typecode)
371      (if (= typecode target::subtag-arrayH)
372        (let* ((rank (%svref array target::arrayH.rank-cell))
373               (dims ()))
374          (declare (fixnum rank))       
375          (do* ((i (1- rank) (1- i)))
376               ((< i 0) dims)
377            (declare (fixnum i))
378            (push (%svref array (the fixnum (+ target::arrayH.dim0-cell i))) dims)))
379        (list (if (= typecode target::subtag-vectorH)
380                (%svref array target::vectorH.physsize-cell)
381                (uvsize array))))
382      (report-bad-arg array 'array))))
383
384
385(defun array-rank (array)
386  "Return the number of dimensions of ARRAY."
387  (let* ((typecode (typecode array)))
388    (declare (fixnum typecode))
389    (if (array-typecode-p typecode)
390      (if (= typecode target::subtag-arrayH)
391        (%svref array target::arrayH.rank-cell)
392        1)
393      (report-bad-arg array 'array))))
394
395(defun vector-push (elt vector)
396  "Attempt to set the element of ARRAY designated by its fill pointer
397   to NEW-EL, and increment the fill pointer by one. If the fill pointer is
398   too large, NIL is returned, otherwise the index of the pushed element is
399   returned."
400  (let* ((fill (fill-pointer vector))
401         (len (%svref vector target::vectorH.physsize-cell)))
402    (declare (fixnum fill len))
403    (when (< fill len)
404      (multiple-value-bind (data offset) (%array-header-data-and-offset vector)
405        (declare (fixnum offset))
406        (setf (%svref vector target::vectorH.logsize-cell) (the fixnum (1+ fill))
407              (uvref data (the fixnum (+ fill offset))) elt)
408        fill))))
409
410;;; Implement some of the guts of REPLACE, where the source and target
411;;; sequence have the same type (and we might be able to BLT things
412;;; around more quickly because of that.)
413;;; Both TARGET and SOURCE are (SIMPLE-ARRAY (*) *), and all of the
414;;; indices are fixnums and in bounds.
415;;; (Actually, we allow some internal uvector types as well as CL vectors.)
416(defun %uvector-replace (target target-start source source-start n typecode)
417  (declare (fixnum target-start n source-start n typecode)
418           (optimize (speed 3) (safety 0)))
419  (if (gvectorp target)
420    (if (and (eq source target)
421             (> target-start source-start))
422      (do* ((i 0 (1+ i))
423            (source-pos (1- (the fixnum (+ source-start n)))
424                        (1- source-pos))
425            (target-pos (1- (the fixnum (+ target-start n)))
426                        (1- target-pos)))
427           ((= i n))
428        (declare (fixnum i source-pos target-pos))
429        (setf (%svref target target-pos) (%svref source source-pos)))
430      (dotimes (i n)
431        (setf (%svref target target-start) (%svref source source-start))
432        (incf target-start)
433        (incf source-start)))
434    (ecase typecode
435      (#.target::subtag-bit-vector
436       (if (and (eq source target)
437                (> target-start source-start))
438         (do* ((i 0 (1+ i))
439               (source-pos (1- (the fixnum (+ source-start n)))
440                           (1- source-pos))
441               (target-pos (1- (the fixnum (+ target-start n)))
442                           (1- target-pos)))
443              ((= i n))
444           (declare (fixnum i source-pos target-pos))
445           (setf (sbit target target-pos) (sbit source source-pos)))
446         (dotimes (i n)
447           (setf (sbit target target-start) (sbit source source-start))
448           (incf target-start)
449           (incf source-start))))
450      ;; All other cases can be handled with %COPY-IVECTOR-TO-IVECTOR,
451      ;; which knows how to handle overlap
452      ((#.target::subtag-s8-vector
453        #.target::subtag-u8-vector)
454       (%copy-ivector-to-ivector source
455                                 source-start
456                                 target
457                                 target-start
458                                 n))
459      ((#.target::subtag-s16-vector
460        #.target::subtag-u16-vector)
461       (%copy-ivector-to-ivector source
462                                 (the fixnum (* source-start 2))
463                                 target
464                                 (the fixnum (* target-start 2))
465                                 (the fixnum (* n 2))))
466      ((#.target::subtag-s32-vector
467        #.target::subtag-u32-vector
468        #.target::subtag-single-float-vector
469        #.target::subtag-simple-base-string
470        #.target::subtag-bignum
471        #.target::subtag-single-float
472        #.target::subtag-double-float
473        #+32-bit-target #.target::subtag-fixnum-vector)
474       (%copy-ivector-to-ivector source
475                                 (the fixnum (* source-start 4))
476                                 target
477                                 (the fixnum (* target-start 4))
478                                 (the fixnum (* n 4))))
479      ((#.target::subtag-double-float-vector
480        #+64-bit-target #.target::subtag-s64-vector
481        #+64-bit-target #.target::subtag-u64-vector
482        #+64-bit-target #.target::subtag-fixnum-vector
483        #.target::subtag-complex-single-float-vector)
484       (%copy-ivector-to-ivector source
485                                 (the fixnum
486                                   (+ (the fixnum (- target::misc-dfloat-offset
487                                                     target::misc-data-offset))
488                                      (the fixnum (* source-start 8))))
489                                 target
490                                 (the fixnum
491                                   (+ (the fixnum (- target::misc-dfloat-offset
492                                                     target::misc-data-offset))
493                                      (the fixnum (* target-start 8))))
494                                 (the fixnum (* n 8))))
495      (#.target::subtag-complex-double-float-vector
496        (%copy-ivector-to-ivector source
497                                 (the fixnum
498                                   (+ (the fixnum (- target::misc-dfloat-offset
499                                                     target::misc-data-offset))
500                                      (the fixnum (* source-start 16))))
501                                 target
502                                 (the fixnum
503                                   (+ (the fixnum (- target::misc-dfloat-offset
504                                                     target::misc-data-offset))
505                                      (the fixnum (* target-start 16))))
506                                 (the fixnum (* n 16))))))
507  target)
508
509(defun vector-push-extend (elt vector &optional (extension nil extp))
510  "Attempt to set the element of VECTOR designated by its fill pointer
511to ELT, and increment the fill pointer by one. If the fill pointer is
512too large, VECTOR is extended using adjust-array.  EXTENSION is the
513minimum number of elements to add if it must be extended."
514  (when extp
515    (unless (and (typep extension 'fixnum)
516                 (> (the fixnum extension) 0))
517      (setq extension (require-type extension 'unsigned-byte))))
518  (let* ((fill (fill-pointer vector))
519         (len (%svref vector target::vectorH.physsize-cell)))
520    (declare (fixnum fill len))
521    (multiple-value-bind (data offset) (%array-header-data-and-offset vector)
522      (declare (fixnum offset))
523      (if (= fill len)
524        (let* ((flags (%svref vector target::arrayH.flags-cell)))
525          (declare (fixnum flags))
526          (unless (logbitp $arh_adjp_bit flags)
527            (%err-disp $XMALADJUST vector))
528          (let* ((new-size (max
529                            (+ len (the fixnum (or extension
530                                                  len)))
531                            4))
532                 (typecode (typecode data))
533                 (new-vector (%alloc-misc new-size typecode)))
534            (%uvector-replace new-vector 0 data offset fill typecode)
535            (setf (%svref vector target::vectorH.data-vector-cell) new-vector
536                  (%svref vector target::vectorH.displacement-cell) 0
537                  (%svref vector target::vectorH.physsize-cell) new-size
538                  (%svref vector target::vectorH.flags-cell) (bitclr $arh_exp_disp_bit flags)
539                  (uvref new-vector fill) elt)))
540        (setf (uvref data (the fixnum (+ offset fill))) elt))
541      (setf (%svref vector target::vectorH.logsize-cell) (the fixnum (1+ fill))))
542    fill))
543
544;;; Could avoid potential memoization somehow
545(defun vector (&lexpr vals)
546  "Construct a SIMPLE-VECTOR from the given objects."
547  (let* ((n (%lexpr-count vals))
548         (v (allocate-typed-vector :simple-vector n)))
549    (declare (fixnum n))
550    (dotimes (i n v) (setf (%svref v i) (%lexpr-ref vals n i)))))
551
552;;; CALL-ARGUMENTS-LIMIT.
553(defun list-to-vector (elts)
554  (let* ((n (length elts)))
555    (declare (fixnum n))
556    (if (< n (floor #x8000 target::node-size))
557      (apply #'vector elts)
558      (make-array n :initial-contents elts))))
559
560             
561   
562(defun %gvector (subtag &lexpr vals)
563  (let* ((n (%lexpr-count vals))
564         (v (%alloc-misc n subtag)))
565    (declare (fixnum n))
566    (dotimes (i n v) (setf (%svref v i) (%lexpr-ref vals n i)))))
567
568(defun %aref1 (v i)
569  (let* ((typecode (typecode v)))
570    (declare (type (unsigned-byte 8)  typecode))
571    (if (or (= typecode target::subtag-simple-vector)
572            (>= (the (unsigned-byte 8) (ivector-typecode-p typecode))
573                target::min-cl-ivector-subtag))
574      (uvref v i)
575      (if (= typecode target::subtag-vectorH)
576        (multiple-value-bind (data offset)
577                             (%array-header-data-and-offset v)
578          (unless (typep i 'fixnum)
579            (report-bad-arg i 'fixnum))
580          (unless (and (typep i 'fixnum)
581                       (>= (the fixnum i) 0)
582                       (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell))))
583            (if (not (typep i 'fixnum))
584              (report-bad-arg i 'fixnum)
585              (%err-disp $XARROOB i v)))
586          (uvref data (+ offset i)))
587        (if (= typecode target::subtag-arrayH)
588          (%err-disp $XNDIMS v 1)
589          (report-bad-arg v 'array))))))
590
591(defun %aset1 (v i new)
592  (let* ((typecode (typecode v)))
593    (declare (type (unsigned-byte 8) typecode))
594    (if (or (= typecode target::subtag-simple-vector)
595            (>= (the (unsigned-byte 8) (ivector-typecode-p typecode))
596                target::min-cl-ivector-subtag))
597      (setf (uvref v i) new)
598      (if (= typecode target::subtag-vectorH)
599        (multiple-value-bind (data offset)
600                             (%array-header-data-and-offset v)
601          (unless (and (typep i 'fixnum)
602                       (>= (the fixnum i) 0)
603                       (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell))))
604            (if (not (typep i 'fixnum))
605              (report-bad-arg i 'fixnum)
606              (%err-disp $XARROOB i v)))
607          (setf (uvref data (+ offset i)) new))
608        (if (= typecode target::subtag-arrayH)
609          (%err-disp $XNDIMS v 1)
610          (report-bad-arg v 'array))))))
611
612;;; Validate the N indices in the lexpr L against the
613;;; array-dimensions of L.  If anything's out-of-bounds,
614;;; error out (unless NO-ERROR is true, in which case
615;;; return NIL.)
616;;; If everything's OK, return the "row-major-index" of the array.
617;;; We know that A's an array-header of rank N.
618
619(defun %array-index (a l n &optional no-error)
620  (declare (fixnum n))
621  (let* ((count (%lexpr-count l)))
622    (declare (fixnum count))
623    (do* ((axis (1- n) (1- axis))
624          (chunk-size 1)
625          (result 0))
626         ((< axis 0) result)
627      (declare (fixnum result axis chunk-size))
628      (let* ((index (%lexpr-ref l count axis))
629             (dim (%svref a (the fixnum (+ target::arrayH.dim0-cell axis)))))
630        (declare (fixnum dim))
631        (unless (and (typep index 'fixnum)
632                     (>= (the fixnum index) 0)
633                     (< (the fixnum index) dim))
634          (if no-error
635            (return-from %array-index nil)
636            (error "Index value ~d is out of bounds for axis ~d of ~s."
637                   index axis a)))
638        (incf result (the fixnum (* chunk-size (the fixnum index))))
639        (setq chunk-size (* chunk-size dim))))))
640
641(defun aref (a &lexpr subs)
642  "Return the element of the ARRAY specified by the SUBSCRIPTS."
643  (let* ((n (%lexpr-count subs)))
644    (declare (fixnum n))
645    (if (= n 1)
646      (%aref1 a (%lexpr-ref subs n 0))
647      (if (= n 2)
648        (%aref2 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1))
649        (if (= n 3)
650          (%aref3 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1) (%lexpr-ref subs n 2))
651          (let* ((typecode (typecode a)))
652            (declare (fixnum typecode))
653            (if (or (>= (the (unsigned-byte 8) (gvector-typecode-p typecode))
654                        target::subtag-vectorH)
655                    (>= (the (unsigned-byte 8) (ivector-typecode-p typecode))
656                        target::min-cl-ivector-subtag))
657              (%err-disp $XNDIMS a n)
658              (if (/= typecode target::subtag-arrayH)
659                (report-bad-arg a 'array)
660                ;;  This typecode is Just Right ...
661                (progn
662                  (unless (= (the fixnum (%svref a target::arrayH.rank-cell)) n)
663                    (%err-disp $XNDIMS a n))
664                  (let* ((rmi (%array-index a subs n)))
665                    (declare (fixnum rmi))
666                    (multiple-value-bind (data offset) (%array-header-data-and-offset a)
667                      (declare (fixnum offset))
668                      (uvref data (the fixnum (+ offset rmi))))))))))))))
669
670
671
672
673
674(defun aset (a &lexpr subs&val)
675  (let* ((count (%lexpr-count subs&val))
676         (nsubs (1- count)))
677    (declare (fixnum nsubs count))
678    (if (eql count 0)
679      (%err-disp $xneinps)
680      (let* ((val (%lexpr-ref subs&val count nsubs)))
681        (if (= nsubs 1)
682          (%aset1 a (%lexpr-ref subs&val count 0) val)
683          (if (= nsubs 2)
684            (%aset2 a (%lexpr-ref subs&val count 0) (%lexpr-ref subs&val count 1) val)
685            (if (= nsubs 3)
686              (%aset3 a (%lexpr-ref subs&val count 0) (%lexpr-ref subs&val count 1) (%lexpr-ref subs&val count 2) val)
687              (let* ((typecode (typecode a)))
688                (declare (fixnum typecode))
689                (if (or (>= (the (unsigned-byte 8) (gvector-typecode-p typecode))
690                        target::subtag-vectorH)
691                    (>= (the (unsigned-byte 8) (ivector-typecode-p typecode))
692                        target::min-cl-ivector-subtag))
693                  (%err-disp $XNDIMS a nsubs)
694                  (if (/= typecode target::subtag-arrayH)
695                    (report-bad-arg a 'array)
696                    ;;  This typecode is Just Right ...
697                    (progn
698                      (unless (= (the fixnum (%svref a target::arrayH.rank-cell)) nsubs)
699                        (%err-disp $XNDIMS a nsubs))
700                      (let* ((rmi (%array-index a subs&val nsubs)))
701                        (declare (fixnum rmi))
702                        (multiple-value-bind (data offset) (%array-header-data-and-offset a)
703                          (setf (uvref data (the fixnum (+ offset rmi))) val))))))))))))))
704
705
706(defun schar (s i)
707  "SCHAR returns the character object at an indexed position in a string
708   just as CHAR does, except the string must be a simple-string."
709  (let* ((typecode (typecode s)))
710    (declare (fixnum typecode))
711    (if (= typecode target::subtag-simple-base-string)
712      (aref (the simple-string s) i)
713      (report-bad-arg s 'simple-string))))
714
715(defun %scharcode (s i)
716  (let* ((typecode (typecode s)))
717    (declare (fixnum typecode))
718    (if (= typecode target::subtag-simple-base-string)
719      (locally (declare (optimize (speed 3) (safety 0)))
720        (aref (the (simple-array (unsigned-byte 32) (*)) s) i))
721      (report-bad-arg s 'simple-string))))
722
723(defun set-schar (s i v)
724  (let* ((typecode (typecode s)))
725    (declare (fixnum typecode))
726    (if (= typecode target::subtag-simple-base-string)
727      (setf (aref (the simple-string s) i) v)
728      (report-bad-arg s 'simple-string))))
729
730(defun %set-scharcode (s i v)
731  (let* ((typecode (typecode s)))
732    (declare (fixnum typecode))
733    (if (= typecode target::subtag-simple-base-string)
734      (locally (declare (optimize (speed 3) (safety 0)))
735        (setf (aref (the simple-string s) i) v))
736      (report-bad-arg s 'simple-string))))
737
738;;; Strings are simple-strings, start & end values are sane.
739(defun %simple-string= (str1 str2 start1 start2 end1 end2)
740  (declare (fixnum start1 start2 end1 end2))
741  (when (= (the fixnum (- end1 start1))
742           (the fixnum (- end2 start2)))
743    (locally (declare (type simple-base-string str1 str2))
744      (do* ((i1 start1 (1+ i1))
745            (i2 start2 (1+ i2)))
746           ((= i1 end1) t)
747        (declare (fixnum i1 i2))
748        (unless (eq (schar str1 i1) (schar str2 i2))
749          (return))))))
750
751(defun copy-uvector (src)
752  (%extend-vector 0 src (uvsize src)))
753
754#+(or ppc32-target arm-target)
755(defun subtag-bytes (subtag element-count)
756  (declare (fixnum subtag element-count))
757  (unless (= #.target::fulltag-immheader (logand subtag #.target::fulltagmask))
758    (error "Not an ivector subtag: ~s" subtag))
759  (let* ((element-bit-shift
760          (if (<= subtag target::max-32-bit-ivector-subtag)
761            5
762            (if (<= subtag target::max-8-bit-ivector-subtag)
763              3
764              (if (<= subtag target::max-16-bit-ivector-subtag)
765                4
766                (if (= subtag target::subtag-double-float-vector)
767                  6
768                  (if (= subtag target::subtag-complex-double-float-vector)
769                      (return-from subtag-bytes
770                        ;; There's a 32-bit pad at the beginning of the vector.
771                        (+ 4 (ash element-count 4)))
772                      (if (= subtag target::subtag-complex-single-float-vector)
773                          (return-from subtag-bytes
774                            ;; There's a 32-bit pad at the beginning of the vector.
775                            (+ 4 (ash element-count 3)))
776                          0)))))))
777         (total-bits (ash element-count element-bit-shift)))
778    (ash (+ 7 total-bits) -3)))
779
780#+ppc64-target
781(defun subtag-bytes (subtag element-count)
782  (declare (fixnum subtag element-count))
783  (unless (= ppc64::lowtag-immheader (logand subtag ppc64::lowtagmask))
784    (error "Not an ivector subtag: ~s" subtag))
785  (let* ((ivector-class (logand subtag ppc64::fulltagmask))
786         (element-bit-shift
787          (if (= ivector-class ppc64::ivector-class-32-bit)
788            5
789            (if (= ivector-class ppc64::ivector-class-8-bit)
790              3
791              (if (= ivector-class ppc64::ivector-class-64-bit)
792                6
793                (if (= subtag ppc64::subtag-bit-vector)
794                  0
795                  4)))))
796         (total-bits (ash element-count element-bit-shift)))
797    (declare (fixnum ivector-class element-bit-shift total-bits))
798    (ash (the fixnum (+ 7 total-bits)) -3)))
799
800#+x8632-target
801(defun subtag-bytes (subtag element-count)
802  (declare (fixnum subtag element-count))
803  (unless (= #.x8632::fulltag-immheader (logand subtag #.x8632::fulltagmask))
804    (error "Not an ivector subtag: ~s" subtag))
805  (let* ((element-bit-shift
806          (if (<= subtag x8632::max-32-bit-ivector-subtag)
807            5
808            (if (<= subtag x8632::max-8-bit-ivector-subtag)
809              3
810              (if (<= subtag x8632::max-16-bit-ivector-subtag)
811                4
812                (if (= subtag x8632::subtag-double-float-vector)
813                  6
814                  (if (= subtag x8632::subtag-complex-double-float-vector)
815                      (return-from subtag-bytes
816                        ;; There's a 32-bit pad at the beginning of the vector.
817                        (+ 4 (ash element-count 4)))
818                      (if (= subtag x8632::subtag-complex-single-float-vector)
819                          (return-from subtag-bytes
820                            ;; There's a 32-bit pad at the beginning of the vector.
821                            (+ 4 (ash element-count 3)))
822                          0)))))))
823         (total-bits (ash element-count element-bit-shift)))
824    (ash (+ 7 total-bits) -3)))
825
826#+x8664-target
827(defun subtag-bytes (subtag element-count)
828  (declare (fixnum subtag element-count))
829  (unless (logbitp (the (mod 16) (logand subtag x8664::fulltagmask))
830                   (logior (ash 1 x8664::fulltag-immheader-0)
831                           (ash 1 x8664::fulltag-immheader-1)
832                           (ash 1 x8664::fulltag-immheader-2)))
833    (error "Not an ivector subtag: ~s" subtag))
834  (let* ((ivector-class (logand subtag x8664::fulltagmask))
835         (element-bit-shift
836          (if (= ivector-class x8664::ivector-class-32-bit)
837            5
838            (if (= ivector-class x8664::ivector-class-64-bit)
839                6
840                (if (= subtag x8664::subtag-bit-vector)
841                  0
842                  (if (= subtag x8664::subtag-complex-double-float-vector)
843                      (return-from subtag-bytes
844                        ;; There's a 64-bit pad at the beginning of the vector.
845                        (+ 8 (ash element-count 4)))
846                      (if (>= subtag x8664::min-8-bit-ivector-subtag)
847                          3
848                          4))))))
849         (total-bits (ash element-count element-bit-shift)))
850    (declare (fixnum ivector-class element-bit-shift total-bits))
851    (ash (the fixnum (+ 7 total-bits)) -3)))
852
853(defun element-type-subtype (type)
854  "Convert element type specifier to internal array subtype code"
855  (ctype-subtype (specifier-type type)))
856
857(defun ctype-subtype (ctype)
858  (typecase ctype
859    (class-ctype
860     (if (or (eq (class-ctype-class ctype) *character-class*)
861             (eq (class-ctype-class ctype) *base-char-class*)
862             (eq (class-ctype-class ctype) *standard-char-class*))
863       target::subtag-simple-base-string
864       target::subtag-simple-vector))
865    (numeric-ctype
866     (if (eq (numeric-ctype-complexp ctype) :complex)
867       (case (numeric-ctype-format ctype)
868         (single-float target::subtag-complex-single-float-vector)
869         (double-float target::subtag-complex-double-float-vector)
870         (t target::subtag-simple-vector))
871       (case (numeric-ctype-class ctype)
872         (integer
873          (let* ((low (numeric-ctype-low ctype))
874                 (high (numeric-ctype-high ctype)))
875            (cond ((or (null low) (null high)) target::subtag-simple-vector)
876                  ((and (>= low 0) (<= high 1)) target::subtag-bit-vector)
877                  ((and (>= low 0) (<= high 255))
878                   target::subtag-u8-vector)
879                  ((and (>= low 0) (<= high 65535))
880                   target::subtag-u16-vector)
881                  ((and (>= low 0) (<= high #xffffffff))
882                   target::subtag-u32-vector)
883                  ((and (>= low -128) (<= high 127)) target::subtag-s8-vector)
884                  ((and (>= low -32768) (<= high 32767)) target::subtag-s16-vector)
885                  #+32-bit-target
886                  ((and (>= low target::target-most-negative-fixnum)
887                        (<= high target::target-most-positive-fixnum))
888                   target::subtag-fixnum-vector)
889                  ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31))))
890                   target::subtag-s32-vector)
891                  #+64-bit-target
892                  ((and (>= low target::target-most-negative-fixnum)
893                        (<= high target::target-most-positive-fixnum))
894                   target::subtag-fixnum-vector)                 
895                  #+64-bit-target
896                  ((and (>= low 0) (<= high (1- (ash 1 64))))
897                   target::subtag-u64-vector)
898                  #+64-bit-target
899                  ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63))))
900                   target::subtag-s64-vector)
901                  (t target::subtag-simple-vector))))
902         (float
903          (case (numeric-ctype-format ctype)
904            ((double-float long-float) target::subtag-double-float-vector)
905            ((single-float short-float) target::subtag-single-float-vector)
906            (t target::subtag-simple-vector)))
907         (t target::subtag-simple-vector))))
908    (named-ctype ; *, T, etc.
909     target::subtag-simple-vector)
910    (t
911     (harder-ctype-subtype ctype))))
912
913(defun %set-simple-array-p (array)
914  (setf (%svref array  target::arrayh.flags-cell)
915        (bitset  $arh_simple_bit (%svref array target::arrayh.flags-cell))))
916
917(defun  %array-header-simple-p (array)
918  (logbitp $arh_simple_bit (%svref array target::arrayh.flags-cell)))
919
920(defun %misc-ref (v i)
921  (%misc-ref v i))
922
923(defun %misc-set (v i new)
924  (%misc-set v i new))
925
926#-ppc-target
927(defun %extend-vector (start oldv newsize)
928  (declare (fixnum start))
929  (let* ((typecode (typecode oldv))
930         (new (%alloc-misc newsize typecode))
931         (oldsize (uvsize oldv)))
932    (declare (fixnum oldsize) (type (unsigned-byte 8) typecode))
933    (%uvector-replace  new start oldv 0 oldsize typecode)))
934
935
936
937; end of l0-array.lisp
Note: See TracBrowser for help on using the repository browser.