1 ;;;; functions to implement arrays
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
15 (declaim (inline adjustable-array-p
18 ;;;; miscellaneous accessor functions
20 ;;; These functions are only needed by the interpreter, 'cause the
21 ;;; compiler inlines them.
22 (macrolet ((def (name)
26 (defun (setf ,name
) (value array
)
27 (setf (,name array
) value
)))))
28 (def %array-fill-pointer
)
29 (def %array-fill-pointer-p
)
30 (def %array-available-elements
)
32 (def %array-displacement
)
33 (def %array-displaced-p
)
34 (def %array-displaced-from
))
36 ;;; For compatibility: DO NOT USE IN NEW CODE.
37 (defun %array-data-vector
(array) (%array-data array
))
39 (defun %array-rank
(array)
42 (defun %array-dimension
(array axis
)
43 (%array-dimension array axis
))
45 (defun %set-array-dimension
(array axis value
)
46 (%set-array-dimension array axis value
))
48 (defun %check-bound
(array bound index
)
49 (declare (type index bound
)
51 (%check-bound array bound index
))
53 (defun check-bound (array bound index
)
54 (declare (type index bound
)
56 (%check-bound array bound index
)
59 (defun %with-array-data
/fp
(array start end
)
60 (%with-array-data-macro array start end
:check-bounds t
:check-fill-pointer t
))
62 (defun %with-array-data
(array start end
)
63 (%with-array-data-macro array start end
:check-bounds t
:array-header-p t
))
65 (defun %data-vector-and-index
(array index
)
66 (if (array-header-p array
)
67 (multiple-value-bind (vector index
)
68 (%with-array-data array index nil
)
69 (values vector index
))
70 (values (truly-the (simple-array * (*)) array
) index
)))
74 (defun %integer-vector-widetag-and-n-bits-shift
(signed high
)
76 #.
(let ((map (make-array (1+ sb
!vm
:n-word-bits
))))
77 (loop for saetp across
78 (reverse sb
!vm
:*specialized-array-element-type-properties
*)
79 for ctype
= (sb!vm
:saetp-ctype saetp
)
80 when
(and (numeric-type-p ctype
)
81 (eq (numeric-type-class ctype
) 'integer
)
82 (zerop (numeric-type-low ctype
)))
83 do
(fill map
(cons (sb!vm
:saetp-typecode saetp
)
84 (sb!vm
:saetp-n-bits-shift saetp
))
85 :end
(1+ (integer-length (numeric-type-high ctype
)))))
88 #.
(let ((map (make-array (1+ sb
!vm
:n-word-bits
))))
89 (loop for saetp across
90 (reverse sb
!vm
:*specialized-array-element-type-properties
*)
91 for ctype
= (sb!vm
:saetp-ctype saetp
)
92 when
(and (numeric-type-p ctype
)
93 (eq (numeric-type-class ctype
) 'integer
)
94 (minusp (numeric-type-low ctype
)))
95 do
(fill map
(cons (sb!vm
:saetp-typecode saetp
)
96 (sb!vm
:saetp-n-bits-shift saetp
))
97 :end
(+ (integer-length (numeric-type-high ctype
)) 2)))
99 (cond ((> high sb
!vm
:n-word-bits
)
100 (values #.sb
!vm
:simple-vector-widetag
101 #.
(1- (integer-length sb
!vm
:n-word-bits
))))
103 (let ((x (aref signed-table high
)))
104 (values (car x
) (cdr x
))))
106 (let ((x (aref unsigned-table high
)))
107 (values (car x
) (cdr x
)))))))
109 ;;; This is a bit complicated, but calling subtypep over all
110 ;;; specialized types is exceedingly slow
111 (defun %vector-widetag-and-n-bits-shift
(type)
112 (macrolet ((with-parameters ((arg-type &key intervals
)
113 (&rest args
) &body body
)
114 (let ((type-sym (gensym)))
115 `(let (,@(loop for arg in args
117 (declare (ignorable ,@args
))
119 (let ((,type-sym
(cdr type
)))
121 ,@(loop for arg in args
123 `(cond ((consp ,type-sym
)
124 (let ((value (pop ,type-sym
)))
125 (if (or (eq value
'*)
126 (typep value
',arg-type
)
142 (let ((value (symbol-value widetag
)))
144 ,(sb!vm
:saetp-n-bits-shift
146 sb
!vm
:*specialized-array-element-type-properties
*
147 :key
#'sb
!vm
:saetp-typecode
))))))
149 (declare (optimize allow-non-returning-tail-call
))
150 (error "Invalid type specifier: ~/sb!impl:print-type-specifier/"
152 (integer-interval-widetag (low high
)
154 (%integer-vector-widetag-and-n-bits-shift
156 (1+ (max (integer-length low
) (integer-length high
))))
157 (%integer-vector-widetag-and-n-bits-shift
159 (max (integer-length low
) (integer-length high
))))))
160 (let* ((consp (consp type
))
168 (result sb
!vm
:simple-vector-widetag
))
169 ((base-char standard-char
#!-sb-unicode character
)
172 (result sb
!vm
:simple-base-string-widetag
))
174 ((character extended-char
)
177 (result sb
!vm
:simple-character-string-widetag
))
181 (result sb
!vm
:simple-bit-vector-widetag
))
185 (result sb
!vm
:simple-array-fixnum-widetag
))
187 (with-parameters ((integer 1)) (high)
189 (result sb
!vm
:simple-vector-widetag
)
190 (%integer-vector-widetag-and-n-bits-shift nil high
))))
192 (with-parameters ((integer 1)) (high)
194 (result sb
!vm
:simple-vector-widetag
)
195 (%integer-vector-widetag-and-n-bits-shift t high
))))
197 (with-parameters (double-float :intervals t
) (low high
)
198 (if (and (not (eq low
'*))
200 (if (or (consp low
) (consp high
))
201 (>= (type-bound-number low
) (type-bound-number high
))
203 (result sb
!vm
:simple-array-nil-widetag
)
204 (result sb
!vm
:simple-array-double-float-widetag
))))
206 (with-parameters (single-float :intervals t
) (low high
)
207 (if (and (not (eq low
'*))
209 (if (or (consp low
) (consp high
))
210 (>= (type-bound-number low
) (type-bound-number high
))
212 (result sb
!vm
:simple-array-nil-widetag
)
213 (result sb
!vm
:simple-array-single-float-widetag
))))
215 (if (and (consp type
)
218 (typep (cadr type
) '(integer 1)))
219 (%integer-vector-widetag-and-n-bits-shift
220 nil
(integer-length (1- (cadr type
))))
224 (with-parameters (long-float :intervals t
) (low high
)
225 (if (and (not (eq low
'*))
227 (if (or (consp low
) (consp high
))
228 (>= (type-bound-number low
) (type-bound-number high
))
230 (result sb
!vm
:simple-array-nil-widetag
)
231 (result sb
!vm
:simple-array-long-float-widetag
))))
233 (with-parameters (integer :intervals t
) (low high
)
234 (let ((low (if (consp low
)
237 (high (if (consp high
)
240 (cond ((or (eq high
'*)
242 (result sb
!vm
:simple-vector-widetag
))
244 (result sb
!vm
:simple-array-nil-widetag
))
246 (integer-interval-widetag low high
))))))
248 (with-parameters (t) (subtype)
250 (result sb
!vm
:simple-vector-widetag
)
251 (let ((ctype (specifier-type type
)))
252 (cond ((eq ctype
*empty-type
*)
253 (result sb
!vm
:simple-array-nil-widetag
))
254 ((union-type-p ctype
)
255 (cond ((csubtypep ctype
(specifier-type '(complex double-float
)))
257 sb
!vm
:simple-array-complex-double-float-widetag
))
258 ((csubtypep ctype
(specifier-type '(complex single-float
)))
260 sb
!vm
:simple-array-complex-single-float-widetag
))
262 ((csubtypep ctype
(specifier-type '(complex long-float
)))
264 sb
!vm
:simple-array-complex-long-float-widetag
))
266 (result sb
!vm
:simple-vector-widetag
))))
268 (case (numeric-type-format ctype
)
271 sb
!vm
:simple-array-complex-double-float-widetag
))
274 sb
!vm
:simple-array-complex-single-float-widetag
))
278 sb
!vm
:simple-array-complex-long-float-widetag
))
280 (result sb
!vm
:simple-vector-widetag
)))))))))
282 (result sb
!vm
:simple-array-nil-widetag
))
285 (let ((ctype (type-or-nil-if-unknown type
)))
287 (return (result sb
!vm
:simple-vector-widetag
)))
290 (let ((types (union-type-types ctype
)))
291 (cond ((not (every #'numeric-type-p types
))
292 (result sb
!vm
:simple-vector-widetag
))
293 ((csubtypep ctype
(specifier-type 'integer
))
294 (integer-interval-widetag
295 (reduce #'min types
:key
#'numeric-type-low
)
296 (reduce #'max types
:key
#'numeric-type-high
)))
297 ((csubtypep ctype
(specifier-type 'double-float
))
298 (result sb
!vm
:simple-array-double-float-widetag
))
299 ((csubtypep ctype
(specifier-type 'single-float
))
300 (result sb
!vm
:simple-array-single-float-widetag
))
302 ((csubtypep ctype
(specifier-type 'long-float
))
303 (result sb
!vm
:simple-array-long-float-widetag
))
305 (result sb
!vm
:simple-vector-widetag
)))))
307 #!-sb-unicode
(result sb
!vm
:simple-base-string-widetag
)
309 (if (loop for
(start . end
)
310 in
(character-set-type-pairs ctype
)
311 always
(and (< start base-char-code-limit
)
312 (< end base-char-code-limit
)))
313 (result sb
!vm
:simple-base-string-widetag
)
314 (result sb
!vm
:simple-character-string-widetag
)))
316 (let ((expansion (type-specifier ctype
)))
317 (if (equal expansion type
)
318 (result sb
!vm
:simple-vector-widetag
)
319 (%vector-widetag-and-n-bits-shift expansion
)))))))))))))
321 (defun %complex-vector-widetag
(widetag)
322 (macrolet ((make-case ()
324 ,@(loop for saetp across sb
!vm
:*specialized-array-element-type-properties
*
325 for complex
= (sb!vm
:saetp-complex-typecode saetp
)
327 collect
(list (sb!vm
:saetp-typecode saetp
) complex
))
329 #.sb
!vm
:complex-vector-widetag
))))
332 (defglobal %%simple-array-n-bits-shifts%%
(make-array (1+ sb
!vm
:widetag-mask
)))
333 #.
(loop for info across sb
!vm
:*specialized-array-element-type-properties
*
334 collect
`(setf (aref %%simple-array-n-bits-shifts%%
,(sb!vm
:saetp-typecode info
))
335 ,(sb!vm
:saetp-n-bits-shift info
)) into forms
336 finally
(return `(progn ,@forms
)))
338 (declaim (type (simple-vector #.
(1+ sb
!vm
:widetag-mask
)) %%simple-array-n-bits-shifts%%
))
340 (declaim (inline vector-length-in-words
))
341 (defun vector-length-in-words (length n-bits-shift
)
342 (declare (type (integer 0 7) n-bits-shift
))
343 (let ((mask (ash (1- sb
!vm
:n-word-bits
) (- n-bits-shift
)))
344 (shift (- n-bits-shift
345 (1- (integer-length sb
!vm
:n-word-bits
)))))
346 (ash (+ length mask
) shift
)))
348 ;;; N-BITS-SHIFT is the shift amount needed to turn LENGTH into bits
349 ;;; or NIL, %%simple-array-n-bits-shifts%% will be used in that case.
350 (defun allocate-vector-with-widetag (widetag length n-bits-shift
)
351 (declare (type (unsigned-byte 8) widetag
)
353 (let* ((n-bits-shift (or n-bits-shift
354 (aref %%simple-array-n-bits-shifts%% widetag
)))
355 (full-length (if (or (= widetag sb
!vm
:simple-base-string-widetag
)
358 sb
!vm
:simple-character-string-widetag
))
361 ;; Be careful not to allocate backing storage for element type NIL.
362 ;; Both it and type BIT have N-BITS-SHIFT = 0, so the determination
363 ;; of true size can't be left up to VECTOR-LENGTH-IN-WORDS.
364 (allocate-vector widetag length
365 (if (/= widetag sb
!vm
:simple-array-nil-widetag
)
366 (vector-length-in-words full-length n-bits-shift
)
369 (defun array-underlying-widetag (array)
370 (macrolet ((make-case ()
372 ,@(loop for saetp across sb
!vm
:*specialized-array-element-type-properties
*
373 for complex
= (sb!vm
:saetp-complex-typecode saetp
)
375 collect
(list complex
(sb!vm
:saetp-typecode saetp
)))
376 ((,sb
!vm
:simple-array-widetag
377 ,sb
!vm
:complex-vector-widetag
378 ,sb
!vm
:complex-array-widetag
)
379 (with-array-data ((array array
) (start) (end))
380 (declare (ignore start end
))
381 (%other-pointer-widetag array
)))
384 (let ((widetag (%other-pointer-widetag array
)))
387 (defun make-vector-like (vector length
)
388 (allocate-vector-with-widetag (array-underlying-widetag vector
) length nil
))
390 ;; Complain in various ways about wrong :INITIAL-foo arguments,
391 ;; returning the two initialization arguments needed for DATA-VECTOR-FROM-INITS.
392 (defun validate-array-initargs (element-p element contents-p contents displaced
)
393 (cond ((and displaced
(or element-p contents-p
))
394 (if (and element-p contents-p
)
395 (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
396 may be specified with the :DISPLACED-TO option")
397 (error "~S may not be specified with the :DISPLACED-TO option"
398 (if element-p
:initial-element
:initial-contents
))))
399 ((and element-p contents-p
)
400 (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
401 (element-p (values :initial-element element
))
402 (contents-p (values :initial-contents contents
))
403 (t (values nil nil
))))
405 (declaim (inline %save-displaced-array-backpointer
))
406 (defun %save-displaced-array-backpointer
(array data
)
407 (flet ((purge (pointers)
408 (remove-if (lambda (value)
409 (or (not value
) (eq array value
)))
411 :key
#'weak-pointer-value
)))
412 ;; Add backpointer to the new data vector if it has a header.
413 (when (array-header-p data
)
414 (setf (%array-displaced-from data
)
415 (cons (make-weak-pointer array
)
416 (purge (%array-displaced-from data
)))))
417 ;; Remove old backpointer, if any.
418 (let ((old-data (%array-data array
)))
419 (when (and (neq data old-data
) (array-header-p old-data
))
420 (setf (%array-displaced-from old-data
)
421 (purge (%array-displaced-from old-data
)))))))
423 ;;; Widetag is the widetag of the underlying vector,
424 ;;; it'll be the same as the resulting array widetag only for simple vectors
425 (defun %make-array
(dimensions widetag n-bits
428 (initial-element nil initial-element-p
)
429 (initial-contents nil initial-contents-p
)
430 adjustable fill-pointer
431 displaced-to displaced-index-offset
)
432 (declare (ignore element-type
))
433 (binding* (((array-rank dimension-0
)
434 (if (listp dimensions
)
435 (values (length dimensions
)
436 (if dimensions
(car dimensions
) 1))
437 (values 1 dimensions
)))
438 ((initialize initial-data
)
439 (validate-array-initargs initial-element-p initial-element
440 initial-contents-p initial-contents
442 (simple (and (null fill-pointer
)
444 (null displaced-to
))))
445 (declare (type array-rank array-rank
))
446 (declare (type index dimension-0
))
447 (cond ((and displaced-index-offset
(null displaced-to
))
448 (error "Can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
449 ((and simple
(= array-rank
1))
450 (let ((vector ; a (SIMPLE-ARRAY * (*))
451 (allocate-vector-with-widetag widetag dimension-0 n-bits
)))
452 ;; presence of at most one :INITIAL-thing keyword was ensured above
453 (cond (initial-element-p
454 (fill vector initial-element
))
456 (let ((content-length (length initial-contents
)))
457 (unless (= dimension-0 content-length
)
458 (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
459 the vector length is ~W."
460 content-length dimension-0
)))
461 (replace vector initial-contents
)))
463 ((and (arrayp displaced-to
)
464 (/= (array-underlying-widetag displaced-to
) widetag
))
465 (error "Array element type of :DISPLACED-TO array does not match specified element type"))
467 ;; it's non-simple or multidimensional, or both.
469 (unless (= array-rank
1)
470 (error "Only vectors can have fill pointers."))
471 (when (and (integerp fill-pointer
) (> fill-pointer dimension-0
))
472 ;; FIXME: should be TYPE-ERROR?
473 (error "invalid fill-pointer ~W" fill-pointer
)))
475 (if (consp dimensions
)
476 (the index
(reduce (lambda (a b
) (* a
(the index b
)))
478 ;; () is considered to have dimension-0 = 1.
479 ;; It avoids the REDUCE lambda being called with no args.
481 (data (or displaced-to
482 (data-vector-from-inits
483 dimensions total-size nil widetag n-bits
484 initialize initial-data
)))
485 (array (make-array-header
486 (cond ((= array-rank
1)
487 (%complex-vector-widetag widetag
))
488 (simple sb
!vm
:simple-array-widetag
)
489 (t sb
!vm
:complex-array-widetag
))
492 (setf (%array-fill-pointer-p array
) t
493 (%array-fill-pointer array
)
494 (if (eq fill-pointer t
) dimension-0 fill-pointer
))
495 (setf (%array-fill-pointer-p array
) nil
496 (%array-fill-pointer array
) total-size
))
497 (setf (%array-available-elements array
) total-size
)
498 ;; Terrible name for this slot - we displace to the
499 ;; target array's header, if any, not the "ultimate"
500 ;; vector in the chain of displacements.
501 (setf (%array-data array
) data
)
502 (setf (%array-displaced-from array
) nil
)
504 (let ((offset (or displaced-index-offset
0)))
505 (when (> (+ offset total-size
)
506 (array-total-size displaced-to
))
507 (error "~S doesn't have enough elements." displaced-to
))
508 (setf (%array-displacement array
) offset
)
509 (setf (%array-displaced-p array
) t
)
510 (%save-displaced-array-backpointer array data
)))
512 (setf (%array-displaced-p array
) nil
)))
513 (if (listp dimensions
)
514 (let ((dims dimensions
)) ; avoid "prevents use of assertion"
515 (dotimes (axis array-rank
)
516 (setf (%array-dimension array axis
) (pop dims
))))
517 (setf (%array-dimension array
0) dimension-0
))
520 (defun make-array (dimensions &rest args
521 &key
(element-type t
)
522 initial-element initial-contents
526 displaced-index-offset
)
527 (declare (ignore initial-element
528 initial-contents adjustable
529 fill-pointer displaced-to displaced-index-offset
))
530 (declare (explicit-check))
531 (multiple-value-bind (widetag shift
) (%vector-widetag-and-n-bits-shift element-type
)
532 (apply #'%make-array dimensions widetag shift args
)))
534 (defun make-static-vector (length &key
535 (element-type '(unsigned-byte 8))
536 (initial-contents nil initial-contents-p
)
537 (initial-element nil initial-element-p
))
538 "Allocate vector of LENGTH elements in static space. Only allocation
539 of specialized arrays is supported."
540 ;; STEP 1: check inputs fully
542 ;; This way of doing explicit checks before the vector is allocated
543 ;; is expensive, but probably worth the trouble as once we've allocated
544 ;; the vector we have no way to get rid of it anymore...
545 (when (eq t
(upgraded-array-element-type element-type
))
546 (error "Static arrays of type ~/sb!impl:print-type-specifier/ not supported."
548 (validate-array-initargs initial-element-p initial-element
549 initial-contents-p initial-contents nil
) ; for effect
550 (when initial-contents-p
551 (unless (= length
(length initial-contents
))
552 (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
553 vector length is ~W."
554 (length initial-contents
)
556 (unless (every (lambda (x) (typep x element-type
)) initial-contents
)
557 (error ":INITIAL-CONTENTS contains elements not of type ~
558 ~/sb!impl:print-type-specifier/."
560 (when initial-element-p
561 (unless (typep initial-element element-type
)
562 (error ":INITIAL-ELEMENT ~S is not of type ~
563 ~/sb!impl:print-type-specifier/."
564 initial-element element-type
)))
567 ;; Allocate and possibly initialize the vector.
568 (multiple-value-bind (type n-bits-shift
)
569 (%vector-widetag-and-n-bits-shift element-type
)
571 (allocate-static-vector type length
572 (vector-length-in-words length
574 (cond (initial-element-p
575 (fill vector initial-element
))
577 (replace vector initial-contents
))
581 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
582 ;;; specified array characteristics. Dimensions is only used to pass
583 ;;; to FILL-DATA-VECTOR for error checking on the structure of
584 ;;; initial-contents.
585 (defun data-vector-from-inits (dimensions total-size
586 element-type widetag n-bits
587 initialize initial-data
)
588 ;; FIXME: element-type can be NIL when widetag is non-nil,
589 ;; and FILL will check the type, although the error will be not as nice.
590 ;; (cond (typep initial-element element-type)
591 ;; (error "~S cannot be used to initialize an array of type ~S."
592 ;; initial-element element-type))
593 (let ((data (if widetag
594 (allocate-vector-with-widetag widetag total-size n-bits
)
595 (make-array total-size
:element-type element-type
))))
598 (fill (the vector data
) initial-data
))
600 ;; DIMENSIONS can be supplied as a list or integer now
601 (dx-let ((list-of-dims (list dimensions
))) ; ok if already a list
602 (fill-data-vector data
603 (if (listp dimensions
) dimensions list-of-dims
)
608 (defun vector (&rest objects
)
609 "Construct a SIMPLE-VECTOR from the given objects."
610 (let ((v (make-array (length objects
))))
611 (do-rest-arg ((x i
) objects
0 v
)
612 (setf (aref v i
) x
))))
615 ;;;; accessor/setter functions
617 ;;; Dispatch to an optimized routine the data vector accessors for
618 ;;; each different specialized vector type. Do dispatching by looking
619 ;;; up the widetag in the array rather than with the typecases, which
620 ;;; as of 1.0.5 compiles to a naive sequence of linear TYPEPs. Also
621 ;;; provide separate versions where bounds checking has been moved
622 ;;; from the callee to the caller, since it's much cheaper to do once
623 ;;; the type information is available. Finally, for each of these
624 ;;; routines also provide a slow path, taken for arrays that are not
625 ;;; vectors or not simple.
626 (macrolet ((def (name table-name
)
628 (defglobal ,table-name
(make-array ,(1+ sb
!vm
:widetag-mask
)))
629 (declaim (type (simple-array function
(,(1+ sb
!vm
:widetag-mask
)))
631 (defmacro ,name
(array-var)
634 (when (sb!vm
::%other-pointer-p
,array-var
)
635 (setf tag
(%other-pointer-widetag
,array-var
)))
636 (svref ,',table-name tag
)))))))
637 (def !find-data-vector-setter %%data-vector-setters%%
)
638 (def !find-data-vector-setter
/check-bounds %%data-vector-setters
/check-bounds%%
)
639 ;; Used by DO-VECTOR-DATA -- which in turn appears in DOSEQUENCE expansion,
640 ;; meaning we can have post-build dependences on this.
641 (def %find-data-vector-reffer %%data-vector-reffers%%
)
642 (def !find-data-vector-reffer
/check-bounds %%data-vector-reffers
/check-bounds%%
))
644 ;;; Like DOVECTOR, but more magical -- can't use this on host.
645 (defmacro do-vector-data
((elt vector
&optional result
) &body body
)
646 (multiple-value-bind (forms decls
) (parse-body body nil
)
647 (with-unique-names (index vec start end ref
)
648 `(with-array-data ((,vec
,vector
)
651 :check-fill-pointer t
)
652 (let ((,ref
(%find-data-vector-reffer
,vec
)))
653 (declare (function ,ref
))
654 (do ((,index
,start
(1+ ,index
)))
657 ,@(filter-dolist-declarations decls
)
660 (let ((,elt
(funcall ,ref
,vec
,index
)))
662 (tagbody ,@forms
))))))))
664 (macrolet ((%ref
(accessor-getter extra-params
)
665 `(funcall (,accessor-getter array
) array index
,@extra-params
))
666 (define (accessor-name slow-accessor-name accessor-getter
667 extra-params check-bounds
)
669 (defun ,accessor-name
(array index
,@extra-params
)
670 (declare (explicit-check))
671 (declare (optimize speed
672 ;; (SAFETY 0) is ok. All calls to
673 ;; these functions are generated by
674 ;; the compiler, so argument count
675 ;; checking isn't needed. Type checking
676 ;; is done implicitly via the widetag
679 (%ref
,accessor-getter
,extra-params
))
680 (defun ,slow-accessor-name
(array index
,@extra-params
)
681 (declare (optimize speed
(safety 0)))
682 (if (not (%array-displaced-p array
))
683 ;; The reasonably quick path of non-displaced complex
685 (let ((array (%array-data array
)))
686 (%ref
,accessor-getter
,extra-params
))
687 ;; The real slow path.
691 (declare (optimize (speed 1) (safety 1)))
692 (,@check-bounds index
)))
695 (declare (ignore end
))
696 (,accessor-name vector index
,@extra-params
)))))))
697 (define hairy-data-vector-ref slow-hairy-data-vector-ref
698 %find-data-vector-reffer
700 (define hairy-data-vector-set slow-hairy-data-vector-set
701 !find-data-vector-setter
703 (define hairy-data-vector-ref
/check-bounds
704 slow-hairy-data-vector-ref
/check-bounds
705 !find-data-vector-reffer
/check-bounds
706 nil
(check-bound array
(%array-dimension array
0)))
707 (define hairy-data-vector-set
/check-bounds
708 slow-hairy-data-vector-set
/check-bounds
709 !find-data-vector-setter
/check-bounds
710 (new-value) (check-bound array
(%array-dimension array
0))))
712 (defun hairy-ref-error (array index
&optional new-value
)
713 (declare (ignore index new-value
))
716 :expected-type
'vector
))
718 (macrolet ((define-reffer (saetp check-form
)
719 (let* ((type (sb!vm
:saetp-specifier saetp
))
720 (atype `(simple-array ,type
(*))))
721 `(named-lambda (optimized-data-vector-ref ,type
) (vector index
)
722 (declare (optimize speed
(safety 0))
723 ;; Obviously these all coerce raw words to lispobjs
724 ;; so don't keep spewing notes about it.
725 (muffle-conditions compiler-note
)
728 `(data-vector-ref (the ,atype vector
)
730 (declare (optimize (safety 1)))
732 (,@check-form index
))))
733 `(data-nil-vector-ref (the ,atype vector
) index
)))))
734 (define-setter (saetp check-form
)
735 (let* ((type (sb!vm
:saetp-specifier saetp
))
736 (atype `(simple-array ,type
(*))))
737 `(named-lambda (optimized-data-vector-set ,type
) (vector index new-value
)
738 (declare (optimize speed
(safety 0)))
739 ;; Impossibly setting an elt of an (ARRAY NIL)
740 ;; returns no value. And nobody cares.
741 (declare (muffle-conditions compiler-note
))
742 (data-vector-set (the ,atype vector
)
744 (declare (optimize (safety 1)))
746 (,@check-form index
)))
748 ;; SPEED 1 needed to avoid the compiler
749 ;; from downgrading the type check to
751 (declare (optimize (speed 1)
753 (the* (,type
:context aref
) new-value
)))
754 ;; For specialized arrays, the return from
755 ;; data-vector-set would have to be reboxed to be a
756 ;; (Lisp) return value; instead, we use the
757 ;; already-boxed value as the return.
759 (define-reffers (symbol deffer check-form slow-path
)
761 ;; FIXME/KLUDGE: can't just FILL here, because genesis doesn't
762 ;; preserve the binding, so re-initiaize as NS doesn't have
763 ;; the energy to figure out to change that right now.
764 (setf ,symbol
(make-array (1+ sb
!vm
::widetag-mask
)
765 :initial-element
#'hairy-ref-error
))
766 ,@(loop for widetag in
'(sb!vm
:complex-vector-widetag
767 sb
!vm
:complex-vector-nil-widetag
768 sb
!vm
:complex-bit-vector-widetag
769 #!+sb-unicode sb
!vm
:complex-character-string-widetag
770 sb
!vm
:complex-base-string-widetag
771 sb
!vm
:simple-array-widetag
772 sb
!vm
:complex-array-widetag
)
773 collect
`(setf (svref ,symbol
,widetag
) ,slow-path
))
774 ,@(loop for saetp across sb
!vm
:*specialized-array-element-type-properties
*
775 for widetag
= (sb!vm
:saetp-typecode saetp
)
776 collect
`(setf (svref ,symbol
,widetag
)
777 (,deffer
,saetp
,check-form
))))))
778 (defun !hairy-data-vector-reffer-init
()
779 (define-reffers %%data-vector-reffers%% define-reffer
781 #'slow-hairy-data-vector-ref
)
782 (define-reffers %%data-vector-setters%% define-setter
784 #'slow-hairy-data-vector-set
)
785 (define-reffers %%data-vector-reffers
/check-bounds%% define-reffer
786 (check-bound vector
(length vector
))
787 #'slow-hairy-data-vector-ref
/check-bounds
)
788 (define-reffers %%data-vector-setters
/check-bounds%% define-setter
789 (check-bound vector
(length vector
))
790 #'slow-hairy-data-vector-set
/check-bounds
)))
792 ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
793 ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
794 ;;; definition is needed for the compiler to use in constant folding.)
795 (defun data-vector-ref (array index
)
796 (declare (explicit-check))
797 (hairy-data-vector-ref array index
))
799 (defun data-vector-ref-with-offset (array index offset
)
800 (declare (explicit-check))
801 (hairy-data-vector-ref array
(+ index offset
)))
803 (defun invalid-array-p (array)
804 (and (array-header-p array
)
805 (consp (%array-displaced-p array
))))
807 (declaim (ftype (function (array) nil
) invalid-array-error
))
808 (defun invalid-array-error (array)
809 (declare (optimize allow-non-returning-tail-call
))
810 (aver (array-header-p array
))
811 ;; Array invalidation stashes the original dimensions here...
812 (let ((dims (%array-displaced-p array
))
813 (et (array-element-type array
)))
814 (error 'invalid-array-error
819 `(vector ,et
,@dims
)))))
821 (declaim (ftype (function (array t integer
&optional t
) nil
)
822 invalid-array-index-error
))
823 (defun invalid-array-index-error (array index bound
&optional axis
)
824 (declare (optimize allow-non-returning-tail-call
))
825 (if (invalid-array-p array
)
826 (invalid-array-error array
)
827 (error 'invalid-array-index-error
831 :expected-type
`(integer 0 (,bound
)))))
833 ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
834 (defun %array-row-major-index
(array &rest subscripts
)
835 (declare (truly-dynamic-extent subscripts
)
837 (let ((length (length subscripts
)))
838 (cond ((array-header-p array
)
839 (let ((rank (%array-rank array
)))
840 (unless (= rank length
)
841 (error "Wrong number of subscripts, ~W, for array of rank ~W."
843 (do ((axis (1- rank
) (1- axis
))
846 ((minusp axis
) result
)
847 (declare (fixnum axis chunk-size result
))
848 (let ((index (fast-&rest-nth axis subscripts
))
849 (dim (%array-dimension array axis
)))
850 (unless (and (fixnump index
) (< -
1 index dim
))
851 (invalid-array-index-error array index dim axis
))
855 (truly-the fixnum
(* chunk-size index
))))
856 chunk-size
(truly-the fixnum
(* chunk-size dim
)))))))
858 (error "Wrong number of subscripts, ~W, for array of rank 1."
861 (let ((index (fast-&rest-nth
0 subscripts
))
862 (length (length (the (simple-array * (*)) array
))))
863 (unless (and (fixnump index
) (< -
1 index length
))
864 (invalid-array-index-error array index length
))
867 (defun array-in-bounds-p (array &rest subscripts
)
868 "Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise."
869 (declare (truly-dynamic-extent subscripts
))
870 (let ((length (length subscripts
)))
871 (cond ((array-header-p array
)
872 (let ((rank (%array-rank array
)))
873 (unless (= rank length
)
874 (error "Wrong number of subscripts, ~W, for array of rank ~W."
876 (loop for i below length
877 for s
= (fast-&rest-nth i subscripts
)
878 always
(and (typep s
'(and fixnum unsigned-byte
))
879 (< s
(%array-dimension array i
))))))
881 (error "Wrong number of subscripts, ~W, for array of rank 1."
884 (let ((subscript (fast-&rest-nth
0 subscripts
)))
885 (and (typep subscript
'(and fixnum unsigned-byte
))
887 (length (truly-the (simple-array * (*)) array
)))))))))
889 (defun array-row-major-index (array &rest subscripts
)
890 (declare (truly-dynamic-extent subscripts
))
891 (apply #'%array-row-major-index array subscripts
))
893 (defun aref (array &rest subscripts
)
894 "Return the element of the ARRAY specified by the SUBSCRIPTS."
895 (declare (truly-dynamic-extent subscripts
))
896 (row-major-aref array
(apply #'%array-row-major-index array subscripts
)))
898 ;;; (setf aref/bit/sbit) are implemented using setf-functions,
899 ;;; because they have to work with (setf (apply #'aref array subscripts))
900 ;;; All other setfs can be done using setf-functions too, but I
901 ;;; haven't found technical advantages or disadvantages for either
903 (defun (setf aref
) (new-value array
&rest subscripts
)
904 (declare (truly-dynamic-extent subscripts
)
906 (setf (row-major-aref array
(apply #'%array-row-major-index array subscripts
))
909 (defun row-major-aref (array index
)
910 "Return the element of array corresponding to the row-major index. This is
912 (declare (optimize (safety 1)))
913 (row-major-aref array index
))
915 (defun %set-row-major-aref
(array index new-value
)
916 (declare (optimize (safety 1)))
917 (setf (row-major-aref array index
) new-value
))
919 (defun svref (simple-vector index
)
920 "Return the INDEXth element of the given Simple-Vector."
921 (declare (optimize (safety 1)))
922 (aref simple-vector index
))
924 (defun %svset
(simple-vector index new
)
925 (declare (optimize (safety 1)))
926 (setf (aref simple-vector index
) new
))
928 (defun bit (bit-array &rest subscripts
)
929 "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
930 (declare (type (array bit
) bit-array
)
931 (truly-dynamic-extent subscripts
)
932 (optimize (safety 1)))
933 (row-major-aref bit-array
(apply #'%array-row-major-index bit-array subscripts
)))
935 (defun (setf bit
) (new-value bit-array
&rest subscripts
)
936 (declare (type (array bit
) bit-array
)
938 (truly-dynamic-extent subscripts
)
939 (optimize (safety 1)))
940 (setf (row-major-aref bit-array
941 (apply #'%array-row-major-index bit-array subscripts
))
944 (defun sbit (simple-bit-array &rest subscripts
)
945 "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
946 (declare (type (simple-array bit
) simple-bit-array
)
947 (truly-dynamic-extent subscripts
)
948 (optimize (safety 1)))
949 (row-major-aref simple-bit-array
950 (apply #'%array-row-major-index simple-bit-array subscripts
)))
952 (defun (setf sbit
) (new-value bit-array
&rest subscripts
)
953 (declare (type (simple-array bit
) bit-array
)
955 (truly-dynamic-extent subscripts
)
956 (optimize (safety 1)))
957 (setf (row-major-aref bit-array
958 (apply #'%array-row-major-index bit-array subscripts
))
961 ;;;; miscellaneous array properties
963 (defun array-element-type (array)
964 "Return the type of the elements of the array"
965 (let ((widetag (%other-pointer-widetag array
))
966 (table (load-time-value
967 (let ((table (make-array 256 :initial-element nil
)))
968 (dotimes (i (length sb
!vm
:*specialized-array-element-type-properties
*) table
)
969 (let* ((saetp (aref sb
!vm
:*specialized-array-element-type-properties
* i
))
970 (typecode (sb!vm
:saetp-typecode saetp
))
971 (complex-typecode (sb!vm
:saetp-complex-typecode saetp
))
972 (specifier (sb!vm
:saetp-specifier saetp
)))
973 (aver (typep specifier
'(or list symbol
)))
974 (setf (aref table typecode
) specifier
)
975 (when complex-typecode
976 (setf (aref table complex-typecode
) specifier
)))))
978 (let ((result (aref table widetag
)))
980 (truly-the (or list symbol
) result
)
981 ;; (MAKE-ARRAY :ELEMENT-TYPE NIL) goes to this branch, but
982 ;; gets the right answer in the end
983 (with-array-data ((array array
) (start) (end))
984 (declare (ignore start end
))
985 (truly-the (or list symbol
) (aref table
(%other-pointer-widetag array
))))))))
987 (defun array-rank (array)
988 "Return the number of dimensions of ARRAY."
989 (if (array-header-p array
)
993 (defun array-dimension (array axis-number
)
994 "Return the length of dimension AXIS-NUMBER of ARRAY."
995 (declare (array array
) (type index axis-number
))
996 (cond ((not (array-header-p array
))
997 (unless (= axis-number
0)
998 (error "Vector axis is not zero: ~S" axis-number
))
999 (length (the (simple-array * (*)) array
)))
1000 ((>= axis-number
(%array-rank array
))
1001 (error "Axis number ~W is too big; ~S only has ~D dimension~:P."
1002 axis-number array
(%array-rank array
)))
1004 (%array-dimension array axis-number
))))
1006 (defun array-dimensions (array)
1007 "Return a list whose elements are the dimensions of the array"
1008 (declare (explicit-check))
1009 (cond ((array-header-p array
)
1010 (do ((results nil
(cons (%array-dimension array index
) results
))
1011 (index (1- (%array-rank array
)) (1- index
)))
1012 ((minusp index
) results
)))
1013 ((typep array
'vector
)
1014 (list (length array
)))
1016 (sb!c
::%type-check-error
/c array
'object-not-array-error nil
))))
1018 (defun array-total-size (array)
1019 "Return the total number of elements in the Array."
1020 (declare (explicit-check))
1021 (cond ((array-header-p array
)
1022 (%array-available-elements array
))
1023 ((typep array
'vector
)
1026 (sb!c
::%type-check-error
/c array
'object-not-array-error nil
))))
1028 (defun array-displacement (array)
1029 "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
1030 options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
1031 (declare (type array array
))
1032 (if (and (array-header-p array
) ; if unsimple and
1033 (%array-displaced-p array
)) ; displaced
1034 (values (%array-data array
) (%array-displacement array
))
1037 (defun adjustable-array-p (array)
1038 "Return T if and only if calling ADJUST-ARRAY on ARRAY will return
1039 the identical object."
1040 (declare (array array
))
1041 ;; Note that this appears not to be a fundamental limitation.
1042 ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
1043 ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
1044 ;; -- CSR, 2004-03-01.
1045 (not (typep array
'simple-array
)))
1047 ;;;; fill pointer frobbing stuff
1049 (declaim (inline array-has-fill-pointer-p
))
1050 (defun array-has-fill-pointer-p (array)
1051 "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
1052 (declare (array array
))
1053 (and (array-header-p array
) (%array-fill-pointer-p array
)))
1055 (defun fill-pointer-error (vector &optional arg
)
1056 (declare (optimize allow-non-returning-tail-call
))
1058 (aver (array-has-fill-pointer-p vector
))
1059 (let ((max (%array-available-elements vector
)))
1060 (error 'simple-type-error
1062 :expected-type
(list 'integer
0 max
)
1063 :format-control
"The new fill pointer, ~S, is larger than the length of the vector (~S.)"
1064 :format-arguments
(list arg max
))))
1066 (error 'simple-type-error
1068 :expected-type
'(and vector
(satisfies array-has-fill-pointer-p
))
1069 :format-control
"~S is not an array with a fill pointer."
1070 :format-arguments
(list vector
)))))
1072 (declaim (inline fill-pointer
))
1073 (defun fill-pointer (vector)
1074 "Return the FILL-POINTER of the given VECTOR."
1075 (declare (explicit-check))
1076 (if (array-has-fill-pointer-p vector
)
1077 (%array-fill-pointer vector
)
1078 (fill-pointer-error vector
)))
1080 (defun %set-fill-pointer
(vector new
)
1081 (declare (explicit-check)
1084 (fill-pointer-error vector x
)))
1085 (cond ((not (array-has-fill-pointer-p vector
))
1087 ((> new
(%array-available-elements vector
))
1090 (setf (%array-fill-pointer vector
) new
)))))
1092 ;;; FIXME: It'd probably make sense to use a MACROLET to share the
1093 ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro
1094 ;;; should probably be based on the VECTOR-PUSH-EXTEND code (which is
1095 ;;; new ca. sbcl-0.7.0) rather than the VECTOR-PUSH code (which dates
1096 ;;; back to CMU CL).
1097 (defun vector-push (new-element array
)
1098 "Attempt to set the element of ARRAY designated by its fill pointer
1099 to NEW-ELEMENT, and increment the fill pointer by one. If the fill pointer is
1100 too large, NIL is returned, otherwise the index of the pushed element is
1102 (declare (explicit-check))
1103 (let ((fill-pointer (fill-pointer array
)))
1104 (cond ((= fill-pointer
(%array-available-elements array
))
1107 (locally (declare (optimize (safety 0)))
1108 (setf (aref array fill-pointer
) new-element
))
1109 (setf (%array-fill-pointer array
) (1+ fill-pointer
))
1112 ;;; Widetags of FROM and TO should be equal
1113 (defun copy-vector-data (from to start end n-bits-shift
)
1114 (declare (vector from to
)
1116 ((integer 0 7) n-bits-shift
))
1117 (let ((from-length (length from
)))
1118 (cond ((simple-vector-p from
)
1119 (replace (truly-the simple-vector to
)
1120 (truly-the simple-vector from
)
1121 :start2 start
:end2 end
))
1122 ;; Vector sizes are double-word aligned and have zeros in
1123 ;; the extra word so it's safe to copy when the boundaries
1124 ;; are matching the whole vector.
1125 ;; A more generic routine is left for another time, even if
1126 ;; only handling aligned data since it will avoid consing
1127 ;; floats or word bignums.
1129 (= end from-length
))
1130 (loop for i below
(vector-length-in-words from-length n-bits-shift
)
1132 (%vector-raw-bits to i
)
1133 (%vector-raw-bits from i
))))
1137 :start2 start
:end2 end
)))
1140 (defun extend-vector (vector min-extension
)
1141 (declare (optimize speed
)
1143 (let* ((old-length (length vector
))
1144 (min-extension (or min-extension
1146 (- array-dimension-limit old-length
))))
1147 (new-length (the index
(+ old-length
1148 (max 1 min-extension
))))
1149 (fill-pointer (1+ old-length
)))
1150 (declare (fixnum new-length min-extension
))
1151 (with-array-data ((old-data vector
) (old-start)
1152 (old-end old-length
))
1153 (let* ((widetag (%other-pointer-widetag old-data
))
1154 (n-bits-shift (aref %%simple-array-n-bits-shifts%% widetag
))
1156 (allocate-vector-with-widetag widetag new-length n-bits-shift
)))
1157 (copy-vector-data old-data new-data old-start old-end n-bits-shift
)
1158 (setf (%array-data vector
) new-data
1159 (%array-available-elements vector
) new-length
1160 (%array-fill-pointer vector
) fill-pointer
1161 (%array-displacement vector
) 0
1162 (%array-dimension vector
0) new-length
1163 (%array-displaced-p vector
) nil
)
1166 (defun vector-push-extend (new-element vector
&optional min-extension
)
1167 (declare (type (or null
(and index
(integer 1))) min-extension
))
1168 (declare (explicit-check))
1169 (let* ((fill-pointer (fill-pointer vector
))
1170 (new-fill-pointer (1+ fill-pointer
)))
1171 (if (= fill-pointer
(%array-available-elements vector
))
1172 (extend-vector vector min-extension
)
1173 (setf (%array-fill-pointer vector
) new-fill-pointer
))
1174 ;; disable bounds checking
1175 (locally (declare (optimize (safety 0)))
1176 (setf (aref vector fill-pointer
) new-element
))
1179 (defun vector-pop (array)
1180 "Decrease the fill pointer by 1 and return the element pointed to by the
1182 (declare (explicit-check))
1183 (let ((fill-pointer (fill-pointer array
)))
1184 (if (zerop fill-pointer
)
1185 (error "There is nothing left to pop.")
1186 ;; disable bounds checking (and any fixnum test)
1187 (locally (declare (optimize (safety 0)))
1189 (setf (%array-fill-pointer array
)
1190 (1- fill-pointer
)))))))
1195 (defun adjust-array (array dimensions
&key
1196 (element-type (array-element-type array
) element-type-p
)
1197 (initial-element nil initial-element-p
)
1198 (initial-contents nil initial-contents-p
)
1200 displaced-to displaced-index-offset
)
1201 "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
1202 (when (invalid-array-p array
)
1203 (invalid-array-error array
))
1204 (binding* ((dimensions-rank (if (listp dimensions
)
1207 (array-rank (array-rank array
))
1209 (unless (= dimensions-rank array-rank
)
1210 (error "The number of dimensions not equal to rank of array.")))
1211 ((initialize initial-data
)
1212 (validate-array-initargs initial-element-p initial-element
1213 initial-contents-p initial-contents
1215 (widetag (array-underlying-widetag array
)))
1216 (cond ((and element-type-p
1217 (/= (%vector-widetag-and-n-bits-shift element-type
)
1219 (error "The new element type, ~
1220 ~/sb-impl:print-type-specifier/, is incompatible ~
1221 with old type, ~/sb-impl:print-type-specifier/."
1222 element-type
(array-element-type array
)))
1223 ((and fill-pointer
(/= array-rank
1))
1224 (error "Only vectors can have fill pointers."))
1225 ((and fill-pointer
(not (array-has-fill-pointer-p array
)))
1226 ;; This case always struck me as odd. It seems like it might mean
1227 ;; that the user asks that the array gain a fill-pointer if it didn't
1228 ;; have one, yet CLHS is clear that the argument array must have a
1229 ;; fill-pointer or else signal a type-error.
1230 (fill-pointer-error array
)))
1231 (cond (initial-contents-p
1232 ;; array former contents replaced by INITIAL-CONTENTS
1233 (let* ((array-size (if (listp dimensions
)
1234 (apply #'* dimensions
)
1236 (array-data (data-vector-from-inits
1237 dimensions array-size element-type nil nil
1238 initialize initial-data
)))
1239 (cond ((adjustable-array-p array
)
1240 (set-array-header array array-data array-size
1241 (get-new-fill-pointer array array-size
1243 0 dimensions nil nil
))
1244 ((array-header-p array
)
1245 ;; simple multidimensional or single dimensional array
1246 (%make-array dimensions widetag
1247 (aref %%simple-array-n-bits-shifts%% widetag
)
1248 :initial-contents initial-contents
))
1252 ;; We already established that no INITIAL-CONTENTS was supplied.
1253 (when (/= (array-underlying-widetag displaced-to
) widetag
)
1254 ;; See lp#1331299 again. Require exact match on upgraded type?
1255 (error "can't displace an array of type ~
1256 ~/sb!impl:print-type-specifier/ into another ~
1257 of type ~/sb!impl:print-type-specifier/"
1258 element-type
(array-element-type displaced-to
)))
1259 (let ((displacement (or displaced-index-offset
0))
1260 (array-size (if (listp dimensions
)
1261 (apply #'* dimensions
)
1263 (declare (fixnum displacement array-size
))
1264 (if (< (the fixnum
(array-total-size displaced-to
))
1265 (the fixnum
(+ displacement array-size
)))
1266 (error "The :DISPLACED-TO array is too small."))
1267 (if (adjustable-array-p array
)
1268 ;; None of the original contents appear in adjusted array.
1269 (set-array-header array displaced-to array-size
1270 (get-new-fill-pointer array array-size
1272 displacement dimensions t nil
)
1273 ;; simple multidimensional or single dimensional array
1274 (%make-array dimensions widetag
1275 (aref %%simple-array-n-bits-shifts%% widetag
)
1276 :displaced-to displaced-to
1277 :displaced-index-offset
1278 displaced-index-offset
))))
1280 (let ((old-length (array-total-size array
))
1281 (new-length (if (listp dimensions
)
1285 (declare (fixnum old-length new-length
))
1286 (with-array-data ((old-data array
) (old-start)
1287 (old-end old-length
))
1288 (cond ((or (and (array-header-p array
)
1289 (%array-displaced-p array
))
1290 (< old-length new-length
))
1292 (data-vector-from-inits
1293 dimensions new-length element-type
1294 (%other-pointer-widetag old-data
) nil
1295 initialize initial-data
))
1296 ;; Provide :END1 to avoid full call to LENGTH
1298 (replace new-data old-data
1300 :start2 old-start
:end2 old-end
))
1302 (shrink-vector old-data new-length
))))
1303 (if (adjustable-array-p array
)
1304 (set-array-header array new-data new-length
1305 (get-new-fill-pointer array new-length
1307 0 dimensions nil nil
)
1310 (let ((old-length (%array-available-elements array
))
1311 (new-length (apply #'* dimensions
)))
1312 (declare (fixnum old-length new-length
))
1313 (with-array-data ((old-data array
) (old-start)
1314 (old-end old-length
))
1315 (declare (ignore old-end
))
1316 (let ((new-data (if (or (and (array-header-p array
)
1317 (%array-displaced-p array
))
1318 (> new-length old-length
)
1319 (not (adjustable-array-p array
)))
1320 (data-vector-from-inits
1321 dimensions new-length
1323 (%other-pointer-widetag old-data
) nil
1324 (if initial-element-p
:initial-element
)
1327 (if (or (zerop old-length
) (zerop new-length
))
1328 (when initial-element-p
(fill new-data initial-element
))
1329 (zap-array-data old-data
(array-dimensions array
)
1331 new-data dimensions new-length
1332 element-type initial-element
1334 (if (adjustable-array-p array
)
1335 (set-array-header array new-data new-length
1336 nil
0 dimensions nil nil
)
1339 sb
!vm
:simple-array-widetag array-rank
)))
1340 (set-array-header new-array new-data new-length
1341 nil
0 dimensions nil t
))))))))))
1344 (defun get-new-fill-pointer (old-array new-array-size fill-pointer
)
1345 (declare (fixnum new-array-size
))
1346 (typecase fill-pointer
1348 ;; "The consequences are unspecified if array is adjusted to a
1349 ;; size smaller than its fill pointer ..."
1350 (when (array-has-fill-pointer-p old-array
)
1351 (when (> (%array-fill-pointer old-array
) new-array-size
)
1352 (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~
1353 smaller than its fill pointer (~S)"
1354 old-array new-array-size
(fill-pointer old-array
)))
1355 (%array-fill-pointer old-array
)))
1359 (when (> fill-pointer new-array-size
)
1360 (error "can't supply a value for :FILL-POINTER (~S) that is larger ~
1361 than the new length of the vector (~S)"
1362 fill-pointer new-array-size
))
1365 ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
1366 ;;; which must be less than or equal to its current length. This can
1367 ;;; be called on vectors without a fill pointer but it is extremely
1368 ;;; dangerous to do so: shrinking the size of an object (as viewed by
1369 ;;; the gc) makes bounds checking unreliable in the face of interrupts
1370 ;;; or multi-threading. Call it only on provably local vectors.
1371 (defun %shrink-vector
(vector new-length
)
1372 (declare (vector vector
))
1373 (unless (array-header-p vector
)
1374 (macrolet ((frob (name &rest things
)
1376 ((simple-array nil
(*)) (error 'nil-array-accessed-error
))
1377 ,@(mapcar (lambda (thing)
1378 (destructuring-bind (type-spec fill-value
)
1381 (fill (truly-the ,type-spec
,name
)
1383 :start new-length
))))
1385 ;; Set the 'tail' of the vector to the appropriate type of zero,
1386 ;; "because in some cases we'll scavenge larger areas in one go,
1387 ;; like groups of pages that had triggered the write barrier, or
1388 ;; the whole static space" according to jsnell.
1392 `((simple-array ,(sb!vm
:saetp-specifier saetp
) (*))
1393 ,(if (or (eq (sb!vm
:saetp-specifier saetp
) 'character
)
1395 (eq (sb!vm
:saetp-specifier saetp
) 'base-char
))
1396 *default-init-char-form
*
1397 (sb!vm
:saetp-initial-element-default saetp
))))
1399 #'sb
!vm
:saetp-specifier
1400 sb
!vm
:*specialized-array-element-type-properties
*)))))
1401 ;; Only arrays have fill-pointers, but vectors have their length
1402 ;; parameter in the same place.
1403 (setf (%array-fill-pointer vector
) new-length
)
1406 (defun shrink-vector (vector new-length
)
1407 (declare (vector vector
))
1409 ((eq (length vector
) new-length
)
1411 ((array-has-fill-pointer-p vector
)
1412 (setf (%array-fill-pointer vector
) new-length
)
1414 (t (subseq vector
0 new-length
))))
1416 ;;; BIG THREAD SAFETY NOTE
1418 ;;; ADJUST-ARRAY/SET-ARRAY-HEADER, and its callees are very
1419 ;;; thread unsafe. They are nonatomic, and can mess with parallel
1420 ;;; code using the same arrays.
1422 ;;; A likely seeming fix is an additional level of indirection:
1423 ;;; ARRAY-HEADER -> ARRAY-INFO -> ... where ARRAY-HEADER would
1424 ;;; hold nothing but the pointer to ARRAY-INFO, and ARRAY-INFO
1425 ;;; would hold everything ARRAY-HEADER now holds. This allows
1426 ;;; consing up a new ARRAY-INFO and replacing it atomically in
1427 ;;; the ARRAY-HEADER.
1429 ;;; %WALK-DISPLACED-ARRAY-BACKPOINTERS is an especially nasty
1430 ;;; one: not only is it needed extremely rarely, which makes
1431 ;;; any thread safety bugs involving it look like rare random
1432 ;;; corruption, but because it walks the chain *upwards*, which
1433 ;;; may violate user expectations.
1435 ;;; Fill in array header with the provided information, and return the array.
1436 (defun set-array-header (array data length fill-pointer displacement dimensions
1438 (labels ((%walk-displaced-array-backpointers
(array new-length
)
1439 (dolist (p (%array-displaced-from array
))
1440 (let ((from (weak-pointer-value p
)))
1441 (when (and from
(eq array
(%array-data from
)))
1442 (let ((requires (+ (%array-available-elements from
)
1443 (%array-displacement from
))))
1444 (unless (>= new-length requires
)
1445 ;; ANSI sayeth (ADJUST-ARRAY dictionary entry):
1447 ;; "If A is displaced to B, the consequences are unspecified if B is
1448 ;; adjusted in such a way that it no longer has enough elements to
1451 ;; since we're hanging on a weak pointer here, we can't signal an
1452 ;; error right now: the array that we're looking at might be
1453 ;; garbage. Instead, we set all dimensions to zero so that next
1454 ;; safe access to the displaced array will trap. Additionally, we
1455 ;; save the original dimensions, so we can signal a more
1456 ;; understandable error when the time comes.
1457 (%walk-displaced-array-backpointers from
0)
1458 (setf (%array-fill-pointer from
) 0
1459 (%array-available-elements from
) 0
1460 (%array-displaced-p from
) (array-dimensions array
))
1461 (dotimes (i (%array-rank from
))
1462 (setf (%array-dimension from i
) 0)))))))))
1464 (setf (%array-displaced-from array
) nil
)
1465 (%walk-displaced-array-backpointers array length
))
1467 (%save-displaced-array-backpointer array data
))
1468 (setf (%array-data array
) data
)
1469 (setf (%array-available-elements array
) length
)
1471 (setf (%array-fill-pointer array
) fill-pointer
)
1472 (setf (%array-fill-pointer-p array
) t
))
1474 (setf (%array-fill-pointer array
) length
)
1475 (setf (%array-fill-pointer-p array
) nil
)))
1476 (setf (%array-displacement array
) displacement
)
1477 (if (listp dimensions
)
1478 (dotimes (axis (array-rank array
))
1479 (declare (type index axis
))
1480 (setf (%array-dimension array axis
) (pop dimensions
)))
1481 (setf (%array-dimension array
0) dimensions
))
1482 (setf (%array-displaced-p array
) displacedp
)
1485 ;;; User visible extension
1486 (declaim (ftype (sfunction (array) (simple-array * (*))) array-storage-vector
))
1487 (defun array-storage-vector (array)
1488 "Returns the underlying storage vector of ARRAY, which must be a non-displaced array.
1490 In SBCL, if ARRAY is a of type \(SIMPLE-ARRAY * \(*)), it is its own storage
1491 vector. Multidimensional arrays, arrays with fill pointers, and adjustable
1492 arrays have an underlying storage vector with the same ARRAY-ELEMENT-TYPE as
1493 ARRAY, which this function returns.
1495 Important note: the underlying vector is an implementation detail. Even though
1496 this function exposes it, changes in the implementation may cause this
1497 function to be removed without further warning."
1498 ;; KLUDGE: Without TRULY-THE the system is not smart enough to figure out that
1499 ;; the return value is always of the known type.
1500 (truly-the (simple-array * (*))
1501 (cond ((not (array-header-p array
))
1503 ((%array-displaced-p array
)
1504 (error "~S cannot be used with displaced arrays. Use ~S instead."
1505 'array-storage-vector
'array-displacement
))
1507 (%array-data array
)))))
1510 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
1512 ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
1513 ;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
1514 ;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
1515 ;;; is a displaced offset to be added to computed indices of OLD-DATA.
1516 (defun zap-array-data (old-data old-dims offset new-data new-dims new-length
1517 element-type initial-element initial-element-p
)
1518 (declare (list old-dims new-dims
)
1519 (fixnum new-length
))
1520 ;; OLD-DIMS comes from array-dimensions, which returns a fresh list
1521 ;; at least in SBCL.
1522 ;; NEW-DIMS comes from the user.
1523 (setf old-dims
(nreverse old-dims
)
1524 new-dims
(reverse new-dims
))
1525 (cond ((eq old-data new-data
)
1526 ;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and
1527 ;; INITIAL-ELEMENT-P are used when OLD-DATA and NEW-DATA are
1528 ;; EQ; in this case, a temporary must be used and filled
1529 ;; appropriately. specified initial-element.
1530 ;; FIXME: transforming this TYPEP to someting a bit faster
1531 ;; would be a win...
1532 (unless (or (not initial-element-p
)
1533 (typep initial-element element-type
))
1534 (error "~S can't be used to initialize an array of type ~
1535 ~/sb!impl:print-type-specifier/."
1536 initial-element element-type
))
1537 (let ((temp (if initial-element-p
1538 (make-array new-length
:initial-element initial-element
)
1539 (make-array new-length
))))
1540 (declare (simple-vector temp
))
1541 (zap-array-data-aux old-data old-dims offset temp new-dims
)
1542 (dotimes (i new-length
)
1543 (setf (aref new-data i
) (aref temp i
)))
1544 ;; Kill the temporary vector to prevent garbage retention.
1545 (%shrink-vector temp
0)))
1547 ;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
1548 ;; already been filled with any
1549 (zap-array-data-aux old-data old-dims offset new-data new-dims
))))
1551 (defun zap-array-data-aux (old-data old-dims offset new-data new-dims
)
1552 (declare (fixnum offset
))
1553 (let ((limits (mapcar (lambda (x y
)
1554 (declare (fixnum x y
))
1555 (1- (the fixnum
(min x y
))))
1556 old-dims new-dims
)))
1557 (macrolet ((bump-index-list (index limits
)
1558 `(do ((subscripts ,index
(cdr subscripts
))
1559 (limits ,limits
(cdr limits
)))
1560 ((null subscripts
) :eof
)
1561 (cond ((< (the fixnum
(car subscripts
))
1562 (the fixnum
(car limits
)))
1564 (1+ (the fixnum
(car subscripts
))))
1566 (t (rplaca subscripts
0))))))
1567 (do ((index (make-list (length old-dims
) :initial-element
0)
1568 (bump-index-list index limits
)))
1570 (setf (aref new-data
(row-major-index-from-dims index new-dims
))
1572 (+ (the fixnum
(row-major-index-from-dims index old-dims
))
1575 ;;; Figure out the row-major-order index of an array reference from a
1576 ;;; list of subscripts and a list of dimensions. This is for internal
1577 ;;; calls only, and the subscripts and dim-list variables are assumed
1578 ;;; to be reversed from what the user supplied.
1579 (defun row-major-index-from-dims (rev-subscripts rev-dim-list
)
1580 (do ((rev-subscripts rev-subscripts
(cdr rev-subscripts
))
1581 (rev-dim-list rev-dim-list
(cdr rev-dim-list
))
1584 ((null rev-dim-list
) result
)
1585 (declare (fixnum chunk-size result
))
1586 (setq result
(+ result
1587 (the fixnum
(* (the fixnum
(car rev-subscripts
))
1589 (setq chunk-size
(* chunk-size
(the fixnum
(car rev-dim-list
))))))
1593 (defun bit-array-same-dimensions-p (array1 array2
)
1594 (declare (type (array bit
) array1 array2
))
1595 (let ((rank (array-rank array1
)))
1596 (and (= rank
(array-rank array2
))
1598 (= (array-total-size array1
)
1599 (array-total-size array2
))
1600 (dotimes (index rank t
)
1601 (when (/= (%array-dimension array1 index
)
1602 (%array-dimension array2 index
))
1605 (defun copy-array-header (array)
1606 (let* ((rank (%array-rank array
))
1607 (size (%array-available-elements array
))
1608 (result (make-array-header sb
!vm
:simple-array-widetag
1610 (loop for i below rank
1611 do
(%set-array-dimension result i
1612 (%array-dimension array i
)))
1613 (setf (%array-displaced-from result
) nil
1614 (%array-displaced-p result
) nil
1615 (%array-fill-pointer-p result
) nil
1616 (%array-fill-pointer result
) size
1617 (%array-available-elements result
) size
)
1620 (defun pick-result-array (result-bit-array bit-array-1
)
1621 (case result-bit-array
1624 (if (vectorp bit-array-1
)
1625 (make-array (array-total-size bit-array-1
)
1628 (let ((header (copy-array-header bit-array-1
)))
1629 (setf (%array-data header
)
1630 (make-array (%array-available-elements bit-array-1
)
1632 :initial-element
0))
1635 (unless (bit-array-same-dimensions-p bit-array-1
1637 (error "~S and ~S don't have the same dimensions."
1638 bit-array-1 result-bit-array
))
1641 (defmacro def-bit-array-op
(name function
)
1642 `(defun ,name
(bit-array-1 bit-array-2
&optional result-bit-array
)
1644 "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
1645 BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
1646 If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
1647 RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
1648 All the arrays must have the same rank and dimensions."
1649 (symbol-name function
))
1650 (declare (type (array bit
) bit-array-1 bit-array-2
)
1651 (type (or (array bit
) (member t nil
)) result-bit-array
))
1652 (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2
)
1653 (error "~S and ~S don't have the same dimensions."
1654 bit-array-1 bit-array-2
))
1655 (let ((result-bit-array (pick-result-array result-bit-array bit-array-1
)))
1656 (if (and (simple-bit-vector-p bit-array-1
)
1657 (simple-bit-vector-p bit-array-2
)
1658 (simple-bit-vector-p result-bit-array
))
1659 (locally (declare (optimize (speed 3) (safety 0)))
1660 (,name bit-array-1 bit-array-2 result-bit-array
))
1661 (with-array-data ((data1 bit-array-1
) (start1) (end1))
1662 (with-array-data ((data2 bit-array-2
) (start2) (end2))
1663 (with-array-data ((data3 result-bit-array
) (start3) (end3))
1664 (if (and (zerop start1
)
1667 (= (length data1
) end1
)
1668 (= (length data2
) end2
)
1669 (= (length data3
) end3
))
1670 (locally (declare (optimize (speed 3) (safety 0)))
1671 (,name data1 data2 data3
))
1672 (do ((index-1 start1
(1+ index-1
))
1673 (index-2 start2
(1+ index-2
))
1674 (index-3 start3
(1+ index-3
)))
1676 (declare (type index index-1 index-2 index-3
))
1677 (setf (sbit data3 index-3
)
1678 (logand (,function
(sbit data1 index-1
)
1679 (sbit data2 index-2
))
1681 result-bit-array
)))))))
1683 (def-bit-array-op bit-and logand
)
1684 (def-bit-array-op bit-ior logior
)
1685 (def-bit-array-op bit-xor logxor
)
1686 (def-bit-array-op bit-eqv logeqv
)
1687 (def-bit-array-op bit-nand lognand
)
1688 (def-bit-array-op bit-nor lognor
)
1689 (def-bit-array-op bit-andc1 logandc1
)
1690 (def-bit-array-op bit-andc2 logandc2
)
1691 (def-bit-array-op bit-orc1 logorc1
)
1692 (def-bit-array-op bit-orc2 logorc2
)
1694 (defun bit-not (bit-array &optional result-bit-array
)
1695 "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
1696 putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
1697 BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
1698 created. Both arrays must have the same rank and dimensions."
1699 (declare (type (array bit
) bit-array
)
1700 (type (or (array bit
) (member t nil
)) result-bit-array
))
1701 (let ((result-bit-array (pick-result-array result-bit-array bit-array
)))
1702 (if (and (simple-bit-vector-p bit-array
)
1703 (simple-bit-vector-p result-bit-array
))
1704 (locally (declare (optimize (speed 3) (safety 0)))
1705 (bit-not bit-array result-bit-array
))
1706 (with-array-data ((src bit-array
) (src-start) (src-end))
1707 (with-array-data ((dst result-bit-array
) (dst-start) (dst-end))
1708 (if (and (zerop src-start
)
1710 (= src-end
(length src
))
1711 (= dst-end
(length dst
)))
1712 (locally (declare (optimize (speed 3) (safety 0)))
1714 (do ((src-index src-start
(1+ src-index
))
1715 (dst-index dst-start
(1+ dst-index
)))
1716 ((>= dst-index dst-end
))
1717 (declare (type index src-index dst-index
))
1718 (setf (sbit dst dst-index
)
1719 (logxor (sbit src src-index
) 1))))
1720 result-bit-array
)))))
1722 ;;;; array type dispatching
1724 ;;; Given DISPATCH-FOO as the DISPATCH-NAME argument (unevaluated),
1725 ;;; defines the functions
1727 ;;; DISPATCH-FOO/SIMPLE-BASE-STRING
1728 ;;; DISPATCH-FOO/SIMPLE-CHARACTER-STRING
1729 ;;; DISPATCH-FOO/SIMPLE-ARRAY-SINGLE-FLOAT
1732 ;;; PARAMS are the function parameters in the definition of each
1733 ;;; specializer function. The array being specialized must be the
1734 ;;; first parameter in PARAMS. A type declaration for this parameter
1735 ;;; is automatically inserted into the body of each function.
1737 ;;; The dispatch table %%FOO-FUNS%% is defined and populated by these
1738 ;;; functions. The table is padded by the function
1739 ;;; HAIRY-FOO-DISPATCH-ERROR, also defined by DEFINE-ARRAY-DISPATCH.
1741 ;;; Finally, the DISPATCH-FOO macro is defined which does the actual
1742 ;;; dispatching when called. It expects arguments that match PARAMS.
1744 (defmacro !define-array-dispatch
(dispatch-name params
&body body
)
1745 (let ((table-name (symbolicate "%%" dispatch-name
"-FUNS%%"))
1746 (error-name (symbolicate "HAIRY-" dispatch-name
"-ERROR")))
1748 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1749 (defun ,error-name
(&rest args
)
1752 :expected-type
'(simple-array * (*)))))
1753 (!defglobal
,table-name
,(make-array (1+ sb
!vm
:widetag-mask
)))
1755 ;; This SUBSTITUTE call happens ** after ** all the SETFs below it.
1756 ;; DEFGLOBAL's initial value is dumped by genesis as a vector filled
1757 ;; with 0 (it would not work if the vector held function objects).
1758 ;; Then the SETFs happen, as cold-load can process %SVSET, which
1759 ;; is great, because it means that hairy sequence dispatch may occur
1760 ;; as early as you'd like in cold-init without regard to file order.
1761 ;; However when it comes to actually executing the toplevel forms
1762 ;; that were compiled into thunks of target code to invoke,
1763 ;; all the known good entries must be preserved.
1764 (substitute #',error-name
0 ,table-name
)
1766 ,@(loop for info across sb
!vm
:*specialized-array-element-type-properties
*
1767 for typecode
= (sb!vm
:saetp-typecode info
)
1768 for specifier
= (sb!vm
:saetp-specifier info
)
1769 for primitive-type-name
= (sb!vm
:saetp-primitive-type-name info
)
1770 collect
(let ((fun-name (symbolicate (string dispatch-name
)
1771 "/" primitive-type-name
)))
1773 (defun ,fun-name
,params
1774 (declare (type (simple-array ,specifier
(*))
1777 (setf (svref ,table-name
,typecode
) #',fun-name
))))
1778 (defmacro ,dispatch-name
(&rest args
)
1779 (check-type (first args
) symbol
)
1780 (let ((tag (gensym "TAG")))
1784 (when (sb!vm
::%other-pointer-p
,(first args
))
1785 (setf ,tag
(%other-pointer-widetag
,(first args
))))
1786 (svref ,',table-name
,tag
)))
1789 (defun sb!kernel
::check-array-shape
(array dimensions
)
1790 (when (let ((dimensions dimensions
))
1791 (dotimes (i (array-rank array
))
1792 (unless (eql (array-dimension array i
) (pop dimensions
))
1794 (error "malformed :INITIAL-CONTENTS: ~S should have dimensions ~S"
1795 (make-array dimensions
:displaced-to
(%array-data array
)
1796 :element-type
(array-element-type array
))
1797 (array-dimensions array
)))