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.
14 (declaim (inline adjustable-array-p
17 ;;;; miscellaneous accessor functions
19 ;;; These functions are only needed by the interpreter, 'cause the
20 ;;; compiler inlines them.
21 (macrolet ((def (name)
25 (defun (setf ,name
) (value array
)
26 (setf (,name array
) value
)))))
27 (def %array-fill-pointer
)
28 (def %array-available-elements
)
30 (def %array-displacement
)
31 (def %array-displaced-p
)
32 (def %array-displaced-from
))
34 (defun %array-rank
(array)
37 (defun %array-dimension
(array axis
)
38 (%array-dimension array axis
))
40 (defun %check-bound
(array bound index
)
41 (declare (type index bound
)
43 (%check-bound array bound index
))
45 (defun check-bound (array bound index
)
46 (declare (type index bound
)
48 (%check-bound array bound index
)
51 (defun %with-array-data
/fp
(array start end
)
52 (%with-array-data-macro array start end
:check-bounds t
:check-fill-pointer t
))
54 (defun %with-array-data
(array start end
)
55 (%with-array-data-macro array start end
:check-bounds t
:array-header-p t
))
57 (defun %data-vector-and-index
(array index
)
58 (if (array-header-p array
)
59 (multiple-value-bind (vector index
)
60 (%with-array-data array index nil
)
61 (values vector index
))
62 (values (truly-the (simple-array * (*)) array
) index
)))
66 (defun %integer-vector-widetag-and-n-bits-shift
(signed high
)
68 #.
(let ((map (make-array (1+ n-word-bits
))))
69 (loop for saetp across
70 (reverse *specialized-array-element-type-properties
*)
71 for ctype
= (saetp-ctype saetp
)
72 when
(and (numeric-type-p ctype
)
73 (eq (numeric-type-class ctype
) 'integer
)
74 (zerop (numeric-type-low ctype
)))
75 do
(fill map
(cons (saetp-typecode saetp
)
76 (saetp-n-bits-shift saetp
))
77 :end
(1+ (integer-length (numeric-type-high ctype
)))))
80 #.
(let ((map (make-array (1+ n-word-bits
))))
81 (loop for saetp across
82 (reverse *specialized-array-element-type-properties
*)
83 for ctype
= (saetp-ctype saetp
)
84 when
(and (numeric-type-p ctype
)
85 (eq (numeric-type-class ctype
) 'integer
)
86 (minusp (numeric-type-low ctype
)))
87 do
(fill map
(cons (saetp-typecode saetp
)
88 (saetp-n-bits-shift saetp
))
89 :end
(+ (integer-length (numeric-type-high ctype
)) 2)))
91 (cond ((> high n-word-bits
)
92 (values #.simple-vector-widetag
93 #.
(1- (integer-length n-word-bits
))))
95 (let ((x (aref signed-table high
)))
96 (values (car x
) (cdr x
))))
98 (let ((x (aref unsigned-table high
)))
99 (values (car x
) (cdr x
)))))))
101 ;;; This is a bit complicated, but calling subtypep over all
102 ;;; specialized types is exceedingly slow
103 (defun %vector-widetag-and-n-bits-shift
(type)
104 (macrolet ((with-parameters ((arg-type &key intervals
)
105 (&rest args
) &body body
)
106 (let ((type-sym (gensym)))
107 `(let (,@(loop for arg in args
109 (declare (ignorable ,@args
))
111 (let ((,type-sym
(cdr type
)))
113 ,@(loop for arg in args
115 `(cond ((consp ,type-sym
)
116 (let ((value (pop ,type-sym
)))
117 (if (or (eq value
'*)
118 (typep value
',arg-type
)
134 `(go fastidiously-parse
))
136 (let ((value (symbol-value widetag
)))
140 *specialized-array-element-type-properties
*
141 :key
#'saetp-typecode
))))))
142 (flet ((integer-interval-widetag (low high
)
144 (%integer-vector-widetag-and-n-bits-shift
146 (1+ (max (integer-length low
) (integer-length high
))))
147 (%integer-vector-widetag-and-n-bits-shift
149 (max (integer-length low
) (integer-length high
))))))
152 ((consp (consp type
))
153 (type-name (if consp
(car type
) type
))
154 ((widetag n-bits-shift
)
159 (result simple-vector-widetag
))
160 ((base-char standard-char
#-sb-unicode character
)
163 (result simple-base-string-widetag
))
165 ((character extended-char
)
168 (result simple-character-string-widetag
))
172 (result simple-bit-vector-widetag
))
176 (result simple-array-fixnum-widetag
))
178 (with-parameters ((integer 1)) (high)
180 (result simple-vector-widetag
)
181 (%integer-vector-widetag-and-n-bits-shift nil high
))))
183 (with-parameters ((integer 1)) (high)
185 (result simple-vector-widetag
)
186 (%integer-vector-widetag-and-n-bits-shift t high
))))
188 (with-parameters (double-float :intervals t
) (low high
)
189 (if (and (not (eq low
'*))
191 (if (or (consp low
) (consp high
))
192 (>= (type-bound-number low
) (type-bound-number high
))
194 (result simple-array-nil-widetag
)
195 (result simple-array-double-float-widetag
))))
197 (with-parameters (single-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 simple-array-nil-widetag
)
204 (result simple-array-single-float-widetag
))))
206 (if (and (consp type
)
209 (typep (cadr type
) '(integer 1)))
210 (%integer-vector-widetag-and-n-bits-shift
211 nil
(integer-length (1- (cadr type
))))
215 (with-parameters (long-float :intervals t
) (low high
)
216 (if (and (not (eq low
'*))
218 (if (or (consp low
) (consp high
))
219 (>= (type-bound-number low
) (type-bound-number high
))
221 (result simple-array-nil-widetag
)
222 (result simple-array-long-float-widetag
))))
224 (with-parameters (integer :intervals t
) (low high
)
225 (let ((low (if (consp low
)
228 (high (if (consp high
)
231 (cond ((or (eq high
'*)
233 (result simple-vector-widetag
))
235 (result simple-array-nil-widetag
))
237 (integer-interval-widetag low high
))))))
239 (with-parameters (t) (subtype)
241 (result simple-vector-widetag
)
242 (let ((ctype (specifier-type type
)))
243 (cond ((eq ctype
*empty-type
*)
244 (result simple-array-nil-widetag
))
245 ((union-type-p ctype
)
246 (cond ((csubtypep ctype
(specifier-type '(complex double-float
)))
248 simple-array-complex-double-float-widetag
))
249 ((csubtypep ctype
(specifier-type '(complex single-float
)))
251 simple-array-complex-single-float-widetag
))
253 ((csubtypep ctype
(specifier-type '(complex long-float
)))
255 simple-array-complex-long-float-widetag
))
257 (result simple-vector-widetag
))))
259 (case (numeric-type-format ctype
)
262 simple-array-complex-double-float-widetag
))
265 simple-array-complex-single-float-widetag
))
269 simple-array-complex-long-float-widetag
))
271 (result simple-vector-widetag
)))))))))
273 (result simple-array-nil-widetag
))
275 (go fastidiously-parse
)))))
276 (return-from %vector-widetag-and-n-bits-shift
277 (values widetag n-bits-shift
)))
279 ;; Do things the hard way after falling through the tagbody.
280 (let* ((ctype (type-or-nil-if-unknown type
))
282 (sb-kernel::replace-hairy-type ctype
))))
284 (null (result simple-vector-widetag
))
286 (let ((types (union-type-types ctype
)))
287 (cond ((not (every #'numeric-type-p types
))
288 (result simple-vector-widetag
))
289 ((csubtypep ctype
(specifier-type 'integer
))
291 (integer-interval-widetag
293 (or (numeric-type-low x
)
294 (return (result simple-vector-widetag
)))))
295 (reduce #'min types
:key
#'low
))
297 (or (numeric-type-high x
)
298 (return (result simple-vector-widetag
)))))
299 (reduce #'max types
:key
#'high
)))))
300 ((csubtypep ctype
(specifier-type 'double-float
))
301 (result simple-array-double-float-widetag
))
302 ((csubtypep ctype
(specifier-type 'single-float
))
303 (result simple-array-single-float-widetag
))
305 ((csubtypep ctype
(specifier-type 'long-float
))
306 (result simple-array-long-float-widetag
))
307 ((csubtypep ctype
(specifier-type 'complex-double-float
))
308 (result simple-array-complex-double-float-widetag
))
309 ((csubtypep ctype
(specifier-type 'complex-single-float
))
310 (result simple-array-complex-single-float-widetag
))
312 (result simple-vector-widetag
)))))
314 (let ((types (intersection-type-types ctype
)))
315 (loop for type in types
316 unless
(hairy-type-p type
)
317 return
(%vector-widetag-and-n-bits-shift
(type-specifier type
)))))
319 #-sb-unicode
(result simple-base-string-widetag
)
321 (if (loop for
(start . end
)
322 in
(character-set-type-pairs ctype
)
323 always
(and (< start base-char-code-limit
)
324 (< end base-char-code-limit
)))
325 (result simple-base-string-widetag
)
326 (result simple-character-string-widetag
)))
328 (let ((expansion (type-specifier ctype
)))
329 (if (equal expansion type
)
330 (result simple-vector-widetag
)
331 (%vector-widetag-and-n-bits-shift expansion
)))))))))
333 (defun %complex-vector-widetag
(widetag)
334 (macrolet ((make-case ()
336 ,@(loop for saetp across
*specialized-array-element-type-properties
*
337 for complex
= (saetp-complex-typecode saetp
)
339 collect
(list (saetp-typecode saetp
) complex
))
341 #.complex-vector-widetag
))))
344 (declaim (inline vector-length-in-words
))
345 (defun vector-length-in-words (length n-bits-shift
)
346 (declare (type (integer 0 7) n-bits-shift
))
347 (let ((mask (ash (1- n-word-bits
) (- n-bits-shift
)))
348 (shift (- n-bits-shift
349 (1- (integer-length n-word-bits
)))))
350 (ash (+ length mask
) shift
)))
352 ;;; N-BITS-SHIFT is the shift amount needed to turn LENGTH into array-size-in-bits,
353 ;;; i.e. log(2,bits-per-elt)
354 (defun allocate-vector-with-widetag (#+ubsan poisoned widetag length n-bits-shift
)
355 (declare (type (unsigned-byte 8) widetag
)
357 (let* ( ;; KLUDGE: add SAETP-N-PAD-ELEMENTS "by hand" since there is
358 ;; but a single case involving it now.
359 (full-length (+ length
(if (= widetag simple-base-string-widetag
) 1 0)))
360 ;; Be careful not to allocate backing storage for element type NIL.
361 ;; Both it and type BIT have N-BITS-SHIFT = 0, so the determination
362 ;; of true size can't be left up to VECTOR-LENGTH-IN-WORDS.
363 ;; VECTOR-LENGTH-IN-WORDS potentially returns a machine-word-sized
364 ;; integer, so it doesn't match the primitive type restriction of
365 ;; POSITIVE-FIXNUM for the last argument of the vector alloc vops.
367 (if (/= widetag simple-array-nil-widetag
)
368 (vector-length-in-words full-length n-bits-shift
)
370 #+ubsan
(if poisoned
; first arg to allocate-vector must be a constant
371 (allocate-vector t widetag length nwords
)
372 (allocate-vector nil widetag length nwords
))
373 #-ubsan
(allocate-vector widetag length nwords
)))
375 (declaim (ftype (sfunction (array) (integer 128 255)) array-underlying-widetag
))
376 (defun array-underlying-widetag (array)
377 (macrolet ((generate-table ()
378 (macrolet ((to-index (x) `(ash ,x -
2)))
379 (let ((table (sb-xc:make-array
64 :initial-element
0
380 :element-type
'(unsigned-byte 8))))
381 (dovector (saetp *specialized-array-element-type-properties
*)
382 (let* ((typecode (saetp-typecode saetp
))
383 (complex-typecode (saetp-complex-typecode saetp
)))
384 (setf (aref table
(to-index typecode
)) typecode
)
385 (when complex-typecode
386 (setf (aref table
(to-index complex-typecode
)) typecode
))))
387 (setf (aref table
(to-index simple-array-widetag
)) 0
388 (aref table
(to-index complex-vector-widetag
)) 0
389 (aref table
(to-index complex-array-widetag
)) 0)
391 (to-index (x) `(ash ,x -
2)))
392 (named-let recurse
((x array
))
393 (let ((result (aref (generate-table)
394 (to-index (%other-pointer-widetag x
)))))
396 (recurse (%array-data x
))
397 (truly-the (integer 128 255) result
))))))
399 (declaim (ftype (sfunction (array) (values (integer 128 255) (unsigned-byte 8)))
400 array-underlying-widetag-and-shift
))
401 (defun array-underlying-widetag-and-shift (array)
402 (declare (explicit-check))
403 (let ((widetag (array-underlying-widetag array
)))
405 (truly-the (unsigned-byte 8)
406 (aref %%simple-array-n-bits-shifts%% widetag
)))))
408 ;; Complain in various ways about wrong MAKE-ARRAY and ADJUST-ARRAY arguments,
409 ;; returning the two initialization arguments needed for DATA-VECTOR-FROM-INITS.
410 ;; This is an unhygienic macro which would be a MACROLET other than for
411 ;; doing so would entail moving toplevel defuns around for no good reason.
412 (defmacro check-make-array-initargs
(displaceable &optional element-type size
)
413 `(cond ,@(when displaceable
415 (when (or element-p contents-p
)
416 (if (and element-p contents-p
)
417 (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
418 may be specified with the :DISPLACED-TO option")
419 (error "~S may not be specified with the :DISPLACED-TO option"
420 (if element-p
:initial-element
:initial-contents
))))
421 (unless (= (array-underlying-widetag displaced-to
) widetag
)
422 ;; Require exact match on upgraded type (lp#1331299)
423 (error "Can't displace an array of type ~/sb-impl:print-type-specifier/ ~
424 into another of type ~/sb-impl:print-type-specifier/"
425 ,element-type
(array-element-type displaced-to
)))
426 (when (< (array-total-size displaced-to
)
427 (+ displaced-index-offset
,size
))
428 (error "The :DISPLACED-TO array is too small.")))
430 (error "Can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))))
431 ((and element-p contents-p
)
432 (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
433 (element-p (values :initial-element initial-element
))
434 (contents-p (values :initial-contents initial-contents
))))
435 (defmacro make-array-bad-fill-pointer
(actual max adjective
)
436 ;; There was a comment implying that this should be TYPE-ERROR
437 ;; but I don't see that as a spec requirement.
438 `(error "Can't supply a value for :FILL-POINTER (~S) that is larger ~
439 than the~A size of the vector (~S)" ,actual
,adjective
,max
))
441 (declaim (inline %save-displaced-array-backpointer
442 %save-displaced-new-array-backpointer
))
443 (defun %save-displaced-array-backpointer
(array data
)
444 (flet ((purge (pointers)
445 (remove-if (lambda (value)
446 (or (not value
) (eq array value
)))
448 :key
#'weak-pointer-value
)))
449 (let ((old-data (%array-data array
)))
450 (unless (eq old-data data
)
451 ;; Add backpointer to the new data vector if it has a header.
452 (when (array-header-p data
)
453 (setf (%array-displaced-from data
)
454 (cons (make-weak-pointer array
)
455 (purge (%array-displaced-from data
)))))
456 ;; Remove old backpointer, if any.
457 (when (array-header-p old-data
)
458 (setf (%array-displaced-from old-data
)
459 (purge (%array-displaced-from old-data
))))))))
461 (defun %save-displaced-new-array-backpointer
(array data
)
462 (flet ((purge (pointers)
463 (remove-if-not #'weak-pointer-value pointers
)))
464 (setf (%array-displaced-from data
)
465 (cons (make-weak-pointer array
)
466 (purge (%array-displaced-from data
))))))
468 (defmacro populate-dimensions
(header list-or-index rank
)
469 `(if (listp ,list-or-index
)
470 (let ((dims ,list-or-index
))
471 (dotimes (axis ,rank
)
472 (declare ((integer 0 ,array-rank-limit
) axis
))
473 (%set-array-dimension
,header axis
(pop dims
))))
474 (%set-array-dimension
,header
0 ,list-or-index
)))
476 (declaim (inline rank-and-total-size-from-dims
))
477 (defun rank-and-total-size-from-dims (dims)
478 (cond ((not (listp dims
)) (values 1 (the index dims
)))
479 ((not dims
) (values 0 1))
480 (t (let ((rank 1) (product (car dims
)))
481 (declare (%array-rank rank
) (index product
))
482 (dolist (dim (cdr dims
) (values rank product
))
483 (setq product
(* product
(the index dim
)))
486 (declaim (inline widetag-
>element-type
))
487 (defun widetag->element-type
(widetag)
488 (svref #.
(let ((a (make-array 32 :initial-element
0)))
489 (dovector (saetp *specialized-array-element-type-properties
* a
)
490 (let ((tag (saetp-typecode saetp
)))
491 (setf (aref a
(ash (- tag
#x80
) -
2)) (saetp-specifier saetp
)))))
492 (- (ash widetag -
2) 32)))
494 (defun initial-contents-error (content-length length
)
495 (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
496 the vector length is ~W."
497 content-length length
))
499 ;;; Widetag is the widetag of the underlying vector,
500 ;;; it'll be the same as the resulting array widetag only for simple vectors
501 (defun %make-array
(dimensions widetag n-bits
504 (initial-element nil element-p
)
505 (initial-contents nil contents-p
)
506 adjustable fill-pointer
508 (displaced-index-offset 0 offset-p
))
509 (declare (ignore element-type
))
510 (binding* (((array-rank total-size
) (rank-and-total-size-from-dims dimensions
))
511 ((initialize initial-data
)
512 ;; element-type might not be supplied, but widetag->element is always good
513 (check-make-array-initargs t
(widetag->element-type widetag
) total-size
))
514 (simple (and (null fill-pointer
)
516 (null displaced-to
))))
518 (cond ((and simple
(= array-rank
1))
519 (let ((vector ; a (SIMPLE-ARRAY * (*))
520 (allocate-vector-with-widetag #+ubsan
(not (or element-p contents-p
))
521 widetag total-size n-bits
)))
522 ;; presence of at most one :INITIAL-thing keyword was ensured above
524 (fill vector initial-element
))
526 (let ((content-length (length initial-contents
)))
527 (unless (= total-size content-length
)
528 (initial-contents-error content-length total-size
)))
529 (replace vector initial-contents
))
532 ;; store the function which bears responsibility for creation of this
533 ;; array in case we need to blame it for not initializing.
534 (set-vector-extra-data (if (= widetag simple-vector-widetag
) ; no shadow bits.
535 vector
; use the LENGTH slot directly
536 (vector-extra-data vector
))
537 (ash (sap-ref-word (current-fp) n-word-bytes
) 3)) ; XXX: magic
538 (cond ((= widetag simple-vector-widetag
)
539 (fill vector
(%make-lisp-obj unwritten-vector-element-marker
)))
540 ((array-may-contain-random-bits-p widetag
)
541 ;; Leave the last word alone for base-string,
542 ;; in case the mandatory trailing null is part of a data word.
543 (dotimes (i (- (vector-length-in-words total-size n-bits
)
544 (if (= widetag simple-base-string-widetag
) 1 0)))
545 (setf (%vector-raw-bits vector i
) sb-ext
:most-positive-word
))))))
548 ;; it's non-simple or multidimensional, or both.
550 (unless (= array-rank
1)
551 (error "Only vectors can have fill pointers."))
552 (when (and (integerp fill-pointer
) (> fill-pointer total-size
))
553 (make-array-bad-fill-pointer fill-pointer total-size
"")))
554 (let* ((data (or displaced-to
555 (data-vector-from-inits dimensions total-size widetag n-bits
556 initialize initial-data
)))
557 (array (make-array-header
558 (cond ((= array-rank
1)
559 (%complex-vector-widetag widetag
))
560 (simple simple-array-widetag
)
561 (t complex-array-widetag
))
564 (logior-array-flags array
+array-fill-pointer-p
+)
565 (setf (%array-fill-pointer array
)
566 (if (eq fill-pointer t
) total-size fill-pointer
)))
568 (reset-array-flags array
+array-fill-pointer-p
+)
569 (setf (%array-fill-pointer array
) total-size
)))
570 (setf (%array-available-elements array
) total-size
)
571 (setf (%array-data array
) data
)
572 (setf (%array-displaced-from array
) nil
)
574 (setf (%array-displacement array
) (or displaced-index-offset
0))
575 (setf (%array-displaced-p array
) t
)
576 (when (adjustable-array-p data
)
577 (%save-displaced-new-array-backpointer array data
)))
579 (setf (%array-displaced-p array
) nil
)))
580 (populate-dimensions array dimensions array-rank
)
583 (defun make-array (dimensions &rest args
584 &key
(element-type t
)
585 initial-element initial-contents
589 displaced-index-offset
)
590 (declare (ignore initial-element
591 initial-contents adjustable
592 fill-pointer displaced-to displaced-index-offset
))
593 (declare (explicit-check))
594 (multiple-value-bind (widetag shift
) (%vector-widetag-and-n-bits-shift element-type
)
595 (apply #'%make-array dimensions widetag shift args
)))
597 (defun make-static-vector (length &key
598 (element-type '(unsigned-byte 8))
599 (initial-contents nil contents-p
)
600 (initial-element nil element-p
))
601 "Allocate vector of LENGTH elements in static space. Only allocation
602 of specialized arrays is supported."
603 ;; STEP 1: check inputs fully
605 ;; This way of doing explicit checks before the vector is allocated
606 ;; is expensive, but probably worth the trouble as once we've allocated
607 ;; the vector we have no way to get rid of it anymore...
608 (when (eq t
(upgraded-array-element-type element-type
))
609 (error "Static arrays of type ~/sb-impl:print-type-specifier/ not supported."
611 (check-make-array-initargs nil
) ; for effect
613 (unless (= length
(length initial-contents
))
614 (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
615 vector length is ~W."
616 (length initial-contents
)
618 (unless (every (lambda (x) (typep x element-type
)) initial-contents
)
619 (error ":INITIAL-CONTENTS contains elements not of type ~
620 ~/sb-impl:print-type-specifier/."
623 (unless (typep initial-element element-type
)
624 (error ":INITIAL-ELEMENT ~S is not of type ~
625 ~/sb-impl:print-type-specifier/."
626 initial-element element-type
)))
629 ;; Allocate and possibly initialize the vector.
630 (multiple-value-bind (type n-bits-shift
)
631 (%vector-widetag-and-n-bits-shift element-type
)
633 ;; KLUDGE: add SAETP-N-PAD-ELEMENTS "by hand" since there is
634 ;; but a single case involving it now.
635 (+ length
(if (= type simple-base-string-widetag
) 1 0)))
637 (allocate-static-vector type length
638 (vector-length-in-words full-length
641 (fill vector initial-element
))
643 (replace vector initial-contents
))
648 (defun make-static-code-vector (length initial-contents
)
649 "Allocate vector of LENGTH elements in static space. Only allocation
650 of specialized arrays is supported."
651 (let ((vector (allocate-static-code-vector simple-array-unsigned-byte-8-widetag
653 (* length n-word-bytes
))))
654 (with-pinned-objects (initial-contents)
655 (jit-memcpy (vector-sap vector
) (vector-sap initial-contents
) length
))
658 ;;; DATA-VECTOR-FROM-INITS returns a simple rank-1 array that has the
659 ;;; specified array characteristics. Dimensions is only used to pass
660 ;;; to FILL-DATA-VECTOR for error checking on the structure of
661 ;;; initial-contents.
662 (defun data-vector-from-inits (dimensions total-size widetag n-bits initialize initial-data
)
663 (declare (fixnum widetag n-bits
)) ; really just that they're non-nil
664 (let ((data (allocate-vector-with-widetag #+ubsan
(not initialize
) widetag total-size n-bits
)))
667 (fill (the vector data
) initial-data
))
669 ;; DIMENSIONS can be supplied as a list or integer now
670 (dx-let ((list-of-dims (list dimensions
))) ; ok if already a list
671 (fill-data-vector data
672 (if (listp dimensions
) dimensions list-of-dims
)
677 (defun vector (&rest objects
)
678 "Construct a SIMPLE-VECTOR from the given objects."
679 (let ((v (make-array (length objects
))))
680 (do-rest-arg ((x i
) objects
0 v
)
681 (setf (aref v i
) x
))))
684 ;;;; accessor/setter functions
686 ;;; Dispatch to an optimized routine the data vector accessors for
687 ;;; each different specialized vector type. Do dispatching by looking
688 ;;; up the widetag in the array rather than with the typecases, which
689 ;;; as of 1.0.5 compiles to a naive sequence of linear TYPEPs. Also
690 ;;; provide separate versions where bounds checking has been moved
691 ;;; from the callee to the caller, since it's much cheaper to do once
692 ;;; the type information is available. Finally, for each of these
693 ;;; routines also provide a slow path, taken for arrays that are not
694 ;;; vectors or not simple.
695 ;;; FIXME: how is this not redundant with DEFINE-ARRAY-DISPATCH?
696 ;;; Which is to say, why did DEFINE-ARRAY-DISPATCH decide to do
697 ;;; something different instead of figuring out how to unify the ways
698 ;;; that we call an element of an array accessed by widetag?
699 (macrolet ((def (name table-name
)
701 (define-load-time-global ,table-name
702 (make-array ,(1+ widetag-mask
)))
703 (declaim (type (simple-array function
(,(1+ widetag-mask
)))
705 (defmacro ,name
(array-var &optional type
)
708 (svref ,',table-name
(%other-pointer-widetag
709 (locally (declare (optimize (safety 1)))
710 (the ,type
,array-var
)))))
712 ;; Assigning TAG to 0 initially produces slightly better
713 ;; code than would be generated by the more natural expression
714 ;; (let ((tag (if (%other-ptr ...) (widetag ...) 0)))
715 ;; but either way is suboptimal. As expressed, if the array-var
716 ;; is known to satisfy %other-pointer-p, then it performs a
717 ;; move-immediate-to-register which is clobbered right away
718 ;; by a zero-extending load. A peephole pass could eliminate
719 ;; the first move as effectless. If expressed the other way,
720 ;; it would produce a jump around a jump because the compiler
721 ;; is unwilling to *unconditionally* assign 0 into a register
722 ;; to begin with. It actually wants to guard an immediate load
723 ;; when it doesn't need to, as if both consequents of the IF
724 ;; have side-effects that should not happen.
726 (when (%other-pointer-p
,array-var
)
727 (setf tag
(%other-pointer-widetag
,array-var
)))
728 (svref ,',table-name tag
))))))))
729 (def !find-data-vector-setter %%data-vector-setters%%
)
730 (def !find-data-vector-setter
/check-bounds %%data-vector-setters
/check-bounds%%
)
731 ;; Used by DO-VECTOR-DATA -- which in turn appears in DOSEQUENCE expansion,
732 ;; meaning we can have post-build dependences on this.
733 (def %find-data-vector-reffer %%data-vector-reffers%%
)
734 (def !find-data-vector-reffer
/check-bounds %%data-vector-reffers
/check-bounds%%
))
736 ;;; Like DOVECTOR, but more magical -- can't use this on host.
737 (defmacro sb-impl
::do-vector-data
((elt vector
&optional result
) &body body
)
738 (multiple-value-bind (forms decls
) (parse-body body nil
)
739 (with-unique-names (index vec start end ref
)
740 `(with-array-data ((,vec
,vector
)
743 :check-fill-pointer t
)
744 (let ((,ref
(%find-data-vector-reffer
,vec
)))
745 (declare (function ,ref
))
746 (do ((,index
,start
(1+ ,index
)))
749 ,@(sb-impl::filter-dolist-declarations decls
)
752 (let ((,elt
(funcall ,ref
,vec
,index
)))
754 (tagbody ,@forms
))))))))
756 (macrolet ((%ref
(accessor-getter extra-params
&optional vector-check
)
757 `(sb-c::%funcall-no-nargs
(,accessor-getter array
,vector-check
) array index
,@extra-params
))
758 (define (accessor-name slow-accessor-name accessor-getter
759 extra-params check-bounds
)
761 (defun ,accessor-name
(array index
,@extra-params
)
762 (declare (explicit-check))
763 (declare (optimize speed
764 ;; (SAFETY 0) is ok. All calls to
765 ;; these functions are generated by
766 ;; the compiler, so argument count
767 ;; checking isn't needed. Type checking
768 ;; is done implicitly via the widetag
771 (%ref
,accessor-getter
,extra-params
))
772 (defun ,(symbolicate 'vector- accessor-name
) (array index
,@extra-params
)
773 (declare (explicit-check)
774 (optimize speed
(safety 0)))
775 (%ref
,accessor-getter
,extra-params vector
))
776 (defun ,(symbolicate 'string- accessor-name
) (array index
,@extra-params
)
777 (declare (explicit-check)
778 (optimize speed
(safety 0)))
779 (%ref
,accessor-getter
,extra-params string
))
780 (defun ,slow-accessor-name
(array index
,@extra-params
)
781 (declare (optimize speed
(safety 0))
783 (if (not (%array-displaced-p array
))
784 ;; The reasonably quick path of non-displaced complex
786 (let ((array (%array-data array
)))
787 (%ref
,accessor-getter
,extra-params
))
788 ;; The real slow path.
792 (declare (optimize (speed 1) (safety 1)))
793 (,@check-bounds index
)))
796 (declare (ignore end
))
797 (%ref
,accessor-getter
,extra-params
)))))))
798 (define hairy-data-vector-ref slow-hairy-data-vector-ref
799 %find-data-vector-reffer
801 (define hairy-data-vector-set slow-hairy-data-vector-set
802 !find-data-vector-setter
804 (define hairy-data-vector-ref
/check-bounds
805 slow-hairy-data-vector-ref
/check-bounds
806 !find-data-vector-reffer
/check-bounds
807 nil
(check-bound array
(%array-dimension array
0)))
808 (define hairy-data-vector-set
/check-bounds
809 slow-hairy-data-vector-set
/check-bounds
810 !find-data-vector-setter
/check-bounds
811 (new-value) (check-bound array
(%array-dimension array
0))))
813 (defun hairy-ref-error (array index
&optional new-value
)
814 (declare (ignore index new-value
)
815 (optimize (sb-c:verify-arg-count
0)))
818 :expected-type
'vector
))
820 (macrolet ((define-reffer (saetp check-form
)
821 (let* ((type (saetp-specifier saetp
))
822 (atype `(simple-array ,type
(*))))
823 `(named-lambda (optimized-data-vector-ref ,type
) (vector index
)
824 (declare (optimize speed
(safety 0))
825 ;; Obviously these all coerce raw words to lispobjs
826 ;; so don't keep spewing notes about it.
827 (muffle-conditions compiler-note
)
830 `(data-vector-ref (the ,atype vector
)
833 (declare (optimize (safety 1)))
834 (,@check-form index
))))
835 `(data-nil-vector-ref (the ,atype vector
) index
)))))
836 (define-setter (saetp check-form
)
837 (let* ((type (saetp-specifier saetp
))
838 (atype `(simple-array ,type
(*))))
839 `(named-lambda (optimized-data-vector-set ,type
) (vector index new-value
)
840 (declare (optimize speed
(safety 0)))
841 ;; Impossibly setting an elt of an (ARRAY NIL)
842 ;; returns no value. And nobody cares.
843 (declare (muffle-conditions compiler-note
))
844 (data-vector-set (the ,atype vector
)
846 (declare (optimize (safety 1)))
848 (,@check-form index
)))
850 ;; SPEED 1 needed to avoid the compiler
851 ;; from downgrading the type check to
853 (declare (optimize (speed 1)
855 (the* (,type
:context sb-c
::aref-context
) new-value
)))
856 ;; Low-level setters return no value
858 (define-reffers (symbol deffer check-form slow-path
)
860 ;; FIXME/KLUDGE: can't just FILL here, because genesis doesn't
861 ;; preserve the binding, so re-initiaize as NS doesn't have
862 ;; the energy to figure out to change that right now.
863 (setf ,symbol
(make-array (1+ widetag-mask
)
864 :initial-element
#'hairy-ref-error
))
865 ,@(loop for widetag in
'(complex-vector-widetag
866 complex-bit-vector-widetag
867 #+sb-unicode complex-character-string-widetag
868 complex-base-string-widetag
870 complex-array-widetag
)
871 collect
`(setf (svref ,symbol
,widetag
) ,slow-path
))
872 ,@(loop for saetp across
*specialized-array-element-type-properties
*
873 for widetag
= (saetp-typecode saetp
)
874 collect
`(setf (svref ,symbol
,widetag
)
875 (,deffer
,saetp
,check-form
))))))
876 (defun !hairy-data-vector-reffer-init
()
877 (define-reffers %%data-vector-reffers%% define-reffer
879 #'slow-hairy-data-vector-ref
)
880 (define-reffers %%data-vector-setters%% define-setter
882 #'slow-hairy-data-vector-set
)
883 (define-reffers %%data-vector-reffers
/check-bounds%% define-reffer
884 (check-bound vector
(length vector
))
885 #'slow-hairy-data-vector-ref
/check-bounds
)
886 (define-reffers %%data-vector-setters
/check-bounds%% define-setter
887 (check-bound vector
(length vector
))
888 #'slow-hairy-data-vector-set
/check-bounds
)))
890 ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
891 ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
892 ;;; definition is needed for the compiler to use in constant folding.)
893 (defun data-vector-ref (array index
)
894 (declare (explicit-check))
895 (hairy-data-vector-ref array index
))
897 (defun data-vector-ref-with-offset (array index offset
)
898 (declare (explicit-check))
899 (hairy-data-vector-ref array
(+ index offset
)))
901 (defun invalid-array-p (array)
902 (and (array-header-p array
)
903 (consp (%array-displaced-p array
))))
905 (declaim (ftype (function (array) nil
) invalid-array-error
))
906 (define-error-wrapper invalid-array-error
(array)
907 (aver (array-header-p array
))
908 ;; Array invalidation stashes the original dimensions here...
909 (let ((dims (%array-displaced-p array
))
910 (et (array-element-type array
)))
911 (error 'invalid-array-error
916 `(vector ,et
,@dims
)))))
918 (declaim (ftype (function (array t integer
&optional t
) nil
)
919 invalid-array-index-error
))
920 (define-error-wrapper invalid-array-index-error
(array index bound
&optional axis
)
921 (if (invalid-array-p array
)
922 (invalid-array-error array
)
923 (error 'invalid-array-index-error
927 :expected-type
`(integer 0 (,bound
)))))
929 ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
930 (defun %array-row-major-index
(array &rest subscripts
)
931 (declare (dynamic-extent subscripts
)
933 (let ((length (length subscripts
)))
934 (cond ((array-header-p array
)
935 (let ((rank (%array-rank array
)))
936 (unless (= rank length
)
937 (error "Wrong number of subscripts, ~W, for array of rank ~W."
939 (do ((axis (1- rank
) (1- axis
))
942 ((minusp axis
) result
)
943 (declare (fixnum axis chunk-size result
))
944 (let ((index (fast-&rest-nth axis subscripts
))
945 (dim (%array-dimension array axis
)))
946 (unless (and (fixnump index
) (< -
1 index dim
))
947 (invalid-array-index-error array index dim axis
))
951 (truly-the fixnum
(* chunk-size index
))))
952 chunk-size
(truly-the fixnum
(* chunk-size dim
)))))))
954 (error "Wrong number of subscripts, ~W, for array of rank 1."
957 (let ((index (fast-&rest-nth
0 subscripts
))
958 (length (length (the (simple-array * (*)) array
))))
959 (unless (and (fixnump index
) (< -
1 index length
))
960 (invalid-array-index-error array index length
))
963 (defun array-in-bounds-p (array &rest subscripts
)
964 "Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise."
965 (declare (dynamic-extent subscripts
))
966 (let ((length (length subscripts
)))
967 (cond ((array-header-p array
)
968 (let ((rank (%array-rank array
)))
969 (unless (= rank length
)
970 (error "Wrong number of subscripts, ~W, for array of rank ~W."
972 (loop for i below length
973 for s
= (fast-&rest-nth i subscripts
)
974 always
(and (typep s
'(and fixnum unsigned-byte
))
975 (< s
(%array-dimension array i
))))))
977 (error "Wrong number of subscripts, ~W, for array of rank 1."
980 (let ((subscript (fast-&rest-nth
0 subscripts
)))
981 (and (typep subscript
'(and fixnum unsigned-byte
))
983 (length (truly-the (simple-array * (*)) array
)))))))))
985 (defun array-row-major-index (array &rest subscripts
)
986 (declare (dynamic-extent subscripts
))
987 (apply #'%array-row-major-index array subscripts
))
989 (defun aref (array &rest subscripts
)
990 "Return the element of the ARRAY specified by the SUBSCRIPTS."
991 (declare (dynamic-extent subscripts
))
992 (row-major-aref array
(apply #'%array-row-major-index array subscripts
)))
994 ;;; (setf aref/bit/sbit) are implemented using setf-functions,
995 ;;; because they have to work with (setf (apply #'aref array subscripts))
996 ;;; All other setfs can be done using setf-functions too, but I
997 ;;; haven't found technical advantages or disadvantages for either
999 (defun (setf aref
) (new-value array
&rest subscripts
)
1000 (declare (dynamic-extent subscripts
)
1002 (setf (row-major-aref array
(apply #'%array-row-major-index array subscripts
))
1005 (defun row-major-aref (array index
)
1006 "Return the element of array corresponding to the row-major index. This is
1008 (declare (optimize (safety 1)))
1009 (row-major-aref array index
))
1011 (defun %set-row-major-aref
(array index new-value
)
1012 (declare (optimize (safety 1)))
1013 (setf (row-major-aref array index
) new-value
))
1015 (defun svref (simple-vector index
)
1016 "Return the INDEXth element of the given Simple-Vector."
1017 (declare (optimize (safety 1)))
1018 (aref simple-vector index
))
1020 (defun %svset
(simple-vector index new
)
1021 (declare (optimize (safety 1)))
1022 (setf (aref simple-vector index
) new
))
1024 (defun bit (bit-array &rest subscripts
)
1025 "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
1026 (declare (type (array bit
) bit-array
)
1027 (dynamic-extent subscripts
)
1028 (optimize (safety 1)))
1029 (row-major-aref bit-array
(apply #'%array-row-major-index bit-array subscripts
)))
1031 (defun (setf bit
) (new-value bit-array
&rest subscripts
)
1032 (declare (type (array bit
) bit-array
)
1033 (type bit new-value
)
1034 (dynamic-extent subscripts
)
1035 (optimize (safety 1)))
1036 (setf (row-major-aref bit-array
1037 (apply #'%array-row-major-index bit-array subscripts
))
1040 (defun sbit (simple-bit-array &rest subscripts
)
1041 "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
1042 (declare (type (simple-array bit
) simple-bit-array
)
1043 (dynamic-extent subscripts
)
1044 (optimize (safety 1)))
1045 (row-major-aref simple-bit-array
1046 (apply #'%array-row-major-index simple-bit-array subscripts
)))
1048 (defun (setf sbit
) (new-value bit-array
&rest subscripts
)
1049 (declare (type (simple-array bit
) bit-array
)
1050 (type bit new-value
)
1051 (dynamic-extent subscripts
)
1052 (optimize (safety 1)))
1053 (setf (row-major-aref bit-array
1054 (apply #'%array-row-major-index bit-array subscripts
))
1057 ;;;; miscellaneous array properties
1059 (define-load-time-global *saetp-widetag-ctype
* (make-array 32 :initial-element
(make-unbound-marker)))
1061 (defun array-element-ctype (array)
1062 ;; same as (SPECIFIER-TYPE (ARRAY-ELEMENT-TYPE ARRAY)) but more efficient
1063 (svref *saetp-widetag-ctype
*
1064 (- (ash (array-underlying-widetag array
) -
2) 32)))
1066 (defun array-element-type (array)
1067 "Return the type of the elements of the array"
1068 (declare (explicit-check array
))
1069 (truly-the (or list symbol
)
1070 (widetag->element-type
(array-underlying-widetag array
))))
1072 (defun array-rank (array)
1073 "Return the number of dimensions of ARRAY."
1074 (%array-rank array
))
1076 (defun array-dimension (array axis-number
)
1077 "Return the length of dimension AXIS-NUMBER of ARRAY."
1078 (declare (array array
) (type index axis-number
))
1079 (cond ((not (array-header-p array
))
1080 (unless (= axis-number
0)
1081 (error "Vector axis is not zero: ~S" axis-number
))
1082 (length (the (simple-array * (*)) array
)))
1083 ((>= axis-number
(%array-rank array
))
1084 (error "Axis number ~W is too big; ~S only has ~D dimension~:P."
1085 axis-number array
(%array-rank array
)))
1087 (%array-dimension array axis-number
))))
1089 (defun array-dimensions (array)
1090 "Return a list whose elements are the dimensions of the array"
1091 (declare (explicit-check))
1092 (cond ((array-header-p array
)
1093 (do ((results nil
(cons (%array-dimension array index
) results
))
1094 (index (1- (%array-rank array
)) (1- index
)))
1095 ((minusp index
) results
)))
1096 ((typep array
'vector
)
1097 (list (length array
)))
1099 (sb-c::%type-check-error
/c array
'object-not-array-error nil
))))
1101 (defun array-total-size (array)
1102 "Return the total number of elements in the Array."
1103 (declare (explicit-check))
1104 (cond ((array-header-p array
)
1105 (%array-available-elements array
))
1106 ((typep array
'vector
)
1109 (sb-c::%type-check-error
/c array
'object-not-array-error nil
))))
1111 (defun array-displacement (array)
1112 "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
1113 options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
1114 (declare (type array array
))
1115 (if (and (array-header-p array
) ; if unsimple and
1116 (%array-displaced-p array
)) ; displaced
1117 (values (%array-data array
) (%array-displacement array
))
1120 (defun adjustable-array-p (array)
1121 "Return T if and only if calling ADJUST-ARRAY on ARRAY will return
1122 the identical object."
1123 (declare (array array
))
1124 ;; Note that this appears not to be a fundamental limitation.
1125 ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
1126 ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
1127 ;; -- CSR, 2004-03-01.
1128 (not (typep array
'simple-array
)))
1130 ;;;; fill pointer frobbing stuff
1132 (setf (info :function
:predicate-truth-constraint
'array-has-fill-pointer-p
)
1133 '(and vector
(not simple-array
)))
1134 (defun array-has-fill-pointer-p (array)
1135 "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
1136 (array-has-fill-pointer-p array
))
1138 (define-error-wrapper fill-pointer-error
(vector)
1139 (declare (optimize (sb-c::verify-arg-count
0)))
1140 (error 'simple-type-error
1142 :expected-type
'(and vector
(satisfies array-has-fill-pointer-p
))
1143 :format-control
"~S is not an array with a fill pointer."
1144 :format-arguments
(list vector
)))
1147 (defun fill-pointer (vector)
1148 "Return the FILL-POINTER of the given VECTOR."
1149 (declare (explicit-check))
1150 (fill-pointer vector
))
1152 (defun %set-fill-pointer
(vector new
)
1153 (declare (explicit-check))
1154 (cond ((not (and (arrayp vector
)
1155 (array-has-fill-pointer-p vector
)))
1156 (fill-pointer-error vector
))
1158 (let ((max (%array-available-elements vector
)))
1159 (when (> (the (and unsigned-byte fixnum
) new
) max
)
1160 (error 'simple-type-error
1162 :expected-type
(list 'integer
0 max
)
1163 :format-control
"The new fill pointer, ~S, is larger than the length of the vector (~S.)"
1164 :format-arguments
(list new max
)))
1165 (setf (%array-fill-pointer vector
) (truly-the index new
))))))
1167 ;;; FIXME: It'd probably make sense to use a MACROLET to share the
1168 ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro
1169 ;;; should probably be based on the VECTOR-PUSH-EXTEND code (which is
1170 ;;; new ca. sbcl-0.7.0) rather than the VECTOR-PUSH code (which dates
1171 ;;; back to CMU CL).
1172 (defun vector-push (new-element array
)
1173 "Attempt to set the element of ARRAY designated by its fill pointer
1174 to NEW-ELEMENT, and increment the fill pointer by one. If the fill pointer is
1175 too large, NIL is returned, otherwise the index of the pushed element is
1177 (declare (explicit-check))
1178 (let ((fill-pointer (fill-pointer array
)))
1179 (cond ((= fill-pointer
(%array-available-elements array
))
1182 (locally (declare (optimize (safety 0)))
1183 (setf (aref array fill-pointer
) new-element
))
1184 (setf (%array-fill-pointer array
) (1+ fill-pointer
))
1188 (defmacro reallocate-vector-with-widetag
(old-vector &rest args
)
1189 (declare (ignore old-vector
))
1190 `(allocate-vector-with-widetag ,@args
))
1192 ;;; This does not try to allow for resizing (ARRAY NIL) - there's no backing storage anyway.
1193 ;;; However, ADJUST-ARRAY apparently thinks it can resize non-simple arrays of
1194 ;;; element type NIL, but fails in ZAP-ARRAY-DATA-AUX. e.g.:
1195 ;;; (adjust-array (make-array '(10 10) :element-type nil) '(20 20))
1196 ;;; allocates a non-simple 10x10 array pointing to a (SIMPLE-ARRAY NIL 100)
1197 ;;; and then gets "An attempt to access an array of element-type NIL was made"
1198 ;;; because it doesn't know not to try to copy elements.
1199 ;;; So unless we think that that is one of the most pressing issues that demands
1200 ;;; a fix, who cares how we reallocate?
1201 ;;; If you're manipulating such arrays, quite literally you deserve to lose.
1202 ;;; FIXME: does not support #+ubsan, which is fairly bit-rotted, so ... meh.
1204 (defun reallocate-vector-with-widetag (old-vector widetag length n-bits-shift
)
1205 (declare (type (unsigned-byte 8) widetag
)
1206 (type index length
))
1207 ;; KLUDGE: add SAETP-N-PAD-ELEMENTS "by hand" since there is
1208 ;; but a single case involving it now.
1209 (let* ((full-length (+ length
(if (= widetag simple-base-string-widetag
) 1 0)))
1210 (nwords (the fixnum
(vector-length-in-words full-length n-bits-shift
))))
1211 (if (sb-vm::force-to-heap-p old-vector
)
1212 (locally (declare (sb-c::tlab
:system
))
1213 (allocate-vector widetag length nwords
))
1214 (allocate-vector widetag length nwords
))))
1216 (defun extend-vector (vector min-extension
)
1217 (declare (optimize speed
)
1219 (let* ((old-length (length vector
))
1220 (min-extension (or min-extension
1222 (- array-dimension-limit old-length
))))
1223 (new-length (the index
(+ old-length
1224 (max 1 min-extension
))))
1225 (fill-pointer (1+ old-length
)))
1226 (declare (fixnum new-length min-extension
))
1227 (with-array-data ((old-data vector
) (old-start)
1228 (old-end old-length
))
1229 (let* ((widetag (%other-pointer-widetag old-data
))
1230 (n-bits-shift (aref %%simple-array-n-bits-shifts%% widetag
))
1232 ;; FIXME: mark prefix of shadow bits assigned, suffix unassigned
1233 (reallocate-vector-with-widetag old-data
#+ubsan nil
1234 widetag new-length n-bits-shift
)))
1236 (if (= widetag simple-vector-widetag
) ; the most common case
1237 (replace (truly-the simple-vector new-data
) ; transformed
1238 (truly-the simple-vector old-data
)
1239 :start2 old-start
:end2 old-end
)
1240 (let ((copier (blt-copier-for-widetag widetag
)))
1242 (funcall (truly-the function copier
) old-data old-start new-data
0 old-length
)
1243 (replace new-data old-data
:start2 old-start
:end2 old-end
))))
1244 (setf (%array-data vector
) new-data
1245 (%array-available-elements vector
) new-length
1246 (%array-fill-pointer vector
) fill-pointer
1247 (%array-displacement vector
) 0
1248 (%array-displaced-p vector
) nil
)
1249 (%set-array-dimension vector
0 new-length
)
1252 (defun vector-push-extend (new-element vector
&optional min-extension
)
1253 (declare (type (or null
(and index
(integer 1))) min-extension
))
1254 (declare (explicit-check))
1255 (let* ((fill-pointer (fill-pointer vector
))
1256 (new-fill-pointer (1+ fill-pointer
)))
1257 (if (= fill-pointer
(%array-available-elements vector
))
1258 (extend-vector vector min-extension
)
1259 (setf (%array-fill-pointer vector
) new-fill-pointer
))
1260 ;; disable bounds checking
1261 (locally (declare (optimize (safety 0)))
1262 (setf (aref vector fill-pointer
) new-element
))
1265 (defun vector-pop (array)
1266 "Decrease the fill pointer by 1 and return the element pointed to by the
1268 (declare (explicit-check))
1269 (let ((fill-pointer (fill-pointer array
)))
1270 (if (zerop fill-pointer
)
1271 (error "There is nothing left to pop.")
1272 ;; disable bounds checking (and any fixnum test)
1273 (locally (declare (optimize (safety 0)))
1275 (setf (%array-fill-pointer array
)
1276 (1- fill-pointer
)))))))
1281 (defun adjust-array (array dimensions
&key
1282 (element-type (array-element-type array
) element-type-p
)
1283 (initial-element nil element-p
)
1284 (initial-contents nil contents-p
)
1286 displaced-to
(displaced-index-offset 0 offset-p
))
1287 "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
1288 (when (invalid-array-p array
)
1289 (invalid-array-error array
))
1291 (((rank new-total-size
) (rank-and-total-size-from-dims dimensions
))
1293 (let ((widetag (array-underlying-widetag array
)))
1294 (unless (= (array-rank array
) rank
) ; "drive-by" check of the rank
1295 (error "Expected ~D new dimension~:P for array, but received ~D."
1296 (array-rank array
) rank
))
1297 (if (or (not element-type-p
)
1298 ;; Quick pass if ELEMENT-TYPE is same as the element type based on widetag
1299 (equal element-type
(widetag->element-type widetag
))
1300 (= (%vector-widetag-and-n-bits-shift element-type
) widetag
))
1302 (error "The new element type, ~/sb-impl:print-type-specifier/, is incompatible ~
1303 with old type, ~/sb-impl:print-type-specifier/."
1304 element-type
(array-element-type array
)))))
1307 (unless (array-has-fill-pointer-p array
)
1309 (error "Only vectors can have fill pointers.")
1310 ;; I believe the sentence saying that this is an error pre-dates the removal
1311 ;; of the restriction of calling ADJUST-ARRAY only on arrays that
1312 ;; are actually adjustable. Making a new array should always work,
1313 ;; so I think this may be a bug in the spec.
1314 (fill-pointer-error array
)))
1315 (cond ((eq fill-pointer t
) new-total-size
)
1316 ((<= fill-pointer new-total-size
) fill-pointer
)
1317 (t (make-array-bad-fill-pointer fill-pointer new-total-size
" new"))))
1318 ((array-has-fill-pointer-p array
)
1319 ;; "consequences are unspecified if array is adjusted to a size smaller than its fill pointer"
1320 (let ((old-fill-pointer (%array-fill-pointer array
)))
1321 (when (< new-total-size old-fill-pointer
)
1322 (error "can't adjust vector ~S to a size (~S) smaller than ~
1323 its current fill pointer (~S)"
1324 array new-total-size old-fill-pointer
))
1325 old-fill-pointer
))))
1326 ((initialize initial-data
)
1327 (check-make-array-initargs t element-type new-total-size
))
1328 (n-bits-shift (aref %%simple-array-n-bits-shifts%% widetag
)))
1331 (displaced-to ; super easy - just repoint ARRAY to new data
1332 (if (adjustable-array-p array
)
1333 (set-array-header array displaced-to new-total-size new-fill-pointer
1334 displaced-index-offset dimensions t nil
)
1335 (%make-array dimensions widetag n-bits-shift
1336 :displaced-to displaced-to
1337 :displaced-index-offset displaced-index-offset
)))
1338 (contents-p ; array former contents replaced by INITIAL-CONTENTS
1339 (let ((array-data (data-vector-from-inits dimensions new-total-size widetag n-bits-shift
1340 initialize initial-data
)))
1341 (cond ((adjustable-array-p array
)
1342 (set-array-header array array-data new-total-size new-fill-pointer
1343 0 dimensions nil nil
))
1344 ((array-header-p array
)
1345 ;; simple multidimensional array.
1346 ;; fill-pointer vectors satisfy ADJUSTABLE-ARRAY-P (in SBCL, that is)
1347 ;; and therefore are handled by the first stanza of the cond.
1348 (%make-array dimensions widetag n-bits-shift
1349 :initial-contents initial-contents
))
1353 (let ((old-length (array-total-size array
)))
1354 ;; Because ADJUST-ARRAY has to ignore any fill-pointer when
1355 ;; copying from the old data, we can't just pass ARRAY as the
1356 ;; second argument of REPLACE.
1357 (with-array-data ((old-data array
) (old-start) (old-end old-length
))
1359 (if (and (= new-total-size old-length
)
1360 (not (and (array-header-p array
) (%array-displaced-p array
))))
1361 ;; if total size is unchanged, and it was not a displaced array,
1362 ;; then this array owns the data and can retain it.
1365 (reallocate-vector-with-widetag old-data
#+ubsan t
1366 widetag new-total-size
1368 (replace data old-data
1369 :start1
0 :end1 new-total-size
1370 :start2 old-start
:end2 old-end
)
1371 (when (and element-p
(> new-total-size old-length
))
1372 (fill data initial-element
:start old-length
))
1374 (if (adjustable-array-p array
)
1375 (set-array-header array new-data new-total-size new-fill-pointer
1376 0 dimensions nil nil
)
1379 (let ((old-total-size (%array-available-elements array
)))
1380 (with-array-data ((old-data array
) (old-start) (old-end old-total-size
))
1381 (declare (ignore old-end
))
1382 (let ((new-data (if (or (and (array-header-p array
)
1383 (%array-displaced-p array
))
1384 (> new-total-size old-total-size
)
1385 (not (adjustable-array-p array
)))
1386 (data-vector-from-inits dimensions new-total-size widetag
1387 n-bits-shift initialize initial-data
)
1389 (if (or (zerop old-total-size
) (zerop new-total-size
))
1390 (when element-p
(fill new-data initial-element
))
1391 (zap-array-data old-data
(array-dimensions array
)
1393 new-data dimensions new-total-size
1394 element-type initial-element
1396 (if (adjustable-array-p array
)
1397 (set-array-header array new-data new-total-size
1398 nil
0 dimensions nil nil
)
1399 (let ((new-array (make-array-header simple-array-widetag rank
)))
1400 (set-array-header new-array new-data new-total-size
1401 nil
0 dimensions nil t
))))))))))
1403 ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
1404 ;;; which must be less than or equal to its current length. This can
1405 ;;; be called on vectors without a fill pointer but it is slightly
1406 ;;; dangerous to do so: shrinking the size of an object accessible
1407 ;;; to another thread could cause it to access an out-of-bounds element.
1408 ;;; GC should generally be fine no matter what happens, because it either
1409 ;;; reads the old length or the new length. If it reads the old length,
1410 ;;; then the whole vector is skipped if unboxed; if it reads the new length,
1411 ;;; then the next object is a filler.
1412 ;;; Exception: for SIMPLE-VECTOR we always zeroized the unused tail,
1413 ;;; because the garbage collector can scan certain pages without regard
1414 ;;; to object boundaries. The situation we need to avoid is this:
1415 ;;; "old" #(...............|.....)
1416 ;;; "new" #(..........)Fill|.....
1418 ;;; where GC reads the objects on the page just after the filler
1419 ;;; because it doesn't know not to.
1421 (defmacro make-filler
(n)
1422 `(logior (ash ,n
#+64-bit
32 #-
64-bit
,n-widetag-bits
) filler-widetag
))
1423 (defmacro filler-nwords
(header)
1424 `(ash ,header
#+64-bit -
32 #-
64-bit
,(- n-widetag-bits
)))
1426 (defun %shrink-vector
(vector new-length
1427 &aux
(old-length (length vector
))
1428 (new-length* new-length
))
1429 (declare (vector vector
))
1431 ((simple-vector-p vector
)
1432 ;; We do in fact call %SHRINK-VECTOR a lot from sequence functions
1433 ;; that overallocate a temporary result. In all places where that happens,
1434 ;; the discarded suffix was never used. So assuming pre-zeroed heap,
1435 ;; it kind of just worked. But I don't want to assume that.
1436 ;; For what it's worth, adding this assertion prior to FILL:
1437 ;; (WHEN (FIND 0 VECTOR :START OLD-LENGTH :TEST #'NEQ) (BUG "No can do"))
1438 ;; produced no failures in the regression suite.
1439 (when (< new-length old-length
) (fill vector
0 :start new-length
)))
1440 ((not (or (array-header-p vector
) (typep vector
'(simple-array nil
(*)))))
1441 (when (simple-base-string-p vector
)
1442 ;; We can blindly store the hidden #\null at NEW-LENGTH, but it would
1443 ;; appear to be an out-of-bounds access if the length is not
1444 ;; changing at all. i.e. while it's safe to always do a store,
1445 ;; the length check has to be skipped.
1446 (locally (declare (optimize (sb-c:insert-array-bounds-checks
0)))
1447 (setf (schar vector new-length
) (code-char 0)))
1448 ;; Now treat both the old and new lengths as if they include
1449 ;; the byte that holds the implicit string terminator.
1452 (let* ((n-bits-shift (aref %%simple-array-n-bits-shifts%%
1453 (%other-pointer-widetag vector
)))
1454 (old-nwords (ceiling (ash old-length n-bits-shift
) n-word-bits
))
1455 (new-nwords (ceiling (ash new-length
* n-bits-shift
) n-word-bits
)))
1456 (when (< new-nwords old-nwords
)
1457 (with-pinned-objects (vector)
1458 ;; VECTOR-SAP is only for unboxed vectors. Use the vop directly.
1459 (let ((data (%primitive vector-sap vector
)))
1460 ;; There is no requirement to zeroize memory corresponding
1461 ;; to unused array elements.
1462 ;; However, it's slightly nicer if the padding word (if present) is 0.
1463 (when (oddp new-nwords
)
1464 (setf (sap-ref-word data
(ash new-nwords word-shift
)) 0))
1465 (let* ((aligned-old (align-up old-nwords
2))
1466 (aligned-new (align-up new-nwords
2)))
1467 ;; Only if physically shrunk as determined by PRIMITIVE-OBJECT-SIZE
1468 ;; will we need to (and have adequate room to) place a filler.
1469 (when (< aligned-new aligned-old
)
1470 (let ((diff (- aligned-old aligned-new
)))
1471 ;; Certainly if the vector is unboxed it can't possibly matter
1472 ;; if GC sees this bit pattern prior to setting the new length;
1473 ;; but even for SIMPLE-VECTOR, it's OK, it turns out.
1474 (setf (sap-ref-word data
(ash aligned-new word-shift
))
1475 (make-filler diff
)))))))))))
1476 ;; Only arrays have fill-pointers, but vectors have their length
1477 ;; parameter in the same place.
1478 (setf (%array-fill-pointer vector
) new-length
)
1481 (defun shrink-vector (vector new-length
)
1482 (declare (vector vector
))
1484 ((eq (length vector
) new-length
)
1486 ((array-has-fill-pointer-p vector
)
1487 (setf (%array-fill-pointer vector
) new-length
)
1489 (t (subseq vector
0 new-length
))))
1491 ;;; BIG THREAD SAFETY NOTE
1493 ;;; ADJUST-ARRAY/SET-ARRAY-HEADER, and its callees are very
1494 ;;; thread unsafe. They are nonatomic, and can mess with parallel
1495 ;;; code using the same arrays.
1497 ;;; A likely seeming fix is an additional level of indirection:
1498 ;;; ARRAY-HEADER -> ARRAY-INFO -> ... where ARRAY-HEADER would
1499 ;;; hold nothing but the pointer to ARRAY-INFO, and ARRAY-INFO
1500 ;;; would hold everything ARRAY-HEADER now holds. This allows
1501 ;;; consing up a new ARRAY-INFO and replacing it atomically in
1502 ;;; the ARRAY-HEADER.
1504 ;;; %WALK-DISPLACED-ARRAY-BACKPOINTERS is an especially nasty
1505 ;;; one: not only is it needed extremely rarely, which makes
1506 ;;; any thread safety bugs involving it look like rare random
1507 ;;; corruption, but because it walks the chain *upwards*, which
1508 ;;; may violate user expectations.
1510 ;;; Fill in array header with the provided information, and return the array.
1511 (defun set-array-header (array data length fill-pointer displacement dimensions
1513 (labels ((%walk-displaced-array-backpointers
(array new-length
)
1514 (dolist (p (%array-displaced-from array
))
1515 (let ((from (weak-pointer-value p
)))
1516 (when (and from
(eq array
(%array-data from
)))
1517 (let ((requires (+ (%array-available-elements from
)
1518 (%array-displacement from
))))
1519 (unless (>= new-length requires
)
1520 ;; ANSI sayeth (ADJUST-ARRAY dictionary entry):
1522 ;; "If A is displaced to B, the consequences are unspecified if B is
1523 ;; adjusted in such a way that it no longer has enough elements to
1526 ;; since we're hanging on a weak pointer here, we can't signal an
1527 ;; error right now: the array that we're looking at might be
1528 ;; garbage. Instead, we set all dimensions to zero so that next
1529 ;; safe access to the displaced array will trap. Additionally, we
1530 ;; save the original dimensions, so we can signal a more
1531 ;; understandable error when the time comes.
1532 (%walk-displaced-array-backpointers from
0)
1533 (setf (%array-fill-pointer from
) 0
1534 (%array-available-elements from
) 0
1535 (%array-displaced-p from
) (array-dimensions array
))
1536 (dotimes (i (%array-rank from
))
1537 (%set-array-dimension from i
0)))))))))
1539 (setf (%array-displaced-from array
) nil
)
1540 (%walk-displaced-array-backpointers array length
))
1542 (%save-displaced-array-backpointer array data
))
1543 (setf (%array-data array
) data
)
1544 (setf (%array-available-elements array
) length
)
1546 (setf (%array-fill-pointer array
) fill-pointer
)
1547 (logior-array-flags array
+array-fill-pointer-p
+))
1549 (setf (%array-fill-pointer array
) length
)
1550 (reset-array-flags array
+array-fill-pointer-p
+)))
1551 (setf (%array-displacement array
) displacement
)
1552 (populate-dimensions array dimensions
(array-rank array
))
1553 (setf (%array-displaced-p array
) displacedp
)
1556 ;;; User visible extension
1557 (declaim (ftype (sfunction (array) (simple-array * (*))) array-storage-vector
))
1558 (defun array-storage-vector (array)
1559 "Returns the underlying storage vector of ARRAY, which must be a non-displaced array.
1561 In SBCL, if ARRAY is a of type \(SIMPLE-ARRAY * \(*)), it is its own storage
1562 vector. Multidimensional arrays, arrays with fill pointers, and adjustable
1563 arrays have an underlying storage vector with the same ARRAY-ELEMENT-TYPE as
1564 ARRAY, which this function returns.
1566 Important note: the underlying vector is an implementation detail. Even though
1567 this function exposes it, changes in the implementation may cause this
1568 function to be removed without further warning."
1569 ;; KLUDGE: Without TRULY-THE the system is not smart enough to figure out that
1570 ;; the return value is always of the known type.
1571 (truly-the (simple-array * (*))
1572 (cond ((not (array-header-p array
))
1574 ((%array-displaced-p array
)
1575 (error "~S cannot be used with displaced arrays. Use ~S instead."
1576 'array-storage-vector
'array-displacement
))
1578 (%array-data array
)))))
1581 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
1583 ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
1584 ;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
1585 ;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
1586 ;;; is a displaced offset to be added to computed indices of OLD-DATA.
1587 (defun zap-array-data (old-data old-dims offset new-data new-dims new-length
1588 element-type initial-element initial-element-p
)
1589 (declare (list old-dims new-dims
)
1590 (fixnum new-length
))
1591 ;; OLD-DIMS comes from array-dimensions, which returns a fresh list
1592 ;; at least in SBCL.
1593 ;; NEW-DIMS comes from the user.
1594 (setf old-dims
(nreverse old-dims
)
1595 new-dims
(reverse new-dims
))
1596 (cond ((eq old-data new-data
)
1597 ;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and
1598 ;; INITIAL-ELEMENT-P are used when OLD-DATA and NEW-DATA are
1599 ;; EQ; in this case, a temporary must be used and filled
1600 ;; appropriately. specified initial-element.
1601 ;; FIXME: transforming this TYPEP to someting a bit faster
1602 ;; would be a win...
1603 (unless (or (not initial-element-p
)
1604 (typep initial-element element-type
))
1605 (error "~S can't be used to initialize an array of type ~
1606 ~/sb-impl:print-type-specifier/."
1607 initial-element element-type
))
1608 (let ((temp (if initial-element-p
1609 (make-array new-length
:initial-element initial-element
)
1610 (make-array new-length
))))
1611 (declare (simple-vector temp
))
1612 (zap-array-data-aux old-data old-dims offset temp new-dims
)
1613 (dotimes (i new-length
)
1614 (setf (aref new-data i
) (aref temp i
)))
1615 ;; Kill the temporary vector to prevent garbage retention.
1616 (%shrink-vector temp
0)))
1618 ;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
1619 ;; already been filled with any
1620 (zap-array-data-aux old-data old-dims offset new-data new-dims
))))
1622 (defun zap-array-data-aux (old-data old-dims offset new-data new-dims
)
1623 (declare (fixnum offset
))
1624 (let ((limits (mapcar (lambda (x y
)
1625 (declare (fixnum x y
))
1626 (1- (the fixnum
(min x y
))))
1627 old-dims new-dims
)))
1628 (macrolet ((bump-index-list (index limits
)
1629 `(do ((subscripts ,index
(cdr subscripts
))
1630 (limits ,limits
(cdr limits
)))
1631 ((null subscripts
) :eof
)
1632 (cond ((< (the fixnum
(car subscripts
))
1633 (the fixnum
(car limits
)))
1635 (1+ (the fixnum
(car subscripts
))))
1637 (t (rplaca subscripts
0))))))
1638 (do ((index (make-list (length old-dims
) :initial-element
0)
1639 (bump-index-list index limits
)))
1641 (setf (aref new-data
(row-major-index-from-dims index new-dims
))
1643 (+ (the fixnum
(row-major-index-from-dims index old-dims
))
1646 ;;; Figure out the row-major-order index of an array reference from a
1647 ;;; list of subscripts and a list of dimensions. This is for internal
1648 ;;; calls only, and the subscripts and dim-list variables are assumed
1649 ;;; to be reversed from what the user supplied.
1650 (defun row-major-index-from-dims (rev-subscripts rev-dim-list
)
1651 (do ((rev-subscripts rev-subscripts
(cdr rev-subscripts
))
1652 (rev-dim-list rev-dim-list
(cdr rev-dim-list
))
1655 ((null rev-dim-list
) result
)
1656 (declare (fixnum chunk-size result
))
1657 (setq result
(+ result
1658 (the fixnum
(* (the fixnum
(car rev-subscripts
))
1660 (setq chunk-size
(* chunk-size
(the fixnum
(car rev-dim-list
))))))
1664 (defun bit-array-same-dimensions-p (array1 array2
)
1665 (declare (type (array bit
) array1 array2
))
1666 (let ((rank (array-rank array1
)))
1667 (and (= rank
(array-rank array2
))
1669 (= (array-total-size array1
)
1670 (array-total-size array2
))
1671 (dotimes (index rank t
)
1672 (when (/= (%array-dimension array1 index
)
1673 (%array-dimension array2 index
))
1676 (defun copy-array-header (array)
1677 (let* ((rank (%array-rank array
))
1678 (size (%array-available-elements array
))
1679 (result (make-array-header simple-array-widetag
1681 (loop for i below rank
1682 do
(%set-array-dimension result i
1683 (%array-dimension array i
)))
1684 ;; fill-pointer-p defaults to 0
1685 (setf (%array-displaced-from result
) nil
1686 (%array-displaced-p result
) nil
1687 (%array-fill-pointer result
) size
1688 (%array-available-elements result
) size
)
1691 (defun pick-result-array (result-bit-array bit-array-1
)
1692 (case result-bit-array
1695 (if (vectorp bit-array-1
)
1696 (make-array (array-total-size bit-array-1
)
1699 (let ((header (copy-array-header bit-array-1
)))
1700 (setf (%array-data header
)
1701 (make-array (%array-available-elements bit-array-1
)
1703 :initial-element
0))
1706 (unless (bit-array-same-dimensions-p bit-array-1
1708 (error "~S and ~S don't have the same dimensions."
1709 bit-array-1 result-bit-array
))
1712 ;;; This used to be a DEFMACRO, but depending on the target's support for Unicode,
1713 ;;; it got a constant-folding-error in the FORMAT call when producing the load-time
1714 ;;; macro. CONCATENATE-FORMAT-P returns true, so then we want to know whether the
1715 ;;; result is a base-string which entails calling SB-KERNEL:SIMPLE-BASE-STRING-P
1716 ;;; which has no definition in the cross-compiler. (We could add one of course)
1718 ;;; Bit array operations are allowed to leave arbitrary values in the
1719 ;;; trailing bits of the result. Examples:
1720 ;;; * (format t "~b~%" (%vector-raw-bits (bit-not #*1001) 0))
1721 ;;; 1111111111111111111111111111111111111111111111111111111111110110
1722 ;;; * (format t "~b~%" (%vector-raw-bits (bit-nor #*1001 #*1010) 0))
1723 ;;; 1111111111111111111111111111111111111111111111111111111111110010
1724 ;;; But because reading is more common than writing, it seems that a better
1725 ;;; technique might be to enforce an invariant that the last word contain 0
1726 ;;; in all unused bits so that EQUAL and SXHASH become far simpler.
1728 (macrolet ((def-bit-array-op (name function
)
1729 `(defun ,name
(bit-array-1 bit-array-2
&optional result-bit-array
)
1731 "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
1732 BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
1733 If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
1734 RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
1735 All the arrays must have the same rank and dimensions."
1736 (symbol-name function
))
1737 (declare (type (array bit
) bit-array-1 bit-array-2
)
1738 (type (or (array bit
) (member t nil
)) result-bit-array
))
1739 (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2
)
1740 (error "~S and ~S don't have the same dimensions."
1741 bit-array-1 bit-array-2
))
1742 (let ((result-bit-array (pick-result-array result-bit-array bit-array-1
)))
1743 (if (and (simple-bit-vector-p bit-array-1
)
1744 (simple-bit-vector-p bit-array-2
)
1745 (simple-bit-vector-p result-bit-array
))
1746 (locally (declare (optimize (speed 3) (safety 0)))
1747 (,name bit-array-1 bit-array-2 result-bit-array
))
1748 (with-array-data ((data1 bit-array-1
) (start1) (end1))
1749 (with-array-data ((data2 bit-array-2
) (start2) (end2))
1750 (with-array-data ((data3 result-bit-array
) (start3) (end3))
1751 (if (and (zerop start1
)
1754 (= (length data1
) end1
)
1755 (= (length data2
) end2
)
1756 (= (length data3
) end3
))
1757 (locally (declare (optimize (speed 3) (safety 0)))
1758 (,name data1 data2 data3
))
1759 (do ((index-1 start1
(1+ index-1
))
1760 (index-2 start2
(1+ index-2
))
1761 (index-3 start3
(1+ index-3
)))
1763 (declare (type index index-1 index-2 index-3
))
1764 (setf (sbit data3 index-3
)
1765 (logand (,function
(sbit data1 index-1
)
1766 (sbit data2 index-2
))
1768 result-bit-array
))))))))
1770 (def-bit-array-op bit-and logand
)
1771 (def-bit-array-op bit-ior logior
)
1772 (def-bit-array-op bit-xor logxor
)
1773 (def-bit-array-op bit-eqv logeqv
)
1774 (def-bit-array-op bit-nand lognand
)
1775 (def-bit-array-op bit-nor lognor
)
1776 (def-bit-array-op bit-andc1 logandc1
)
1777 (def-bit-array-op bit-andc2 logandc2
)
1778 (def-bit-array-op bit-orc1 logorc1
)
1779 (def-bit-array-op bit-orc2 logorc2
)
1782 (defun bit-not (bit-array &optional result-bit-array
)
1783 "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
1784 putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
1785 BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
1786 created. Both arrays must have the same rank and dimensions."
1787 (declare (type (array bit
) bit-array
)
1788 (type (or (array bit
) (member t nil
)) result-bit-array
))
1789 (let ((result-bit-array (pick-result-array result-bit-array bit-array
)))
1790 (if (and (simple-bit-vector-p bit-array
)
1791 (simple-bit-vector-p result-bit-array
))
1792 (locally (declare (optimize (speed 3) (safety 0)))
1793 (bit-not bit-array result-bit-array
))
1794 (with-array-data ((src bit-array
) (src-start) (src-end))
1795 (with-array-data ((dst result-bit-array
) (dst-start) (dst-end))
1796 (if (and (zerop src-start
)
1798 (= src-end
(length src
))
1799 (= dst-end
(length dst
)))
1800 (locally (declare (optimize (speed 3) (safety 0)))
1802 (do ((src-index src-start
(1+ src-index
))
1803 (dst-index dst-start
(1+ dst-index
)))
1804 ((>= dst-index dst-end
))
1805 (declare (type index src-index dst-index
))
1806 (setf (sbit dst dst-index
)
1807 (logxor (sbit src src-index
) 1))))
1808 result-bit-array
)))))
1810 ;;;; array type dispatching
1812 ;;; Given DISPATCH-FOO as the DISPATCH-NAME argument (unevaluated),
1813 ;;; defines the functions
1815 ;;; DISPATCH-FOO/SIMPLE-BASE-STRING
1816 ;;; DISPATCH-FOO/SIMPLE-CHARACTER-STRING
1817 ;;; DISPATCH-FOO/SIMPLE-ARRAY-SINGLE-FLOAT
1820 ;;; PARAMS are the function parameters in the definition of each
1821 ;;; specializer function. The array being specialized must be the
1822 ;;; first parameter in PARAMS. A type declaration for this parameter
1823 ;;; is automatically inserted into the body of each function.
1825 ;;; The dispatch table %%FOO-FUNS%% is defined and populated by these
1826 ;;; functions. The table is padded by the function
1827 ;;; HAIRY-FOO-DISPATCH-ERROR, also defined by DEFINE-ARRAY-DISPATCH.
1829 ;;; Finally, the DISPATCH-FOO macro is defined which does the actual
1830 ;;; dispatching when called. It expects arguments that match PARAMS.
1832 (defmacro sb-impl
::!define-array-dispatch
(style dispatch-name params nil-array
&body body
)
1833 #-
(or x86 x86-64 arm64
) (setq style
:call
)
1834 (let ((table-name (symbolicate "%%" dispatch-name
"-FUNS%%"))
1835 (error-name (symbolicate "HAIRY-" dispatch-name
"-ERROR")))
1836 (declare (ignorable table-name
))
1838 (defun ,error-name
(,(first params
) &rest rest
)
1839 (declare (ignore rest
))
1841 :datum
,(first params
)
1842 :expected-type
'(simple-array * (*))))
1846 `((define-load-time-global ,table-name
,(sb-xc:make-array
(1+ widetag-mask
)))
1848 ;; This SUBSTITUTE call happens ** after ** all the SETFs below it.
1849 ;; DEFGLOBAL's initial value is dumped by genesis as a vector filled
1850 ;; with 0 (it would not work if the vector held function objects).
1851 ;; Then the SETFs happen, as cold-load can process %SVSET, which
1852 ;; is great, because it means that hairy sequence dispatch may occur
1853 ;; as early as you'd like in cold-init without regard to file order.
1854 ;; However when it comes to actually executing the toplevel forms
1855 ;; that were compiled into thunks of target code to invoke,
1856 ;; all the known good entries must be preserved.
1857 (nsubstitute #',error-name
0 ,table-name
)
1859 ,@(loop for info across
*specialized-array-element-type-properties
*
1860 for typecode
= (saetp-typecode info
)
1861 for specifier
= (saetp-specifier info
)
1862 for primitive-type-name
= (saetp-primitive-type-name info
)
1863 collect
(let ((fun-name (symbolicate (string dispatch-name
)
1864 "/" primitive-type-name
)))
1866 (defun ,fun-name
,params
1867 (declare (type (simple-array ,specifier
(*))
1869 ,@(if (null specifier
)
1872 (setf (svref ,table-name
,typecode
) #',fun-name
))))
1873 (defmacro ,dispatch-name
(&rest args
)
1874 (aver (symbolp (first args
)))
1875 (let ((tag (gensym "TAG")))
1876 `(,',(if (find '&rest params
)
1881 (when (%other-pointer-p
,(first args
))
1882 (setf ,tag
(%other-pointer-widetag
,(first args
))))
1883 (svref (truly-the (simple-vector 256) (load-time-value ,',table-name t
))
1887 (multiple-value-bind (body decls
) (parse-body body nil
)
1888 `((declaim (inline ,dispatch-name
))
1889 (defun ,dispatch-name
,params
1890 (declare (optimize (sb-c:jump-table
3)))
1892 (case (if (%other-pointer-p
,(first params
))
1893 (ash (%other-pointer-widetag
,(first params
)) -
2)
1896 for info across
*specialized-array-element-type-properties
*
1897 for specifier
= (saetp-specifier info
)
1898 collect
`(,(ash (saetp-typecode info
) -
2)
1899 (let ((,(first params
)
1900 (truly-the (simple-array ,specifier
(*))
1902 ,@(if (null specifier
)
1906 (,error-name
,@params
)))))))))))
1908 (defun sb-kernel::check-array-shape
(array dimensions
)
1909 (when (let ((dimensions dimensions
))
1910 (dotimes (i (array-rank array
))
1911 (unless (eql (array-dimension array i
) (pop dimensions
))
1913 (error "malformed :INITIAL-CONTENTS: ~S should have dimensions ~S"
1914 (make-array dimensions
:displaced-to
(%array-data array
)
1915 :element-type
(array-element-type array
))
1916 (array-dimensions array
)))
1919 ;;; Horrible kludge for the "static-vectors" system
1920 ;;; which uses an internal symbol in SB-IMPL.
1921 (import '%vector-widetag-and-n-bits-shift
'sb-impl
)