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
)
31 (def %array-data-vector
)
32 (def %array-displacement
)
33 (def %array-displaced-p
)
34 (def %array-displaced-from
))
36 (defun %array-rank
(array)
39 (defun %array-dimension
(array axis
)
40 (%array-dimension array axis
))
42 (defun %set-array-dimension
(array axis value
)
43 (%set-array-dimension array axis value
))
45 (defun %check-bound
(array bound index
)
46 (declare (type index bound
)
48 (%check-bound array bound index
))
50 (defun check-bound (array bound index
)
51 (declare (type index bound
)
53 (%check-bound array bound index
))
55 (defun %with-array-data
/fp
(array start end
)
56 (%with-array-data-macro array start end
:check-bounds t
:check-fill-pointer t
))
58 (defun %with-array-data
(array start end
)
59 (%with-array-data-macro array start end
:check-bounds t
:check-fill-pointer nil
))
61 (defun %data-vector-and-index
(array index
)
62 (if (array-header-p array
)
63 (multiple-value-bind (vector index
)
64 (%with-array-data array index nil
)
65 (values vector index
))
66 (values array index
)))
69 (defun %integer-vector-widetag-and-n-bits
(signed high
)
71 #.
(let ((map (make-array (1+ sb
!vm
:n-word-bits
))))
72 (loop for saetp across
73 (reverse sb
!vm
:*specialized-array-element-type-properties
*)
74 for ctype
= (sb!vm
:saetp-ctype saetp
)
75 when
(and (numeric-type-p ctype
)
76 (eq (numeric-type-class ctype
) 'integer
)
77 (zerop (numeric-type-low ctype
)))
78 do
(fill map
(cons (sb!vm
:saetp-typecode saetp
)
79 (sb!vm
:saetp-n-bits saetp
))
80 :end
(1+ (integer-length (numeric-type-high ctype
)))))
83 #.
(let ((map (make-array (1+ sb
!vm
:n-word-bits
))))
84 (loop for saetp across
85 (reverse sb
!vm
:*specialized-array-element-type-properties
*)
86 for ctype
= (sb!vm
:saetp-ctype saetp
)
87 when
(and (numeric-type-p ctype
)
88 (eq (numeric-type-class ctype
) 'integer
)
89 (minusp (numeric-type-low ctype
)))
90 do
(fill map
(cons (sb!vm
:saetp-typecode saetp
)
91 (sb!vm
:saetp-n-bits saetp
))
92 :end
(+ (integer-length (numeric-type-high ctype
)) 2)))
94 (cond ((> high sb
!vm
:n-word-bits
)
95 (values #.sb
!vm
:simple-vector-widetag
#.sb
!vm
:n-word-bits
))
97 (let ((x (aref signed-table high
)))
98 (values (car x
) (cdr x
))))
100 (let ((x (aref unsigned-table high
)))
101 (values (car x
) (cdr x
)))))))
103 ;;; This is a bit complicated, but calling subtypep over all
104 ;;; specialized types is exceedingly slow
105 (defun %vector-widetag-and-n-bits
(type)
106 (macrolet ((with-parameters ((arg-type &key intervals
)
107 (&rest args
) &body body
)
108 (let ((type-sym (gensym)))
109 `(let (,@(loop for arg in args
111 (declare (ignorable ,@args
))
113 (let ((,type-sym
(cdr type
)))
115 ,@(loop for arg in args
117 `(cond ((consp ,type-sym
)
118 (let ((value (pop ,type-sym
)))
119 (if (or (eq value
'*)
120 (typep value
',arg-type
)
136 (let ((value (symbol-value widetag
)))
140 sb
!vm
:*specialized-array-element-type-properties
*
141 :key
#'sb
!vm
:saetp-typecode
))))))
143 (error "Invalid type specifier: ~s" type
))
144 (integer-interval-widetag (low high
)
146 (%integer-vector-widetag-and-n-bits
148 (1+ (max (integer-length low
) (integer-length high
))))
149 (%integer-vector-widetag-and-n-bits
151 (max (integer-length low
) (integer-length high
))))))
152 (let* ((consp (consp type
))
160 (result sb
!vm
:simple-vector-widetag
))
161 ((base-char standard-char
#!-sb-unicode character
)
164 (result sb
!vm
:simple-base-string-widetag
))
166 ((character extended-char
)
169 (result sb
!vm
:simple-character-string-widetag
))
173 (result sb
!vm
:simple-bit-vector-widetag
))
177 (result sb
!vm
:simple-array-fixnum-widetag
))
179 (with-parameters ((integer 1)) (high)
181 (result sb
!vm
:simple-vector-widetag
)
182 (%integer-vector-widetag-and-n-bits nil high
))))
184 (with-parameters ((integer 1)) (high)
186 (result sb
!vm
:simple-vector-widetag
)
187 (%integer-vector-widetag-and-n-bits t high
))))
189 (with-parameters (double-float :intervals t
) (low high
)
190 (if (and (not (eq low
'*))
192 (if (or (consp low
) (consp high
))
193 (>= (type-bound-number low
) (type-bound-number high
))
195 (result sb
!vm
:simple-array-nil-widetag
)
196 (result sb
!vm
:simple-array-double-float-widetag
))))
198 (with-parameters (single-float :intervals t
) (low high
)
199 (if (and (not (eq low
'*))
201 (if (or (consp low
) (consp high
))
202 (>= (type-bound-number low
) (type-bound-number high
))
204 (result sb
!vm
:simple-array-nil-widetag
)
205 (result sb
!vm
:simple-array-single-float-widetag
))))
207 (if (and (consp type
)
210 (typep (cadr type
) '(integer 1)))
211 (%integer-vector-widetag-and-n-bits
212 nil
(integer-length (1- (cadr type
))))
216 (with-parameters (long-float :intervals t
) (low high
)
217 (if (and (not (eq low
'*))
219 (if (or (consp low
) (consp high
))
220 (>= (type-bound-number low
) (type-bound-number high
))
222 (result sb
!vm
:simple-array-nil-widetag
)
223 (result sb
!vm
:simple-array-long-float-widetag
))))
225 (with-parameters (integer :intervals t
) (low high
)
226 (let ((low (if (consp low
)
229 (high (if (consp high
)
232 (cond ((or (eq high
'*)
234 (result sb
!vm
:simple-vector-widetag
))
236 (result sb
!vm
:simple-array-nil-widetag
))
238 (integer-interval-widetag low high
))))))
240 (with-parameters (t) (subtype)
242 (result sb
!vm
:simple-vector-widetag
)
243 (let ((ctype (specifier-type type
)))
244 (cond ((eq ctype
*empty-type
*)
245 (result sb
!vm
:simple-array-nil-widetag
))
246 ((union-type-p ctype
)
247 (cond ((csubtypep ctype
(specifier-type '(complex double-float
)))
249 sb
!vm
:simple-array-complex-double-float-widetag
))
250 ((csubtypep ctype
(specifier-type '(complex single-float
)))
252 sb
!vm
:simple-array-complex-single-float-widetag
))
254 ((csubtypep ctype
(specifier-type '(complex long-float
)))
256 sb
!vm
:simple-array-complex-long-float-widetag
))
258 (result sb
!vm
:simple-vector-widetag
))))
260 (case (numeric-type-format ctype
)
263 sb
!vm
:simple-array-complex-double-float-widetag
))
266 sb
!vm
:simple-array-complex-single-float-widetag
))
270 sb
!vm
:simple-array-complex-long-float-widetag
))
272 (result sb
!vm
:simple-vector-widetag
)))))))))
274 (result sb
!vm
:simple-array-nil-widetag
))
278 (handler-case (specifier-type type
)
279 (parse-unknown-type ()
280 (return (result sb
!vm
:simple-vector-widetag
))))))
282 (union-type ; FIXME: forward ref
283 (let ((types (union-type-types ctype
)))
284 (cond ((not (every #'numeric-type-p types
))
285 (result sb
!vm
:simple-vector-widetag
))
286 ((csubtypep ctype
(specifier-type 'integer
))
287 (integer-interval-widetag
288 (reduce #'min types
:key
#'numeric-type-low
)
289 (reduce #'max types
:key
#'numeric-type-high
)))
290 ((csubtypep ctype
(specifier-type 'double-float
))
291 (result sb
!vm
:simple-array-double-float-widetag
))
292 ((csubtypep ctype
(specifier-type 'single-float
))
293 (result sb
!vm
:simple-array-single-float-widetag
))
295 ((csubtypep ctype
(specifier-type 'long-float
))
296 (result sb
!vm
:simple-array-long-float-widetag
))
298 (result sb
!vm
:simple-vector-widetag
)))))
299 (character-set-type ; FIXME: forward ref
300 #!-sb-unicode
(result sb
!vm
:simple-base-string-widetag
)
302 (if (loop for
(start . end
)
303 in
(character-set-type-pairs ctype
)
304 always
(and (< start base-char-code-limit
)
305 (< end base-char-code-limit
)))
306 (result sb
!vm
:simple-base-string-widetag
)
307 (result sb
!vm
:simple-character-string-widetag
)))
309 (let ((expansion (type-specifier ctype
)))
310 (if (equal expansion type
)
311 (result sb
!vm
:simple-vector-widetag
)
312 (%vector-widetag-and-n-bits expansion
)))))))))))))
314 (defun %complex-vector-widetag
(widetag)
315 (macrolet ((make-case ()
317 ,@(loop for saetp across sb
!vm
:*specialized-array-element-type-properties
*
318 for complex
= (sb!vm
:saetp-complex-typecode saetp
)
320 collect
(list (sb!vm
:saetp-typecode saetp
) complex
))
322 #.sb
!vm
:complex-vector-widetag
))))
325 (defglobal %%simple-array-n-bits%%
(make-array (1+ sb
!vm
:widetag-mask
)))
326 #.
(loop for info across sb
!vm
:*specialized-array-element-type-properties
*
327 collect
`(setf (aref %%simple-array-n-bits%%
,(sb!vm
:saetp-typecode info
))
328 ,(sb!vm
:saetp-n-bits info
)) into forms
329 finally
(return `(progn ,@forms
)))
331 (declaim (type (simple-vector #.
(1+ sb
!vm
:widetag-mask
)) %%simple-array-n-bits%%
))
333 (defun allocate-vector-with-widetag (widetag length
&optional n-bits
)
334 (declare (type (unsigned-byte 8) widetag
)
336 (let ((n-bits (or n-bits
(aref %%simple-array-n-bits%% widetag
))))
337 (declare (type (integer 0 256) n-bits
))
338 (allocate-vector widetag length
340 (* (if (or (= widetag sb
!vm
:simple-base-string-widetag
)
343 sb
!vm
:simple-character-string-widetag
))
347 sb
!vm
:n-word-bits
))))
349 (defun array-underlying-widetag (array)
350 (macrolet ((make-case ()
352 ,@(loop for saetp across sb
!vm
:*specialized-array-element-type-properties
*
353 for complex
= (sb!vm
:saetp-complex-typecode saetp
)
355 collect
(list complex
(sb!vm
:saetp-typecode saetp
)))
356 ((,sb
!vm
:simple-array-widetag
357 ,sb
!vm
:complex-vector-widetag
358 ,sb
!vm
:complex-array-widetag
)
359 (with-array-data ((array array
) (start) (end))
360 (declare (ignore start end
))
361 (%other-pointer-widetag array
)))
364 (let ((widetag (%other-pointer-widetag array
)))
367 ;; Complain in various ways about wrong :INITIAL-foo arguments,
368 ;; returning the two initialization arguments needed for DATA-VECTOR-FROM-INITS.
369 (defun validate-array-initargs (element-p element contents-p contents displaced
)
370 (cond ((and displaced
(or element-p contents-p
))
371 (if (and element-p contents-p
)
372 (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
373 may be specified with the :DISPLACED-TO option")
374 (error "~S may not be specified with the :DISPLACED-TO option"
375 (if element-p
:initial-element
:initial-contents
))))
376 ((and element-p contents-p
)
377 (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
378 (element-p (values :initial-element element
))
379 (contents-p (values :initial-contents contents
))
380 (t (values nil nil
))))
382 (declaim (inline %save-displaced-array-backpointer
))
383 (defun %save-displaced-array-backpointer
(array data
)
384 (flet ((purge (pointers)
385 (remove-if (lambda (value)
386 (or (not value
) (eq array value
)))
388 :key
#'weak-pointer-value
)))
389 ;; Add backpointer to the new data vector if it has a header.
390 (when (array-header-p data
)
391 (setf (%array-displaced-from data
)
392 (cons (make-weak-pointer array
)
393 (purge (%array-displaced-from data
)))))
394 ;; Remove old backpointer, if any.
395 (let ((old-data (%array-data-vector array
)))
396 (when (and (neq data old-data
) (array-header-p old-data
))
397 (setf (%array-displaced-from old-data
)
398 (purge (%array-displaced-from old-data
)))))))
400 ;;; Widetag is the widetag of the underlying vector,
401 ;;; it'll be the same as the resulting array widetag only for simple vectors
402 (defun %make-array
(dimensions widetag n-bits
405 (initial-element nil initial-element-p
)
406 (initial-contents nil initial-contents-p
)
407 adjustable fill-pointer
408 displaced-to displaced-index-offset
)
409 (declare (ignore element-type
))
410 (binding* (((array-rank dimension-0
)
411 (if (listp dimensions
)
412 (values (length dimensions
)
413 (if dimensions
(car dimensions
) 1))
414 (values 1 dimensions
)))
415 ((initialize initial-data
)
416 (validate-array-initargs initial-element-p initial-element
417 initial-contents-p initial-contents
419 (simple (and (null fill-pointer
)
421 (null displaced-to
))))
422 (declare (type array-rank array-rank
))
423 (declare (type index dimension-0
))
424 (cond ((and displaced-index-offset
(null displaced-to
))
425 (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
426 ((and simple
(= array-rank
1))
427 (let ((vector ; a (SIMPLE-ARRAY * (*))
428 (allocate-vector-with-widetag widetag dimension-0 n-bits
)))
429 ;; presence of at most one :INITIAL-thing keyword was ensured above
430 (cond (initial-element-p
431 (fill vector initial-element
))
433 (let ((content-length (length initial-contents
)))
434 (unless (= dimension-0 content-length
)
435 (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
436 the vector length is ~W."
437 content-length dimension-0
)))
438 (replace vector initial-contents
)))
440 ((and (arrayp displaced-to
)
441 (/= (array-underlying-widetag displaced-to
) widetag
))
442 (error "Array element type of :DISPLACED-TO array does not match specified element type"))
444 ;; it's non-simple or multidimensional, or both.
446 (unless (= array-rank
1)
447 (error "Only vectors can have fill pointers."))
448 (when (and (integerp fill-pointer
) (> fill-pointer dimension-0
))
449 ;; FIXME: should be TYPE-ERROR?
450 (error "invalid fill-pointer ~W" fill-pointer
)))
452 (if (consp dimensions
)
453 (the index
(reduce (lambda (a b
) (* a
(the index b
)))
455 ;; () is considered to have dimension-0 = 1.
456 ;; It avoids the REDUCE lambda being called with no args.
458 (data (or displaced-to
459 (data-vector-from-inits
460 dimensions total-size nil widetag n-bits
461 initialize initial-data
)))
462 (array (make-array-header
463 (cond ((= array-rank
1)
464 (%complex-vector-widetag widetag
))
465 (simple sb
!vm
:simple-array-widetag
)
466 (t sb
!vm
:complex-array-widetag
))
469 (setf (%array-fill-pointer-p array
) t
470 (%array-fill-pointer array
)
471 (if (eq fill-pointer t
) dimension-0 fill-pointer
))
472 (setf (%array-fill-pointer-p array
) nil
473 (%array-fill-pointer array
) total-size
))
474 (setf (%array-available-elements array
) total-size
)
475 ;; Terrible name for this slot - we displace to the
476 ;; target array's header, if any, not the "ultimate"
477 ;; vector in the chain of displacements.
478 (setf (%array-data-vector array
) data
)
479 (setf (%array-displaced-from array
) nil
)
481 (let ((offset (or displaced-index-offset
0)))
482 (when (> (+ offset total-size
)
483 (array-total-size displaced-to
))
484 (error "~S doesn't have enough elements." displaced-to
))
485 (setf (%array-displacement array
) offset
)
486 (setf (%array-displaced-p array
) t
)
487 (%save-displaced-array-backpointer array data
)))
489 (setf (%array-displaced-p array
) nil
)))
490 (if (listp dimensions
)
491 (let ((dims dimensions
)) ; avoid "prevents use of assertion"
492 (dotimes (axis array-rank
)
493 (setf (%array-dimension array axis
) (pop dims
))))
494 (setf (%array-dimension array
0) dimension-0
))
497 (defun make-array (dimensions &rest args
498 &key
(element-type t
)
499 initial-element initial-contents
503 displaced-index-offset
)
504 (declare (ignore initial-element
505 initial-contents adjustable
506 fill-pointer displaced-to displaced-index-offset
))
507 (declare (explicit-check))
508 (multiple-value-bind (widetag n-bits
) (%vector-widetag-and-n-bits element-type
)
509 (apply #'%make-array dimensions widetag n-bits args
)))
511 (defun make-static-vector (length &key
512 (element-type '(unsigned-byte 8))
513 (initial-contents nil initial-contents-p
)
514 (initial-element nil initial-element-p
))
516 "Allocate vector of LENGTH elements in static space. Only allocation
517 of specialized arrays is supported."
518 ;; STEP 1: check inputs fully
520 ;; This way of doing explicit checks before the vector is allocated
521 ;; is expensive, but probably worth the trouble as once we've allocated
522 ;; the vector we have no way to get rid of it anymore...
523 (when (eq t
(upgraded-array-element-type element-type
))
524 (error "Static arrays of type ~S not supported."
526 (validate-array-initargs initial-element-p initial-element
527 initial-contents-p initial-contents nil
) ; for effect
528 (when initial-contents-p
529 (unless (= length
(length initial-contents
))
530 (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
531 vector length is ~W."
532 (length initial-contents
)
534 (unless (every (lambda (x) (typep x element-type
)) initial-contents
)
535 (error ":INITIAL-CONTENTS contains elements not of type ~S."
537 (when initial-element-p
538 (unless (typep initial-element element-type
)
539 (error ":INITIAL-ELEMENT ~S is not of type ~S."
540 initial-element element-type
)))
543 ;; Allocate and possibly initialize the vector.
544 (multiple-value-bind (type n-bits
)
545 (%vector-widetag-and-n-bits element-type
)
547 (allocate-static-vector type length
548 (ceiling (* length n-bits
)
549 sb
!vm
:n-word-bits
))))
550 (cond (initial-element-p
551 (fill vector initial-element
))
553 (replace vector initial-contents
))
557 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the
558 ;;; specified array characteristics. Dimensions is only used to pass
559 ;;; to FILL-DATA-VECTOR for error checking on the structure of
560 ;;; initial-contents.
561 (defun data-vector-from-inits (dimensions total-size
562 element-type widetag n-bits
563 initialize initial-data
)
564 ;; FIXME: element-type can be NIL when widetag is non-nil,
565 ;; and FILL will check the type, although the error will be not as nice.
566 ;; (cond (typep initial-element element-type)
567 ;; (error "~S cannot be used to initialize an array of type ~S."
568 ;; initial-element element-type))
569 (let ((data (if widetag
570 (allocate-vector-with-widetag widetag total-size n-bits
)
571 (make-array total-size
:element-type element-type
))))
574 (fill (the vector data
) initial-data
))
576 ;; DIMENSIONS can be supplied as a list or integer now
577 (dx-let ((list-of-dims (list dimensions
))) ; ok if already a list
578 (fill-data-vector data
579 (if (listp dimensions
) dimensions list-of-dims
)
584 (defun vector (&rest objects
)
586 "Construct a SIMPLE-VECTOR from the given objects."
587 (let ((v (make-array (length objects
))))
588 (do-rest-arg ((x i
) objects
0 v
)
589 (setf (aref v i
) x
))))
592 ;;;; accessor/setter functions
594 ;;; Dispatch to an optimized routine the data vector accessors for
595 ;;; each different specialized vector type. Do dispatching by looking
596 ;;; up the widetag in the array rather than with the typecases, which
597 ;;; as of 1.0.5 compiles to a naive sequence of linear TYPEPs. Also
598 ;;; provide separate versions where bounds checking has been moved
599 ;;; from the callee to the caller, since it's much cheaper to do once
600 ;;; the type information is available. Finally, for each of these
601 ;;; routines also provide a slow path, taken for arrays that are not
602 ;;; vectors or not simple.
603 (macrolet ((def (name table-name
)
605 (defglobal ,table-name
(make-array ,(1+ sb
!vm
:widetag-mask
)))
606 (defmacro ,name
(array-var)
609 (when (sb!vm
::%other-pointer-p
,array-var
)
610 (setf tag
(%other-pointer-widetag
,array-var
)))
611 (svref ,',table-name tag
)))))))
612 (def !find-data-vector-setter %%data-vector-setters%%
)
613 (def !find-data-vector-setter
/check-bounds %%data-vector-setters
/check-bounds%%
)
614 ;; Used by DO-VECTOR-DATA -- which in turn appears in DOSEQUENCE expansion,
615 ;; meaning we can have post-build dependences on this.
616 (def %find-data-vector-reffer %%data-vector-reffers%%
)
617 (def !find-data-vector-reffer
/check-bounds %%data-vector-reffers
/check-bounds%%
))
619 ;;; Like DOVECTOR, but more magical -- can't use this on host.
620 (defmacro do-vector-data
((elt vector
&optional result
) &body body
)
621 (multiple-value-bind (forms decls
) (parse-body body nil
)
622 (with-unique-names (index vec start end ref
)
623 `(with-array-data ((,vec
,vector
)
626 :check-fill-pointer t
)
627 (let ((,ref
(%find-data-vector-reffer
,vec
)))
628 (do ((,index
,start
(1+ ,index
)))
631 ,@(filter-dolist-declarations decls
)
634 (let ((,elt
(funcall ,ref
,vec
,index
)))
636 (tagbody ,@forms
))))))))
638 (macrolet ((%ref
(accessor-getter extra-params
)
639 `(funcall (,accessor-getter array
) array index
,@extra-params
))
640 (define (accessor-name slow-accessor-name accessor-getter
641 extra-params check-bounds
)
643 (defun ,accessor-name
(array index
,@extra-params
)
644 (declare (explicit-check))
645 (declare (optimize speed
646 ;; (SAFETY 0) is ok. All calls to
647 ;; these functions are generated by
648 ;; the compiler, so argument count
649 ;; checking isn't needed. Type checking
650 ;; is done implicitly via the widetag
653 (%ref
,accessor-getter
,extra-params
))
654 (defun ,slow-accessor-name
(array index
,@extra-params
)
655 (declare (optimize speed
(safety 0)))
656 (if (not (%array-displaced-p array
))
657 ;; The reasonably quick path of non-displaced complex
659 (let ((array (%array-data-vector array
)))
660 (%ref
,accessor-getter
,extra-params
))
661 ;; The real slow path.
665 (declare (optimize (speed 1) (safety 1)))
666 (,@check-bounds index
)))
669 (declare (ignore end
))
670 (,accessor-name vector index
,@extra-params
)))))))
671 (define hairy-data-vector-ref slow-hairy-data-vector-ref
672 %find-data-vector-reffer
674 (define hairy-data-vector-set slow-hairy-data-vector-set
675 !find-data-vector-setter
677 (define hairy-data-vector-ref
/check-bounds
678 slow-hairy-data-vector-ref
/check-bounds
679 !find-data-vector-reffer
/check-bounds
680 nil
(check-bound array
(array-dimension array
0)))
681 (define hairy-data-vector-set
/check-bounds
682 slow-hairy-data-vector-set
/check-bounds
683 !find-data-vector-setter
/check-bounds
684 (new-value) (check-bound array
(array-dimension array
0))))
686 (defun hairy-ref-error (array index
&optional new-value
)
687 (declare (ignore index new-value
))
690 :expected-type
'vector
))
692 (macrolet ((define-reffer (saetp check-form
)
693 (let* ((type (sb!vm
:saetp-specifier saetp
))
694 (atype `(simple-array ,type
(*))))
695 `(named-lambda (optimized-data-vector-ref ,type
) (vector index
)
696 (declare (optimize speed
(safety 0))
697 ;; Obviously these all coerce raw words to lispobjs
698 ;; so don't keep spewing notes about it.
699 (muffle-conditions compiler-note
)
702 `(data-vector-ref (the ,atype vector
)
704 (declare (optimize (safety 1)))
706 (,@check-form index
))))
707 `(data-nil-vector-ref (the ,atype vector
) index
)))))
708 (define-setter (saetp check-form
)
709 (let* ((type (sb!vm
:saetp-specifier saetp
))
710 (atype `(simple-array ,type
(*))))
711 `(named-lambda (optimized-data-vector-set ,type
) (vector index new-value
)
712 (declare (optimize speed
(safety 0)))
713 ;; Impossibly setting an elt of an (ARRAY NIL)
714 ;; returns no value. And nobody cares.
715 (declare (muffle-conditions compiler-note
))
716 (data-vector-set (the ,atype vector
)
718 (declare (optimize (safety 1)))
720 (,@check-form index
)))
722 ;; SPEED 1 needed to avoid the compiler
723 ;; from downgrading the type check to
725 (declare (optimize (speed 1)
727 (the ,type new-value
)))
728 ;; For specialized arrays, the return from
729 ;; data-vector-set would have to be reboxed to be a
730 ;; (Lisp) return value; instead, we use the
731 ;; already-boxed value as the return.
733 (define-reffers (symbol deffer check-form slow-path
)
735 ;; FIXME/KLUDGE: can't just FILL here, because genesis doesn't
736 ;; preserve the binding, so re-initiaize as NS doesn't have
737 ;; the energy to figure out to change that right now.
738 (setf ,symbol
(make-array (1+ sb
!vm
::widetag-mask
)
739 :initial-element
#'hairy-ref-error
))
740 ,@(loop for widetag in
'(sb!vm
:complex-vector-widetag
741 sb
!vm
:complex-vector-nil-widetag
742 sb
!vm
:complex-bit-vector-widetag
743 #!+sb-unicode sb
!vm
:complex-character-string-widetag
744 sb
!vm
:complex-base-string-widetag
745 sb
!vm
:simple-array-widetag
746 sb
!vm
:complex-array-widetag
)
747 collect
`(setf (svref ,symbol
,widetag
) ,slow-path
))
748 ,@(loop for saetp across sb
!vm
:*specialized-array-element-type-properties
*
749 for widetag
= (sb!vm
:saetp-typecode saetp
)
750 collect
`(setf (svref ,symbol
,widetag
)
751 (,deffer
,saetp
,check-form
))))))
752 (defun !hairy-data-vector-reffer-init
()
753 (define-reffers %%data-vector-reffers%% define-reffer
755 #'slow-hairy-data-vector-ref
)
756 (define-reffers %%data-vector-setters%% define-setter
758 #'slow-hairy-data-vector-set
)
759 (define-reffers %%data-vector-reffers
/check-bounds%% define-reffer
760 (check-bound vector
(length vector
))
761 #'slow-hairy-data-vector-ref
/check-bounds
)
762 (define-reffers %%data-vector-setters
/check-bounds%% define-setter
763 (check-bound vector
(length vector
))
764 #'slow-hairy-data-vector-set
/check-bounds
)))
766 ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
767 ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
768 ;;; definition is needed for the compiler to use in constant folding.)
769 (defun data-vector-ref (array index
)
770 (declare (explicit-check))
771 (hairy-data-vector-ref array index
))
773 (defun data-vector-ref-with-offset (array index offset
)
774 (declare (explicit-check))
775 (hairy-data-vector-ref array
(+ index offset
)))
777 (defun invalid-array-p (array)
778 (and (array-header-p array
)
779 (consp (%array-displaced-p array
))))
781 (declaim (ftype (function (array) nil
) invalid-array-error
))
782 (defun invalid-array-error (array)
783 (aver (array-header-p array
))
784 ;; Array invalidation stashes the original dimensions here...
785 (let ((dims (%array-displaced-p array
))
786 (et (array-element-type array
)))
787 (error 'invalid-array-error
792 `(vector ,et
,@dims
)))))
794 (declaim (ftype (function (array t integer
&optional t
) nil
)
795 invalid-array-index-error
))
796 (defun invalid-array-index-error (array index bound
&optional axis
)
797 (if (invalid-array-p array
)
798 (invalid-array-error array
)
799 (error 'invalid-array-index-error
803 :expected-type
`(integer 0 (,bound
)))))
805 ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
806 (defun %array-row-major-index
(array &rest subscripts
)
807 (declare (truly-dynamic-extent subscripts
)
809 (let ((length (length subscripts
)))
810 (cond ((array-header-p array
)
811 (let ((rank (%array-rank array
)))
812 (unless (= rank length
)
813 (error "wrong number of subscripts, ~W, for array of rank ~W."
815 (do ((axis (1- rank
) (1- axis
))
818 ((minusp axis
) result
)
819 (declare (fixnum axis chunk-size result
))
820 (let ((index (fast-&rest-nth axis subscripts
))
821 (dim (%array-dimension array axis
)))
822 (unless (and (fixnump index
) (< -
1 index dim
))
823 (invalid-array-index-error array index dim axis
))
827 (truly-the fixnum
(* chunk-size index
))))
828 chunk-size
(truly-the fixnum
(* chunk-size dim
)))))))
830 (error "Wrong number of subscripts, ~W, for array of rank 1."
833 (let ((index (fast-&rest-nth
0 subscripts
))
834 (length (length (the (simple-array * (*)) array
))))
835 (unless (and (fixnump index
) (< -
1 index length
))
836 (invalid-array-index-error array index length
))
839 (defun array-in-bounds-p (array &rest subscripts
)
841 "Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise."
842 (declare (truly-dynamic-extent subscripts
))
843 (let ((length (length subscripts
)))
844 (cond ((array-header-p array
)
845 (let ((rank (%array-rank array
)))
846 (unless (= rank length
)
847 (error "Wrong number of subscripts, ~W, for array of rank ~W."
849 (loop for i below length
850 for s
= (fast-&rest-nth i subscripts
)
851 always
(and (typep s
'(and fixnum unsigned-byte
))
852 (< s
(%array-dimension array i
))))))
854 (error "Wrong number of subscripts, ~W, for array of rank 1."
857 (let ((subscript (fast-&rest-nth
0 subscripts
)))
858 (and (typep subscript
'(and fixnum unsigned-byte
))
860 (length (truly-the (simple-array * (*)) array
)))))))))
862 (defun array-row-major-index (array &rest subscripts
)
863 (declare (truly-dynamic-extent subscripts
))
864 (apply #'%array-row-major-index array subscripts
))
866 (defun aref (array &rest subscripts
)
868 "Return the element of the ARRAY specified by the SUBSCRIPTS."
869 (declare (truly-dynamic-extent subscripts
))
870 (row-major-aref array
(apply #'%array-row-major-index array subscripts
)))
872 ;;; (setf aref/bit/sbit) are implemented using setf-functions,
873 ;;; because they have to work with (setf (apply #'aref array subscripts))
874 ;;; All other setfs can be done using setf-functions too, but I
875 ;;; haven't found technical advantages or disadvantages for either
877 (defun (setf aref
) (new-value array
&rest subscripts
)
878 (declare (truly-dynamic-extent subscripts
)
880 (setf (row-major-aref array
(apply #'%array-row-major-index array subscripts
))
883 (defun row-major-aref (array index
)
885 "Return the element of array corresponding to the row-major index. This is
887 (declare (optimize (safety 1)))
888 (row-major-aref array index
))
890 (defun %set-row-major-aref
(array index new-value
)
891 (declare (optimize (safety 1)))
892 (setf (row-major-aref array index
) new-value
))
894 (defun svref (simple-vector index
)
896 "Return the INDEXth element of the given Simple-Vector."
897 (declare (optimize (safety 1)))
898 (aref simple-vector index
))
900 (defun %svset
(simple-vector index new
)
901 (declare (optimize (safety 1)))
902 (setf (aref simple-vector index
) new
))
904 (defun bit (bit-array &rest subscripts
)
906 "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
907 (declare (type (array bit
) bit-array
)
908 (truly-dynamic-extent subscripts
)
909 (optimize (safety 1)))
910 (row-major-aref bit-array
(apply #'%array-row-major-index bit-array subscripts
)))
912 (defun (setf bit
) (new-value bit-array
&rest subscripts
)
913 (declare (type (array bit
) bit-array
)
915 (truly-dynamic-extent subscripts
)
916 (optimize (safety 1)))
917 (setf (row-major-aref bit-array
918 (apply #'%array-row-major-index bit-array subscripts
))
921 (defun sbit (simple-bit-array &rest subscripts
)
923 "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
924 (declare (type (simple-array bit
) simple-bit-array
)
925 (truly-dynamic-extent subscripts
)
926 (optimize (safety 1)))
927 (row-major-aref simple-bit-array
928 (apply #'%array-row-major-index simple-bit-array subscripts
)))
930 (defun (setf sbit
) (new-value bit-array
&rest subscripts
)
931 (declare (type (simple-array bit
) bit-array
)
933 (truly-dynamic-extent subscripts
)
934 (optimize (safety 1)))
935 (setf (row-major-aref bit-array
936 (apply #'%array-row-major-index bit-array subscripts
))
939 ;;;; miscellaneous array properties
941 (defun array-element-type (array)
943 "Return the type of the elements of the array"
944 (let ((widetag (%other-pointer-widetag array
))
945 (table (load-time-value
946 (let ((table (make-array 256 :initial-element nil
)))
947 (dotimes (i (length sb
!vm
:*specialized-array-element-type-properties
*) table
)
948 (let* ((saetp (aref sb
!vm
:*specialized-array-element-type-properties
* i
))
949 (typecode (sb!vm
:saetp-typecode saetp
))
950 (complex-typecode (sb!vm
:saetp-complex-typecode saetp
))
951 (specifier (sb!vm
:saetp-specifier saetp
)))
952 (aver (typep specifier
'(or list symbol
)))
953 (setf (aref table typecode
) specifier
)
954 (when complex-typecode
955 (setf (aref table complex-typecode
) specifier
)))))
957 (let ((result (aref table widetag
)))
959 (truly-the (or list symbol
) result
)
960 ;; (MAKE-ARRAY :ELEMENT-TYPE NIL) goes to this branch, but
961 ;; gets the right answer in the end
962 (with-array-data ((array array
) (start) (end))
963 (declare (ignore start end
))
964 (truly-the (or list symbol
) (aref table
(%other-pointer-widetag array
))))))))
966 (defun array-rank (array)
968 "Return the number of dimensions of ARRAY."
969 (if (array-header-p array
)
973 (defun array-dimension (array axis-number
)
975 "Return the length of dimension AXIS-NUMBER of ARRAY."
976 (declare (array array
) (type index axis-number
))
977 (cond ((not (array-header-p array
))
978 (unless (= axis-number
0)
979 (error "Vector axis is not zero: ~S" axis-number
))
980 (length (the (simple-array * (*)) array
)))
981 ((>= axis-number
(%array-rank array
))
982 (error "Axis number ~W is too big; ~S only has ~D dimension~:P."
983 axis-number array
(%array-rank array
)))
985 (%array-dimension array axis-number
))))
987 (defun array-dimensions (array)
989 "Return a list whose elements are the dimensions of the array"
990 (declare (array array
))
991 (if (array-header-p array
)
992 (do ((results nil
(cons (array-dimension array index
) results
))
993 (index (1- (array-rank array
)) (1- index
)))
994 ((minusp index
) results
))
995 (list (array-dimension array
0))))
997 (defun array-total-size (array)
999 "Return the total number of elements in the Array."
1000 (declare (array array
))
1001 (if (array-header-p array
)
1002 (%array-available-elements array
)
1003 (length (the vector array
))))
1005 (defun array-displacement (array)
1007 "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
1008 options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
1009 (declare (type array array
))
1010 (if (and (array-header-p array
) ; if unsimple and
1011 (%array-displaced-p array
)) ; displaced
1012 (values (%array-data-vector array
) (%array-displacement array
))
1015 (defun adjustable-array-p (array)
1017 "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
1018 to the argument, this happens for complex arrays."
1019 (declare (array array
))
1020 ;; Note that this appears not to be a fundamental limitation.
1021 ;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
1022 ;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
1023 ;; -- CSR, 2004-03-01.
1024 (not (typep array
'simple-array
)))
1026 ;;;; fill pointer frobbing stuff
1028 (declaim (inline array-has-fill-pointer-p
))
1029 (defun array-has-fill-pointer-p (array)
1031 "Return T if the given ARRAY has a fill pointer, or NIL otherwise."
1032 (declare (array array
))
1033 (and (array-header-p array
) (%array-fill-pointer-p array
)))
1035 (defun fill-pointer-error (vector &optional arg
)
1037 (aver (array-has-fill-pointer-p vector
))
1038 (let ((max (%array-available-elements vector
)))
1039 (error 'simple-type-error
1041 :expected-type
(list 'integer
0 max
)
1042 :format-control
"The new fill pointer, ~S, is larger than the length of the vector (~S.)"
1043 :format-arguments
(list arg max
))))
1045 (error 'simple-type-error
1047 :expected-type
'(and vector
(satisfies array-has-fill-pointer-p
))
1048 :format-control
"~S is not an array with a fill pointer."
1049 :format-arguments
(list vector
)))))
1051 (declaim (inline fill-pointer
))
1052 (defun fill-pointer (vector)
1054 "Return the FILL-POINTER of the given VECTOR."
1055 (declare (explicit-check))
1056 (if (array-has-fill-pointer-p vector
)
1057 (%array-fill-pointer vector
)
1058 (fill-pointer-error vector
)))
1060 (defun %set-fill-pointer
(vector new
)
1061 (declare (explicit-check))
1063 (fill-pointer-error vector x
)))
1064 (if (array-has-fill-pointer-p vector
)
1065 (if (> new
(%array-available-elements vector
))
1067 (setf (%array-fill-pointer vector
) new
))
1070 ;;; FIXME: It'd probably make sense to use a MACROLET to share the
1071 ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro
1072 ;;; should probably be based on the VECTOR-PUSH-EXTEND code (which is
1073 ;;; new ca. sbcl-0.7.0) rather than the VECTOR-PUSH code (which dates
1074 ;;; back to CMU CL).
1075 (defun vector-push (new-element array
)
1077 "Attempt to set the element of ARRAY designated by its fill pointer
1078 to NEW-ELEMENT, and increment the fill pointer by one. If the fill pointer is
1079 too large, NIL is returned, otherwise the index of the pushed element is
1081 (declare (explicit-check))
1082 (let ((fill-pointer (fill-pointer array
)))
1083 (declare (fixnum fill-pointer
))
1084 (cond ((= fill-pointer
(%array-available-elements array
))
1087 (locally (declare (optimize (safety 0)))
1088 (setf (aref array fill-pointer
) new-element
))
1089 (setf (%array-fill-pointer array
) (1+ fill-pointer
))
1092 (defun vector-push-extend (new-element vector
&optional min-extension
)
1093 (declare (type (or null fixnum
) min-extension
))
1094 (declare (explicit-check))
1095 (let ((fill-pointer (fill-pointer vector
)))
1096 (declare (fixnum fill-pointer
))
1097 (when (= fill-pointer
(%array-available-elements vector
))
1098 (let ((min-extension
1100 (let ((length (length vector
)))
1102 (- array-dimension-limit length
))))))
1103 (adjust-array vector
(+ fill-pointer
(max 1 min-extension
)))))
1104 ;; disable bounds checking
1105 (locally (declare (optimize (safety 0)))
1106 (setf (aref vector fill-pointer
) new-element
))
1107 (setf (%array-fill-pointer vector
) (1+ fill-pointer
))
1110 (defun vector-pop (array)
1112 "Decrease the fill pointer by 1 and return the element pointed to by the
1114 (declare (explicit-check))
1115 (let ((fill-pointer (fill-pointer array
)))
1116 (declare (fixnum fill-pointer
))
1117 (if (zerop fill-pointer
)
1118 (error "There is nothing left to pop.")
1119 ;; disable bounds checking (and any fixnum test)
1120 (locally (declare (optimize (safety 0)))
1122 (setf (%array-fill-pointer array
)
1123 (1- fill-pointer
)))))))
1128 (defun adjust-array (array dimensions
&key
1129 (element-type (array-element-type array
) element-type-p
)
1130 (initial-element nil initial-element-p
)
1131 (initial-contents nil initial-contents-p
)
1133 displaced-to displaced-index-offset
)
1135 "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
1136 (when (invalid-array-p array
)
1137 (invalid-array-error array
))
1138 (binding* ((dimensions (ensure-list dimensions
))
1139 (array-rank (array-rank array
))
1141 (unless (= (length dimensions
) array-rank
)
1142 (error "The number of dimensions not equal to rank of array.")))
1143 ((initialize initial-data
)
1144 (validate-array-initargs initial-element-p initial-element
1145 initial-contents-p initial-contents
1147 (cond ((and element-type-p
1148 (not (subtypep element-type
(array-element-type array
))))
1149 ;; This is weird. Should check upgraded type against actual
1150 ;; array element type I think. See lp#1331299. CLHS says that
1151 ;; "consequences are unspecified" so current behavior isn't wrong.
1152 (error "The new element type, ~S, is incompatible with old type."
1154 ((and fill-pointer
(/= array-rank
1))
1155 (error "Only vectors can have fill pointers."))
1156 ((and fill-pointer
(not (array-has-fill-pointer-p array
)))
1157 ;; This case always struck me as odd. It seems like it might mean
1158 ;; that the user asks that the array gain a fill-pointer if it didn't
1159 ;; have one, yet CLHS is clear that the argument array must have a
1160 ;; fill-pointer or else signal a type-error.
1161 (fill-pointer-error array
)))
1162 (cond (initial-contents-p
1163 ;; array former contents replaced by INITIAL-CONTENTS
1164 (let* ((array-size (apply #'* dimensions
))
1165 (array-data (data-vector-from-inits
1166 dimensions array-size element-type nil nil
1167 initialize initial-data
)))
1168 (if (adjustable-array-p array
)
1169 (set-array-header array array-data array-size
1170 (get-new-fill-pointer array array-size
1172 0 dimensions nil nil
)
1173 (if (array-header-p array
)
1174 ;; simple multidimensional or single dimensional array
1175 (make-array dimensions
1176 :element-type element-type
1177 :initial-contents initial-contents
)
1180 ;; We already established that no INITIAL-CONTENTS was supplied.
1181 (unless (or (eql element-type
(array-element-type displaced-to
))
1182 (subtypep element-type
(array-element-type displaced-to
)))
1183 ;; See lp#1331299 again. Require exact match on upgraded type?
1184 (error "can't displace an array of type ~S into another of ~
1186 element-type
(array-element-type displaced-to
)))
1187 (let ((displacement (or displaced-index-offset
0))
1188 (array-size (apply #'* dimensions
)))
1189 (declare (fixnum displacement array-size
))
1190 (if (< (the fixnum
(array-total-size displaced-to
))
1191 (the fixnum
(+ displacement array-size
)))
1192 (error "The :DISPLACED-TO array is too small."))
1193 (if (adjustable-array-p array
)
1194 ;; None of the original contents appear in adjusted array.
1195 (set-array-header array displaced-to array-size
1196 (get-new-fill-pointer array array-size
1198 displacement dimensions t nil
)
1199 ;; simple multidimensional or single dimensional array
1200 (make-array dimensions
1201 :element-type element-type
1202 :displaced-to displaced-to
1203 :displaced-index-offset
1204 displaced-index-offset
))))
1206 (let ((old-length (array-total-size array
))
1207 (new-length (car dimensions
))
1209 (declare (fixnum old-length new-length
))
1210 (with-array-data ((old-data array
) (old-start)
1211 (old-end old-length
))
1212 (cond ((or (and (array-header-p array
)
1213 (%array-displaced-p array
))
1214 (< old-length new-length
))
1216 (data-vector-from-inits
1217 dimensions new-length element-type
1218 (%other-pointer-widetag old-data
) nil
1219 initialize initial-data
))
1220 ;; Provide :END1 to avoid full call to LENGTH
1222 (replace new-data old-data
1224 :start2 old-start
:end2 old-end
))
1226 (shrink-vector old-data new-length
))))
1227 (if (adjustable-array-p array
)
1228 (set-array-header array new-data new-length
1229 (get-new-fill-pointer array new-length
1231 0 dimensions nil nil
)
1234 (let ((old-length (%array-available-elements array
))
1235 (new-length (apply #'* dimensions
)))
1236 (declare (fixnum old-length new-length
))
1237 (with-array-data ((old-data array
) (old-start)
1238 (old-end old-length
))
1239 (declare (ignore old-end
))
1240 (let ((new-data (if (or (and (array-header-p array
)
1241 (%array-displaced-p array
))
1242 (> new-length old-length
)
1243 (not (adjustable-array-p array
)))
1244 (data-vector-from-inits
1245 dimensions new-length
1247 (%other-pointer-widetag old-data
) nil
1248 (if initial-element-p
:initial-element
)
1251 (if (or (zerop old-length
) (zerop new-length
))
1252 (when initial-element-p
(fill new-data initial-element
))
1253 (zap-array-data old-data
(array-dimensions array
)
1255 new-data dimensions new-length
1256 element-type initial-element
1258 (if (adjustable-array-p array
)
1259 (set-array-header array new-data new-length
1260 nil
0 dimensions nil nil
)
1263 sb
!vm
:simple-array-widetag array-rank
)))
1264 (set-array-header new-array new-data new-length
1265 nil
0 dimensions nil t
))))))))))
1268 (defun get-new-fill-pointer (old-array new-array-size fill-pointer
)
1269 (cond ((not fill-pointer
)
1270 ;; "The consequences are unspecified if array is adjusted to a
1271 ;; size smaller than its fill pointer ..."
1272 (when (array-has-fill-pointer-p old-array
)
1273 (when (> (%array-fill-pointer old-array
) new-array-size
)
1274 (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~
1275 smaller than its fill pointer (~S)"
1276 old-array new-array-size
(fill-pointer old-array
)))
1277 (%array-fill-pointer old-array
)))
1278 ((numberp fill-pointer
)
1279 (when (> fill-pointer new-array-size
)
1280 (error "can't supply a value for :FILL-POINTER (~S) that is larger ~
1281 than the new length of the vector (~S)"
1282 fill-pointer new-array-size
))
1284 ((eq fill-pointer t
)
1287 ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
1288 ;;; which must be less than or equal to its current length. This can
1289 ;;; be called on vectors without a fill pointer but it is extremely
1290 ;;; dangerous to do so: shrinking the size of an object (as viewed by
1291 ;;; the gc) makes bounds checking unreliable in the face of interrupts
1292 ;;; or multi-threading. Call it only on provably local vectors.
1293 (defun %shrink-vector
(vector new-length
)
1294 (declare (vector vector
))
1295 (unless (array-header-p vector
)
1296 (macrolet ((frob (name &rest things
)
1298 ((simple-array nil
(*)) (error 'nil-array-accessed-error
))
1299 ,@(mapcar (lambda (thing)
1300 (destructuring-bind (type-spec fill-value
)
1303 (fill (truly-the ,type-spec
,name
)
1305 :start new-length
))))
1307 ;; Set the 'tail' of the vector to the appropriate type of zero,
1308 ;; "because in some cases we'll scavenge larger areas in one go,
1309 ;; like groups of pages that had triggered the write barrier, or
1310 ;; the whole static space" according to jsnell.
1314 `((simple-array ,(sb!vm
:saetp-specifier saetp
) (*))
1315 ,(if (or (eq (sb!vm
:saetp-specifier saetp
) 'character
)
1317 (eq (sb!vm
:saetp-specifier saetp
) 'base-char
))
1318 *default-init-char-form
*
1319 (sb!vm
:saetp-initial-element-default saetp
))))
1321 #'sb
!vm
:saetp-specifier
1322 sb
!vm
:*specialized-array-element-type-properties
*)))))
1323 ;; Only arrays have fill-pointers, but vectors have their length
1324 ;; parameter in the same place.
1325 (setf (%array-fill-pointer vector
) new-length
)
1328 (defun shrink-vector (vector new-length
)
1329 (declare (vector vector
))
1331 ((eq (length vector
) new-length
)
1333 ((array-has-fill-pointer-p vector
)
1334 (setf (%array-fill-pointer vector
) new-length
)
1336 (t (subseq vector
0 new-length
))))
1338 ;;; BIG THREAD SAFETY NOTE
1340 ;;; ADJUST-ARRAY/SET-ARRAY-HEADER, and its callees are very
1341 ;;; thread unsafe. They are nonatomic, and can mess with parallel
1342 ;;; code using the same arrays.
1344 ;;; A likely seeming fix is an additional level of indirection:
1345 ;;; ARRAY-HEADER -> ARRAY-INFO -> ... where ARRAY-HEADER would
1346 ;;; hold nothing but the pointer to ARRAY-INFO, and ARRAY-INFO
1347 ;;; would hold everything ARRAY-HEADER now holds. This allows
1348 ;;; consing up a new ARRAY-INFO and replacing it atomically in
1349 ;;; the ARRAY-HEADER.
1351 ;;; %WALK-DISPLACED-ARRAY-BACKPOINTERS is an especially nasty
1352 ;;; one: not only is it needed extremely rarely, which makes
1353 ;;; any thread safety bugs involving it look like rare random
1354 ;;; corruption, but because it walks the chain *upwards*, which
1355 ;;; may violate user expectations.
1357 ;;; Fill in array header with the provided information, and return the array.
1358 (defun set-array-header (array data length fill-pointer displacement dimensions
1360 (labels ((%walk-displaced-array-backpointers
(array new-length
)
1361 (dolist (p (%array-displaced-from array
))
1362 (let ((from (weak-pointer-value p
)))
1363 (when (and from
(eq array
(%array-data-vector from
)))
1364 (let ((requires (+ (%array-available-elements from
)
1365 (%array-displacement from
))))
1366 (unless (>= new-length requires
)
1367 ;; ANSI sayeth (ADJUST-ARRAY dictionary entry):
1369 ;; "If A is displaced to B, the consequences are unspecified if B is
1370 ;; adjusted in such a way that it no longer has enough elements to
1373 ;; since we're hanging on a weak pointer here, we can't signal an
1374 ;; error right now: the array that we're looking at might be
1375 ;; garbage. Instead, we set all dimensions to zero so that next
1376 ;; safe access to the displaced array will trap. Additionally, we
1377 ;; save the original dimensions, so we can signal a more
1378 ;; understandable error when the time comes.
1379 (%walk-displaced-array-backpointers from
0)
1380 (setf (%array-fill-pointer from
) 0
1381 (%array-available-elements from
) 0
1382 (%array-displaced-p from
) (array-dimensions array
))
1383 (dotimes (i (%array-rank from
))
1384 (setf (%array-dimension from i
) 0)))))))))
1386 (setf (%array-displaced-from array
) nil
)
1387 (%walk-displaced-array-backpointers array length
))
1389 (%save-displaced-array-backpointer array data
))
1390 (setf (%array-data-vector array
) data
)
1391 (setf (%array-available-elements array
) length
)
1393 (setf (%array-fill-pointer array
) fill-pointer
)
1394 (setf (%array-fill-pointer-p array
) t
))
1396 (setf (%array-fill-pointer array
) length
)
1397 (setf (%array-fill-pointer-p array
) nil
)))
1398 (setf (%array-displacement array
) displacement
)
1399 (if (listp dimensions
)
1400 (dotimes (axis (array-rank array
))
1401 (declare (type index axis
))
1402 (setf (%array-dimension array axis
) (pop dimensions
)))
1403 (setf (%array-dimension array
0) dimensions
))
1404 (setf (%array-displaced-p array
) displacedp
)
1407 ;;; User visible extension
1408 (declaim (ftype (function (array) (values (simple-array * (*)) &optional
))
1409 array-storage-vector
))
1410 (defun array-storage-vector (array)
1412 "Returns the underlying storage vector of ARRAY, which must be a non-displaced array.
1414 In SBCL, if ARRAY is a of type \(SIMPLE-ARRAY * \(*)), it is its own storage
1415 vector. Multidimensional arrays, arrays with fill pointers, and adjustable
1416 arrays have an underlying storage vector with the same ARRAY-ELEMENT-TYPE as
1417 ARRAY, which this function returns.
1419 Important note: the underlying vector is an implementation detail. Even though
1420 this function exposes it, changes in the implementation may cause this
1421 function to be removed without further warning."
1422 ;; KLUDGE: Without TRULY-THE the system is not smart enough to figure out that
1423 ;; the return value is always of the known type.
1424 (truly-the (simple-array * (*))
1425 (if (array-header-p array
)
1426 (if (%array-displaced-p array
)
1427 (error "~S cannot be used with displaced arrays. Use ~S instead."
1428 'array-storage-vector
'array-displacement
)
1429 (%array-data-vector array
))
1433 ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
1435 ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
1436 ;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
1437 ;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
1438 ;;; is a displaced offset to be added to computed indices of OLD-DATA.
1439 (defun zap-array-data (old-data old-dims offset new-data new-dims new-length
1440 element-type initial-element initial-element-p
)
1441 (declare (list old-dims new-dims
)
1442 (fixnum new-length
))
1443 ;; OLD-DIMS comes from array-dimensions, which returns a fresh list
1444 ;; at least in SBCL.
1445 ;; NEW-DIMS comes from the user.
1446 (setf old-dims
(nreverse old-dims
)
1447 new-dims
(reverse new-dims
))
1448 (cond ((eq old-data new-data
)
1449 ;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and
1450 ;; INITIAL-ELEMENT-P are used when OLD-DATA and NEW-DATA are
1451 ;; EQ; in this case, a temporary must be used and filled
1452 ;; appropriately. specified initial-element.
1453 (when initial-element-p
1454 ;; FIXME: transforming this TYPEP to someting a bit faster
1455 ;; would be a win...
1456 (unless (typep initial-element element-type
)
1457 (error "~S can't be used to initialize an array of type ~S."
1458 initial-element element-type
)))
1459 (let ((temp (if initial-element-p
1460 (make-array new-length
:initial-element initial-element
)
1461 (make-array new-length
))))
1462 (declare (simple-vector temp
))
1463 (zap-array-data-aux old-data old-dims offset temp new-dims
)
1464 (dotimes (i new-length
)
1465 (setf (aref new-data i
) (aref temp i
)))
1466 ;; Kill the temporary vector to prevent garbage retention.
1467 (%shrink-vector temp
0)))
1469 ;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
1470 ;; already been filled with any
1471 (zap-array-data-aux old-data old-dims offset new-data new-dims
))))
1473 (defun zap-array-data-aux (old-data old-dims offset new-data new-dims
)
1474 (declare (fixnum offset
))
1475 (let ((limits (mapcar (lambda (x y
)
1476 (declare (fixnum x y
))
1477 (1- (the fixnum
(min x y
))))
1478 old-dims new-dims
)))
1479 (macrolet ((bump-index-list (index limits
)
1480 `(do ((subscripts ,index
(cdr subscripts
))
1481 (limits ,limits
(cdr limits
)))
1482 ((null subscripts
) :eof
)
1483 (cond ((< (the fixnum
(car subscripts
))
1484 (the fixnum
(car limits
)))
1486 (1+ (the fixnum
(car subscripts
))))
1488 (t (rplaca subscripts
0))))))
1489 (do ((index (make-list (length old-dims
) :initial-element
0)
1490 (bump-index-list index limits
)))
1492 (setf (aref new-data
(row-major-index-from-dims index new-dims
))
1494 (+ (the fixnum
(row-major-index-from-dims index old-dims
))
1497 ;;; Figure out the row-major-order index of an array reference from a
1498 ;;; list of subscripts and a list of dimensions. This is for internal
1499 ;;; calls only, and the subscripts and dim-list variables are assumed
1500 ;;; to be reversed from what the user supplied.
1501 (defun row-major-index-from-dims (rev-subscripts rev-dim-list
)
1502 (do ((rev-subscripts rev-subscripts
(cdr rev-subscripts
))
1503 (rev-dim-list rev-dim-list
(cdr rev-dim-list
))
1506 ((null rev-dim-list
) result
)
1507 (declare (fixnum chunk-size result
))
1508 (setq result
(+ result
1509 (the fixnum
(* (the fixnum
(car rev-subscripts
))
1511 (setq chunk-size
(* chunk-size
(the fixnum
(car rev-dim-list
))))))
1515 (defun bit-array-same-dimensions-p (array1 array2
)
1516 (declare (type (array bit
) array1 array2
))
1517 (and (= (array-rank array1
)
1518 (array-rank array2
))
1519 (dotimes (index (array-rank array1
) t
)
1520 (when (/= (array-dimension array1 index
)
1521 (array-dimension array2 index
))
1524 (defun pick-result-array (result-bit-array bit-array-1
)
1525 (case result-bit-array
1527 ((nil) (make-array (array-dimensions bit-array-1
)
1529 :initial-element
0))
1531 (unless (bit-array-same-dimensions-p bit-array-1
1533 (error "~S and ~S don't have the same dimensions."
1534 bit-array-1 result-bit-array
))
1537 (defmacro def-bit-array-op
(name function
)
1538 `(defun ,name
(bit-array-1 bit-array-2
&optional result-bit-array
)
1541 "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
1542 BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
1543 If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
1544 RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
1545 All the arrays must have the same rank and dimensions."
1546 (symbol-name function
))
1547 (declare (type (array bit
) bit-array-1 bit-array-2
)
1548 (type (or (array bit
) (member t nil
)) result-bit-array
))
1549 (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2
)
1550 (error "~S and ~S don't have the same dimensions."
1551 bit-array-1 bit-array-2
))
1552 (let ((result-bit-array (pick-result-array result-bit-array bit-array-1
)))
1553 (if (and (simple-bit-vector-p bit-array-1
)
1554 (simple-bit-vector-p bit-array-2
)
1555 (simple-bit-vector-p result-bit-array
))
1556 (locally (declare (optimize (speed 3) (safety 0)))
1557 (,name bit-array-1 bit-array-2 result-bit-array
))
1558 (with-array-data ((data1 bit-array-1
) (start1) (end1))
1559 (declare (ignore end1
))
1560 (with-array-data ((data2 bit-array-2
) (start2) (end2))
1561 (declare (ignore end2
))
1562 (with-array-data ((data3 result-bit-array
) (start3) (end3))
1563 (do ((index-1 start1
(1+ index-1
))
1564 (index-2 start2
(1+ index-2
))
1565 (index-3 start3
(1+ index-3
)))
1566 ((>= index-3 end3
) result-bit-array
)
1567 (declare (type index index-1 index-2 index-3
))
1568 (setf (sbit data3 index-3
)
1569 (logand (,function
(sbit data1 index-1
)
1570 (sbit data2 index-2
))
1573 (def-bit-array-op bit-and logand
)
1574 (def-bit-array-op bit-ior logior
)
1575 (def-bit-array-op bit-xor logxor
)
1576 (def-bit-array-op bit-eqv logeqv
)
1577 (def-bit-array-op bit-nand lognand
)
1578 (def-bit-array-op bit-nor lognor
)
1579 (def-bit-array-op bit-andc1 logandc1
)
1580 (def-bit-array-op bit-andc2 logandc2
)
1581 (def-bit-array-op bit-orc1 logorc1
)
1582 (def-bit-array-op bit-orc2 logorc2
)
1584 (defun bit-not (bit-array &optional result-bit-array
)
1586 "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
1587 putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
1588 BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
1589 created. Both arrays must have the same rank and dimensions."
1590 (declare (type (array bit
) bit-array
)
1591 (type (or (array bit
) (member t nil
)) result-bit-array
))
1592 (let ((result-bit-array (pick-result-array result-bit-array bit-array
)))
1593 (if (and (simple-bit-vector-p bit-array
)
1594 (simple-bit-vector-p result-bit-array
))
1595 (locally (declare (optimize (speed 3) (safety 0)))
1596 (bit-not bit-array result-bit-array
))
1597 (with-array-data ((src bit-array
) (src-start) (src-end))
1598 (declare (ignore src-end
))
1599 (with-array-data ((dst result-bit-array
) (dst-start) (dst-end))
1600 (do ((src-index src-start
(1+ src-index
))
1601 (dst-index dst-start
(1+ dst-index
)))
1602 ((>= dst-index dst-end
) result-bit-array
)
1603 (declare (type index src-index dst-index
))
1604 (setf (sbit dst dst-index
)
1605 (logxor (sbit src src-index
) 1))))))))
1607 ;;;; array type dispatching
1609 ;;; Given DISPATCH-FOO as the DISPATCH-NAME argument (unevaluated),
1610 ;;; defines the functions
1612 ;;; DISPATCH-FOO/SIMPLE-BASE-STRING
1613 ;;; DISPATCH-FOO/SIMPLE-CHARACTER-STRING
1614 ;;; DISPATCH-FOO/SIMPLE-ARRAY-SINGLE-FLOAT
1617 ;;; PARAMS are the function parameters in the definition of each
1618 ;;; specializer function. The array being specialized must be the
1619 ;;; first parameter in PARAMS. A type declaration for this parameter
1620 ;;; is automatically inserted into the body of each function.
1622 ;;; The dispatch table %%FOO-FUNS%% is defined and populated by these
1623 ;;; functions. The table is padded by the function
1624 ;;; HAIRY-FOO-DISPATCH-ERROR, also defined by DEFINE-ARRAY-DISPATCH.
1626 ;;; Finally, the DISPATCH-FOO macro is defined which does the actual
1627 ;;; dispatching when called. It expects arguments that match PARAMS.
1629 (defmacro define-array-dispatch
(dispatch-name params
&body body
)
1630 (let ((table-name (symbolicate "%%" dispatch-name
"-FUNS%%"))
1631 (error-name (symbolicate "HAIRY-" dispatch-name
"-ERROR")))
1633 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1634 (defun ,error-name
(&rest args
)
1637 :expected-type
'(simple-array * (*)))))
1638 (!defglobal
,table-name
(make-array ,(1+ sb
!vm
:widetag-mask
)
1639 :initial-element
#',error-name
))
1640 ,@(loop for info across sb
!vm
:*specialized-array-element-type-properties
*
1641 for typecode
= (sb!vm
:saetp-typecode info
)
1642 for specifier
= (sb!vm
:saetp-specifier info
)
1643 for primitive-type-name
= (sb!vm
:saetp-primitive-type-name info
)
1644 collect
(let ((fun-name (symbolicate (string dispatch-name
)
1645 "/" primitive-type-name
)))
1647 (defun ,fun-name
,params
1648 (declare (type (simple-array ,specifier
(*))
1651 (setf (svref ,table-name
,typecode
) #',fun-name
))))
1652 (defmacro ,dispatch-name
(&rest args
)
1653 (check-type (first args
) symbol
)
1654 (let ((tag (gensym "TAG")))
1658 (when (sb!vm
::%other-pointer-p
,(first args
))
1659 (setf ,tag
(%other-pointer-widetag
,(first args
))))
1660 (svref ,',table-name
,tag
)))
