;;;; functions to implement arrays
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB-VM")
(declaim (inline adjustable-array-p
array-displacement))
;;;; miscellaneous accessor functions
;;; These functions are only needed by the interpreter, 'cause the
;;; compiler inlines them.
(macrolet ((def (name)
`(progn
(defun ,name (array)
(,name array))
(defun (setf ,name) (value array)
(setf (,name array) value)))))
(def %array-fill-pointer)
(def %array-available-elements)
(def %array-data)
(def %array-displacement)
(def %array-displaced-p)
(def %array-displaced-from))
(defun %array-rank (array)
(%array-rank array))
(defun %array-dimension (array axis)
(%array-dimension array axis))
(defun %check-bound (array bound index)
(declare (type index bound)
(fixnum index))
(%check-bound array bound index))
(defun check-bound (array bound index)
(declare (type index bound)
(fixnum index))
(%check-bound array bound index)
index)
(defun %with-array-data/fp (array start end)
(%with-array-data-macro array start end :check-bounds t :check-fill-pointer t))
(defun %with-array-data (array start end)
(%with-array-data-macro array start end :check-bounds t :array-header-p t))
(defun %data-vector-and-index (array index)
(if (array-header-p array)
(multiple-value-bind (vector index)
(%with-array-data array index nil)
(values vector index))
(values (truly-the (simple-array * (*)) array) index)))
;;;; MAKE-ARRAY
(defun %integer-vector-widetag-and-n-bits-shift (signed high)
(let ((unsigned-table
#.(let ((map (make-array (1+ n-word-bits))))
(loop for saetp across
(reverse *specialized-array-element-type-properties*)
for ctype = (saetp-ctype saetp)
when (and (numeric-type-p ctype)
(eq (numeric-type-class ctype) 'integer)
(zerop (numeric-type-low ctype)))
do (fill map (cons (saetp-typecode saetp)
(saetp-n-bits-shift saetp))
:end (1+ (integer-length (numeric-type-high ctype)))))
map))
(signed-table
#.(let ((map (make-array (1+ n-word-bits))))
(loop for saetp across
(reverse *specialized-array-element-type-properties*)
for ctype = (saetp-ctype saetp)
when (and (numeric-type-p ctype)
(eq (numeric-type-class ctype) 'integer)
(minusp (numeric-type-low ctype)))
do (fill map (cons (saetp-typecode saetp)
(saetp-n-bits-shift saetp))
:end (+ (integer-length (numeric-type-high ctype)) 2)))
map)))
(cond ((> high n-word-bits)
(values #.simple-vector-widetag
#.(1- (integer-length n-word-bits))))
(signed
(let ((x (aref signed-table high)))
(values (car x) (cdr x))))
(t
(let ((x (aref unsigned-table high)))
(values (car x) (cdr x)))))))
;;; This is a bit complicated, but calling subtypep over all
;;; specialized types is exceedingly slow
(defun %vector-widetag-and-n-bits-shift (type)
(macrolet ((with-parameters ((arg-type &key intervals)
(&rest args) &body body)
(let ((type-sym (gensym)))
`(let (,@(loop for arg in args
collect `(,arg '*)))
(declare (ignorable ,@args))
(when (consp type)
(let ((,type-sym (cdr type)))
(block nil
,@(loop for arg in args
collect
`(cond ((consp ,type-sym)
(let ((value (pop ,type-sym)))
(if (or (eq value '*)
(typep value ',arg-type)
,(if intervals
`(and (consp value)
(null (cdr value))
(typep (car value)
',arg-type))))
(setf ,arg value)
(ill-type))))
((null ,type-sym)
(return))
(t
(ill-type)))))
(when ,type-sym
(ill-type))))
,@body)))
(ill-type ()
`(go fastidiously-parse))
(result (widetag)
(let ((value (symbol-value widetag)))
`(values ,value
,(saetp-n-bits-shift
(find value
*specialized-array-element-type-properties*
:key #'saetp-typecode))))))
(flet ((integer-interval-widetag (low high)
(if (minusp low)
(%integer-vector-widetag-and-n-bits-shift
t
(1+ (max (integer-length low) (integer-length high))))
(%integer-vector-widetag-and-n-bits-shift
nil
(max (integer-length low) (integer-length high))))))
(tagbody
(binding*
((consp (consp type))
(type-name (if consp (car type) type))
((widetag n-bits-shift)
(case type-name
((t)
(when consp
(ill-type))
(result simple-vector-widetag))
((base-char standard-char #-sb-unicode character)
(when consp
(ill-type))
(result simple-base-string-widetag))
#+sb-unicode
((character extended-char)
(when consp
(ill-type))
(result simple-character-string-widetag))
(bit
(when consp
(ill-type))
(result simple-bit-vector-widetag))
(fixnum
(when consp
(ill-type))
(result simple-array-fixnum-widetag))
(unsigned-byte
(with-parameters ((integer 1)) (high)
(if (eq high '*)
(result simple-vector-widetag)
(%integer-vector-widetag-and-n-bits-shift nil high))))
(signed-byte
(with-parameters ((integer 1)) (high)
(if (eq high '*)
(result simple-vector-widetag)
(%integer-vector-widetag-and-n-bits-shift t high))))
(double-float
(with-parameters (double-float :intervals t) (low high)
(if (and (not (eq low '*))
(not (eq high '*))
(if (or (consp low) (consp high))
(>= (type-bound-number low) (type-bound-number high))
(> low high)))
(result simple-array-nil-widetag)
(result simple-array-double-float-widetag))))
(single-float
(with-parameters (single-float :intervals t) (low high)
(if (and (not (eq low '*))
(not (eq high '*))
(if (or (consp low) (consp high))
(>= (type-bound-number low) (type-bound-number high))
(> low high)))
(result simple-array-nil-widetag)
(result simple-array-single-float-widetag))))
(mod
(if (and (consp type)
(consp (cdr type))
(null (cddr type))
(typep (cadr type) '(integer 1)))
(%integer-vector-widetag-and-n-bits-shift
nil (integer-length (1- (cadr type))))
(ill-type)))
#+long-float
(long-float
(with-parameters (long-float :intervals t) (low high)
(if (and (not (eq low '*))
(not (eq high '*))
(if (or (consp low) (consp high))
(>= (type-bound-number low) (type-bound-number high))
(> low high)))
(result simple-array-nil-widetag)
(result simple-array-long-float-widetag))))
(integer
(with-parameters (integer :intervals t) (low high)
(let ((low (if (consp low)
(1+ (car low))
low))
(high (if (consp high)
(1- (car high))
high)))
(cond ((or (eq high '*)
(eq low '*))
(result simple-vector-widetag))
((> low high)
(result simple-array-nil-widetag))
(t
(integer-interval-widetag low high))))))
(complex
(with-parameters (t) (subtype)
(if (eq subtype '*)
(result simple-vector-widetag)
(let ((ctype (specifier-type type)))
(cond ((eq ctype *empty-type*)
(result simple-array-nil-widetag))
((union-type-p ctype)
(cond ((csubtypep ctype (specifier-type '(complex double-float)))
(result
simple-array-complex-double-float-widetag))
((csubtypep ctype (specifier-type '(complex single-float)))
(result
simple-array-complex-single-float-widetag))
#+long-float
((csubtypep ctype (specifier-type '(complex long-float)))
(result
simple-array-complex-long-float-widetag))
(t
(result simple-vector-widetag))))
(t
(case (numeric-type-format ctype)
(double-float
(result
simple-array-complex-double-float-widetag))
(single-float
(result
simple-array-complex-single-float-widetag))
#+long-float
(long-float
(result
simple-array-complex-long-float-widetag))
(t
(result simple-vector-widetag)))))))))
((nil)
(result simple-array-nil-widetag))
(t
(go fastidiously-parse)))))
(return-from %vector-widetag-and-n-bits-shift
(values widetag n-bits-shift)))
fastidiously-parse)
;; Do things the hard way after falling through the tagbody.
(let* ((ctype (type-or-nil-if-unknown type))
(ctype (and ctype
(sb-kernel::replace-hairy-type ctype))))
(typecase ctype
(null (result simple-vector-widetag))
(union-type
(let ((types (union-type-types ctype)))
(cond ((not (every #'numeric-type-p types))
(result simple-vector-widetag))
((csubtypep ctype (specifier-type 'integer))
(block nil
(integer-interval-widetag
(dx-flet ((low (x)
(or (numeric-type-low x)
(return (result simple-vector-widetag)))))
(reduce #'min types :key #'low))
(dx-flet ((high (x)
(or (numeric-type-high x)
(return (result simple-vector-widetag)))))
(reduce #'max types :key #'high)))))
((csubtypep ctype (specifier-type 'double-float))
(result simple-array-double-float-widetag))
((csubtypep ctype (specifier-type 'single-float))
(result simple-array-single-float-widetag))
#+long-float
((csubtypep ctype (specifier-type 'long-float))
(result simple-array-long-float-widetag))
((csubtypep ctype (specifier-type 'complex-double-float))
(result simple-array-complex-double-float-widetag))
((csubtypep ctype (specifier-type 'complex-single-float))
(result simple-array-complex-single-float-widetag))
(t
(result simple-vector-widetag)))))
(intersection-type
(let ((types (intersection-type-types ctype)))
(loop for type in types
unless (hairy-type-p type)
return (%vector-widetag-and-n-bits-shift (type-specifier type)))))
(character-set-type
#-sb-unicode (result simple-base-string-widetag)
#+sb-unicode
(if (loop for (start . end)
in (character-set-type-pairs ctype)
always (and (< start base-char-code-limit)
(< end base-char-code-limit)))
(result simple-base-string-widetag)
(result simple-character-string-widetag)))
(t
(let ((expansion (type-specifier ctype)))
(if (equal expansion type)
(result simple-vector-widetag)
(%vector-widetag-and-n-bits-shift expansion)))))))))
(defun %complex-vector-widetag (widetag)
(macrolet ((make-case ()
`(case widetag
,@(loop for saetp across *specialized-array-element-type-properties*
for complex = (saetp-complex-typecode saetp)
when complex
collect (list (saetp-typecode saetp) complex))
(t
#.complex-vector-widetag))))
(make-case)))
(declaim (inline vector-length-in-words))
(defun vector-length-in-words (length n-bits-shift)
(declare (type (integer 0 7) n-bits-shift))
(let ((mask (ash (1- n-word-bits) (- n-bits-shift)))
(shift (- n-bits-shift
(1- (integer-length n-word-bits)))))
(ash (+ length mask) shift)))
;;; N-BITS-SHIFT is the shift amount needed to turn LENGTH into array-size-in-bits,
;;; i.e. log(2,bits-per-elt)
(defun allocate-vector-with-widetag (#+ubsan poisoned widetag length n-bits-shift)
(declare (type (unsigned-byte 8) widetag)
(type index length))
(let* ( ;; KLUDGE: add SAETP-N-PAD-ELEMENTS "by hand" since there is
;; but a single case involving it now.
(full-length (+ length (if (= widetag simple-base-string-widetag) 1 0)))
;; Be careful not to allocate backing storage for element type NIL.
;; Both it and type BIT have N-BITS-SHIFT = 0, so the determination
;; of true size can't be left up to VECTOR-LENGTH-IN-WORDS.
;; VECTOR-LENGTH-IN-WORDS potentially returns a machine-word-sized
;; integer, so it doesn't match the primitive type restriction of
;; POSITIVE-FIXNUM for the last argument of the vector alloc vops.
(nwords (the fixnum
(if (/= widetag simple-array-nil-widetag)
(vector-length-in-words full-length n-bits-shift)
0))))
#+ubsan (if poisoned ; first arg to allocate-vector must be a constant
(allocate-vector t widetag length nwords)
(allocate-vector nil widetag length nwords))
#-ubsan (allocate-vector widetag length nwords)))
(declaim (ftype (sfunction (array) (integer 128 255)) array-underlying-widetag))
(defun array-underlying-widetag (array)
(macrolet ((generate-table ()
(macrolet ((to-index (x) `(ash ,x -2)))
(let ((table (sb-xc:make-array 64 :initial-element 0
:element-type '(unsigned-byte 8))))
(dovector (saetp *specialized-array-element-type-properties*)
(let* ((typecode (saetp-typecode saetp))
(complex-typecode (saetp-complex-typecode saetp)))
(setf (aref table (to-index typecode)) typecode)
(when complex-typecode
(setf (aref table (to-index complex-typecode)) typecode))))
(setf (aref table (to-index simple-array-widetag)) 0
(aref table (to-index complex-vector-widetag)) 0
(aref table (to-index complex-array-widetag)) 0)
table)))
(to-index (x) `(ash ,x -2)))
(named-let recurse ((x array))
(let ((result (aref (generate-table)
(to-index (%other-pointer-widetag x)))))
(if (= 0 result)
(recurse (%array-data x))
(truly-the (integer 128 255) result))))))
;; Complain in various ways about wrong MAKE-ARRAY and ADJUST-ARRAY arguments,
;; returning the two initialization arguments needed for DATA-VECTOR-FROM-INITS.
;; This is an unhygienic macro which would be a MACROLET other than for
;; doing so would entail moving toplevel defuns around for no good reason.
(defmacro check-make-array-initargs (displaceable &optional element-type size)
`(cond ,@(when displaceable
`((displaced-to
(when (or element-p contents-p)
(if (and element-p contents-p)
(error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
may be specified with the :DISPLACED-TO option")
(error "~S may not be specified with the :DISPLACED-TO option"
(if element-p :initial-element :initial-contents))))
(unless (= (array-underlying-widetag displaced-to) widetag)
;; Require exact match on upgraded type (lp#1331299)
(error "Can't displace an array of type ~/sb-impl:print-type-specifier/ ~
into another of type ~/sb-impl:print-type-specifier/"
,element-type (array-element-type displaced-to)))
(when (< (array-total-size displaced-to)
(+ displaced-index-offset ,size))
(error "The :DISPLACED-TO array is too small.")))
(offset-p
(error "Can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))))
((and element-p contents-p)
(error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
(element-p (values :initial-element initial-element))
(contents-p (values :initial-contents initial-contents))))
(defmacro make-array-bad-fill-pointer (actual max adjective)
;; There was a comment implying that this should be TYPE-ERROR
;; but I don't see that as a spec requirement.
`(error "Can't supply a value for :FILL-POINTER (~S) that is larger ~
than the~A size of the vector (~S)" ,actual ,adjective ,max))
(declaim (inline %save-displaced-array-backpointer))
(defun %save-displaced-array-backpointer (array data)
(flet ((purge (pointers)
(remove-if (lambda (value)
(or (not value) (eq array value)))
pointers
:key #'weak-pointer-value)))
;; Add backpointer to the new data vector if it has a header.
(when (array-header-p data)
(setf (%array-displaced-from data)
(cons (make-weak-pointer array)
(purge (%array-displaced-from data)))))
;; Remove old backpointer, if any.
(let ((old-data (%array-data array)))
(when (and (neq data old-data) (array-header-p old-data))
(setf (%array-displaced-from old-data)
(purge (%array-displaced-from old-data)))))))
(defmacro populate-dimensions (header list-or-index rank)
`(if (listp ,list-or-index)
(let ((dims ,list-or-index))
(dotimes (axis ,rank)
(declare ((integer 0 ,array-rank-limit) axis))
(%set-array-dimension ,header axis (pop dims))))
(%set-array-dimension ,header 0 ,list-or-index)))
(declaim (inline rank-and-total-size-from-dims))
(defun rank-and-total-size-from-dims (dims)
(cond ((not (listp dims)) (values 1 (the index dims)))
((not dims) (values 0 1))
(t (let ((rank 1) (product (car dims)))
(declare (array-rank rank) (index product))
(dolist (dim (cdr dims) (values rank product))
(setq product (* product (the index dim)))
(incf rank))))))
(defconstant-eqx +widetag->element-type+
#.(let ((a (make-array 32 :initial-element 0)))
(dovector (saetp *specialized-array-element-type-properties* a)
(let ((tag (saetp-typecode saetp)))
(setf (aref a (ash (- tag #x80) -2)) (saetp-specifier saetp)))))
#'equalp)
(declaim (inline widetag->element-type))
(defun widetag->element-type (widetag)
(svref +widetag->element-type+ (- (ash widetag -2) 32)))
;;; Widetag is the widetag of the underlying vector,
;;; it'll be the same as the resulting array widetag only for simple vectors
(defun %make-array (dimensions widetag n-bits
&key
element-type
(initial-element nil element-p)
(initial-contents nil contents-p)
adjustable fill-pointer
displaced-to
(displaced-index-offset 0 offset-p))
(declare (ignore element-type))
(binding* (((array-rank total-size) (rank-and-total-size-from-dims dimensions))
((initialize initial-data)
;; element-type might not be supplied, but widetag->element is always good
(check-make-array-initargs t (widetag->element-type widetag) total-size))
(simple (and (null fill-pointer)
(not adjustable)
(null displaced-to))))
(cond ((and simple (= array-rank 1))
(let ((vector ; a (SIMPLE-ARRAY * (*))
(allocate-vector-with-widetag #+ubsan (not (or element-p contents-p))
widetag total-size n-bits)))
;; presence of at most one :INITIAL-thing keyword was ensured above
(cond (element-p
(fill vector initial-element))
(contents-p
(let ((content-length (length initial-contents)))
(unless (= total-size content-length)
(error "There are ~W elements in the :INITIAL-CONTENTS, but ~
the vector length is ~W."
content-length total-size)))
(replace vector initial-contents))
#+ubsan
(t
;; store the function which bears responsibility for creation of this
;; array in case we need to blame it for not initializing.
(set-vector-extra-data (if (= widetag simple-vector-widetag) ; no shadow bits.
vector ; use the LENGTH slot directly
(vector-extra-data vector))
(ash (sap-ref-word (current-fp) n-word-bytes) 3)) ; XXX: magic
(cond ((= widetag simple-vector-widetag)
(fill vector (%make-lisp-obj no-tls-value-marker-widetag)))
((array-may-contain-random-bits-p widetag)
;; Leave the last word alone for base-string,
;; in case the mandatory trailing null is part of a data word.
(dotimes (i (- (vector-length-in-words total-size n-bits)
(if (= widetag simple-base-string-widetag) 1 0)))
(setf (%vector-raw-bits vector i) sb-ext:most-positive-word))))))
vector))
(t
;; it's non-simple or multidimensional, or both.
(when fill-pointer
(unless (= array-rank 1)
(error "Only vectors can have fill pointers."))
(when (and (integerp fill-pointer) (> fill-pointer total-size))
(make-array-bad-fill-pointer fill-pointer total-size "")))
(let* ((data (or displaced-to
(data-vector-from-inits dimensions total-size widetag n-bits
initialize initial-data)))
(array (make-array-header
(cond ((= array-rank 1)
(%complex-vector-widetag widetag))
(simple simple-array-widetag)
(t complex-array-widetag))
array-rank)))
(cond (fill-pointer
(logior-header-bits array +array-fill-pointer-p+)
(setf (%array-fill-pointer array)
(if (eq fill-pointer t) total-size fill-pointer)))
(t
(reset-header-bits array +array-fill-pointer-p+)
(setf (%array-fill-pointer array) total-size)))
(setf (%array-available-elements array) total-size)
(setf (%array-data array) data)
(setf (%array-displaced-from array) nil)
(cond (displaced-to
(let ((offset (or displaced-index-offset 0)))
(when (> (+ offset total-size)
(array-total-size displaced-to))
(error "~S doesn't have enough elements." displaced-to))
(setf (%array-displacement array) offset)
(setf (%array-displaced-p array) t)
(%save-displaced-array-backpointer array data)))
(t
(setf (%array-displaced-p array) nil)))
(populate-dimensions array dimensions array-rank)
array)))))
(defun make-array (dimensions &rest args
&key (element-type t)
initial-element initial-contents
adjustable
fill-pointer
displaced-to
displaced-index-offset)
(declare (ignore initial-element
initial-contents adjustable
fill-pointer displaced-to displaced-index-offset))
(declare (explicit-check))
(multiple-value-bind (widetag shift) (%vector-widetag-and-n-bits-shift element-type)
(apply #'%make-array dimensions widetag shift args)))
(defun make-static-vector (length &key
(element-type '(unsigned-byte 8))
(initial-contents nil contents-p)
(initial-element nil element-p))
"Allocate vector of LENGTH elements in static space. Only allocation
of specialized arrays is supported."
;; STEP 1: check inputs fully
;;
;; This way of doing explicit checks before the vector is allocated
;; is expensive, but probably worth the trouble as once we've allocated
;; the vector we have no way to get rid of it anymore...
(when (eq t (upgraded-array-element-type element-type))
(error "Static arrays of type ~/sb-impl:print-type-specifier/ not supported."
element-type))
(check-make-array-initargs nil) ; for effect
(when contents-p
(unless (= length (length initial-contents))
(error "There are ~W elements in the :INITIAL-CONTENTS, but the ~
vector length is ~W."
(length initial-contents)
length))
(unless (every (lambda (x) (typep x element-type)) initial-contents)
(error ":INITIAL-CONTENTS contains elements not of type ~
~/sb-impl:print-type-specifier/."
element-type)))
(when element-p
(unless (typep initial-element element-type)
(error ":INITIAL-ELEMENT ~S is not of type ~
~/sb-impl:print-type-specifier/."
initial-element element-type)))
;; STEP 2
;;
;; Allocate and possibly initialize the vector.
(multiple-value-bind (type n-bits-shift)
(%vector-widetag-and-n-bits-shift element-type)
(let* ((full-length
;; KLUDGE: add SAETP-N-PAD-ELEMENTS "by hand" since there is
;; but a single case involving it now.
(+ length (if (= type simple-base-string-widetag) 1 0)))
(vector
(allocate-static-vector type length
(vector-length-in-words full-length
n-bits-shift))))
(cond (element-p
(fill vector initial-element))
(contents-p
(replace vector initial-contents))
(t
vector)))))
#+darwin-jit
(defun make-static-code-vector (length initial-contents)
"Allocate vector of LENGTH elements in static space. Only allocation
of specialized arrays is supported."
(let ((vector (allocate-static-code-vector simple-array-unsigned-byte-8-widetag
length
(* length n-word-bytes))))
(with-pinned-objects (initial-contents)
(jit-memcpy (vector-sap vector) (vector-sap initial-contents) length))
vector))
;;; DATA-VECTOR-FROM-INITS returns a simple rank-1 array that has the
;;; specified array characteristics. Dimensions is only used to pass
;;; to FILL-DATA-VECTOR for error checking on the structure of
;;; initial-contents.
(defun data-vector-from-inits (dimensions total-size widetag n-bits initialize initial-data)
(declare (fixnum widetag n-bits)) ; really just that they're non-nil
(let ((data (allocate-vector-with-widetag #+ubsan (not initialize) widetag total-size n-bits)))
(ecase initialize
(:initial-element
(fill (the vector data) initial-data))
(:initial-contents
;; DIMENSIONS can be supplied as a list or integer now
(dx-let ((list-of-dims (list dimensions))) ; ok if already a list
(fill-data-vector data
(if (listp dimensions) dimensions list-of-dims)
initial-data)))
((nil)))
data))
(defun vector (&rest objects)
"Construct a SIMPLE-VECTOR from the given objects."
(let ((v (make-array (length objects))))
(do-rest-arg ((x i) objects 0 v)
(setf (aref v i) x))))
;;;; accessor/setter functions
;;; Dispatch to an optimized routine the data vector accessors for
;;; each different specialized vector type. Do dispatching by looking
;;; up the widetag in the array rather than with the typecases, which
;;; as of 1.0.5 compiles to a naive sequence of linear TYPEPs. Also
;;; provide separate versions where bounds checking has been moved
;;; from the callee to the caller, since it's much cheaper to do once
;;; the type information is available. Finally, for each of these
;;; routines also provide a slow path, taken for arrays that are not
;;; vectors or not simple.
;;; FIXME: how is this not redundant with DEFINE-ARRAY-DISPATCH?
;;; Which is to say, why did DEFINE-ARRAY-DISPATCH decide to do
;;; something different instead of figuring out how to unify the ways
;;; that we call an element of an array accessed by widetag?
(macrolet ((def (name table-name)
`(progn
(define-load-time-global ,table-name
(make-array ,(1+ widetag-mask)))
(declaim (type (simple-array function (,(1+ widetag-mask)))
,table-name))
(defmacro ,name (array-var)
`(the function
;; Assigning TAG to 0 initially produces slightly better
;; code than would be generated by the more natural expression
;; (let ((tag (if (%other-ptr ...) (widetag ...) 0)))
;; but either way is suboptimal. As expressed, if the array-var
;; is known to satisfy %other-pointer-p, then it performs a
;; move-immediate-to-register which is clobbered right away
;; by a zero-extending load. A peephole pass could eliminate
;; the first move as effectless. If expressed the other way,
;; it would produce a jump around a jump because the compiler
;; is unwilling to *unconditionally* assign 0 into a register
;; to begin with. It actually wants to guard an immediate load
;; when it doesn't need to, as if both consequents of the IF
;; have side-effects that should not happen.
(let ((tag 0))
(when (%other-pointer-p ,array-var)
(setf tag (%other-pointer-widetag ,array-var)))
(svref ,',table-name tag)))))))
(def !find-data-vector-setter %%data-vector-setters%%)
(def !find-data-vector-setter/check-bounds %%data-vector-setters/check-bounds%%)
;; Used by DO-VECTOR-DATA -- which in turn appears in DOSEQUENCE expansion,
;; meaning we can have post-build dependences on this.
(def %find-data-vector-reffer %%data-vector-reffers%%)
(def !find-data-vector-reffer/check-bounds %%data-vector-reffers/check-bounds%%))
;;; Like DOVECTOR, but more magical -- can't use this on host.
(defmacro sb-impl::do-vector-data ((elt vector &optional result) &body body)
(multiple-value-bind (forms decls) (parse-body body nil)
(with-unique-names (index vec start end ref)
`(with-array-data ((,vec ,vector)
(,start)
(,end)
:check-fill-pointer t)
(let ((,ref (%find-data-vector-reffer ,vec)))
(declare (function ,ref))
(do ((,index ,start (1+ ,index)))
((>= ,index ,end)
(let ((,elt nil))
,@(sb-impl::filter-dolist-declarations decls)
,elt
,result))
(let ((,elt (funcall ,ref ,vec ,index)))
,@decls
(tagbody ,@forms))))))))
;;; We need this constant to be dumped in such a way that genesis can directly
;;; compute the symbol-value in cold load, and not defer the reference until
;;; *!cold-toplevels* are evaluated. That's because GROW-HASH-TABLE calls REPLACE
;;; which calls VECTOR-REPLACE which tries to reference the array of functions,
;;; which had better not be deferred, or all hell breaks loose. It's actually
;;; tricky to call any function in any file that has its toplevel forms evaluated
;;; later than the current file, because you don't generally know whether code
;;; blobs in that other file have had their L-T-V fixups patched in.
(defconstant-eqx +blt-copier-for-widetag+ #.(make-array 32 :initial-element nil)
#'equalp)
(macrolet ((%ref (accessor-getter extra-params)
`(funcall (,accessor-getter array) array index ,@extra-params))
(define (accessor-name slow-accessor-name accessor-getter
extra-params check-bounds)
`(progn
(defun ,accessor-name (array index ,@extra-params)
(declare (explicit-check))
(declare (optimize speed
;; (SAFETY 0) is ok. All calls to
;; these functions are generated by
;; the compiler, so argument count
;; checking isn't needed. Type checking
;; is done implicitly via the widetag
;; dispatch.
(safety 0)))
(%ref ,accessor-getter ,extra-params))
(defun ,slow-accessor-name (array index ,@extra-params)
(declare (optimize speed (safety 0)))
(if (not (%array-displaced-p array))
;; The reasonably quick path of non-displaced complex
;; arrays.
(let ((array (%array-data array)))
(%ref ,accessor-getter ,extra-params))
;; The real slow path.
(with-array-data
((vector array)
(index (locally
(declare (optimize (speed 1) (safety 1)))
(,@check-bounds index)))
(end)
:force-inline t)
(declare (ignore end))
(,accessor-name vector index ,@extra-params)))))))
(define hairy-data-vector-ref slow-hairy-data-vector-ref
%find-data-vector-reffer
nil (progn))
(define hairy-data-vector-set slow-hairy-data-vector-set
!find-data-vector-setter
(new-value) (progn))
(define hairy-data-vector-ref/check-bounds
slow-hairy-data-vector-ref/check-bounds
!find-data-vector-reffer/check-bounds
nil (check-bound array (%array-dimension array 0)))
(define hairy-data-vector-set/check-bounds
slow-hairy-data-vector-set/check-bounds
!find-data-vector-setter/check-bounds
(new-value) (check-bound array (%array-dimension array 0))))
(defun hairy-ref-error (array index &optional new-value)
(declare (ignore index new-value))
(error 'type-error
:datum array
:expected-type 'vector))
(macrolet ((define-reffer (saetp check-form)
(let* ((type (saetp-specifier saetp))
(atype `(simple-array ,type (*))))
`(named-lambda (optimized-data-vector-ref ,type) (vector index)
(declare (optimize speed (safety 0))
;; Obviously these all coerce raw words to lispobjs
;; so don't keep spewing notes about it.
(muffle-conditions compiler-note)
(ignorable index))
,(if type
`(data-vector-ref (the ,atype vector)
(locally
(declare (optimize (safety 1)))
(the index
(,@check-form index))))
`(data-nil-vector-ref (the ,atype vector) index)))))
(define-setter (saetp check-form)
(let* ((type (saetp-specifier saetp))
(atype `(simple-array ,type (*))))
`(named-lambda (optimized-data-vector-set ,type) (vector index new-value)
(declare (optimize speed (safety 0)))
;; Impossibly setting an elt of an (ARRAY NIL)
;; returns no value. And nobody cares.
(declare (muffle-conditions compiler-note))
(data-vector-set (the ,atype vector)
(locally
(declare (optimize (safety 1)))
(the index
(,@check-form index)))
(locally
;; SPEED 1 needed to avoid the compiler
;; from downgrading the type check to
;; a cheaper one.
(declare (optimize (speed 1)
(safety 1)))
(the* (,type :context :aref) new-value)))
;; Low-level setters return no value
new-value)))
(define-reffers (symbol deffer check-form slow-path)
`(progn
;; FIXME/KLUDGE: can't just FILL here, because genesis doesn't
;; preserve the binding, so re-initiaize as NS doesn't have
;; the energy to figure out to change that right now.
(setf ,symbol (make-array (1+ widetag-mask)
:initial-element #'hairy-ref-error))
,@(loop for widetag in '(complex-vector-widetag
complex-bit-vector-widetag
#+sb-unicode complex-character-string-widetag
complex-base-string-widetag
simple-array-widetag
complex-array-widetag)
collect `(setf (svref ,symbol ,widetag) ,slow-path))
,@(loop for saetp across *specialized-array-element-type-properties*
for widetag = (saetp-typecode saetp)
collect `(setf (svref ,symbol ,widetag)
(,deffer ,saetp ,check-form))))))
(defun !hairy-data-vector-reffer-init ()
(!blt-copiers-cold-init +blt-copier-for-widetag+)
(define-reffers %%data-vector-reffers%% define-reffer
(progn)
#'slow-hairy-data-vector-ref)
(define-reffers %%data-vector-setters%% define-setter
(progn)
#'slow-hairy-data-vector-set)
(define-reffers %%data-vector-reffers/check-bounds%% define-reffer
(check-bound vector (length vector))
#'slow-hairy-data-vector-ref/check-bounds)
(define-reffers %%data-vector-setters/check-bounds%% define-setter
(check-bound vector (length vector))
#'slow-hairy-data-vector-set/check-bounds)))
;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
;;; definition is needed for the compiler to use in constant folding.)
(defun data-vector-ref (array index)
(declare (explicit-check))
(hairy-data-vector-ref array index))
(defun data-vector-ref-with-offset (array index offset)
(declare (explicit-check))
(hairy-data-vector-ref array (+ index offset)))
(defun invalid-array-p (array)
(and (array-header-p array)
(consp (%array-displaced-p array))))
(declaim (ftype (function (array) nil) invalid-array-error))
(defun invalid-array-error (array)
(declare (optimize allow-non-returning-tail-call))
(aver (array-header-p array))
;; Array invalidation stashes the original dimensions here...
(let ((dims (%array-displaced-p array))
(et (array-element-type array)))
(error 'invalid-array-error
:datum array
:expected-type
(if (cdr dims)
`(array ,et ,dims)
`(vector ,et ,@dims)))))
(declaim (ftype (function (array t integer &optional t) nil)
invalid-array-index-error))
(defun invalid-array-index-error (array index bound &optional axis)
(declare (optimize allow-non-returning-tail-call))
(if (invalid-array-p array)
(invalid-array-error array)
(error 'invalid-array-index-error
:array array
:axis axis
:datum index
:expected-type `(integer 0 (,bound)))))
;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
(defun %array-row-major-index (array &rest subscripts)
(declare (truly-dynamic-extent subscripts)
(array array))
(let ((length (length subscripts)))
(cond ((array-header-p array)
(let ((rank (%array-rank array)))
(unless (= rank length)
(error "Wrong number of subscripts, ~W, for array of rank ~W."
length rank))
(do ((axis (1- rank) (1- axis))
(chunk-size 1)
(result 0))
((minusp axis) result)
(declare (fixnum axis chunk-size result))
(let ((index (fast-&rest-nth axis subscripts))
(dim (%array-dimension array axis)))
(unless (and (fixnump index) (< -1 index dim))
(invalid-array-index-error array index dim axis))
(setf result
(truly-the fixnum
(+ result
(truly-the fixnum (* chunk-size index))))
chunk-size (truly-the fixnum (* chunk-size dim)))))))
((/= length 1)
(error "Wrong number of subscripts, ~W, for array of rank 1."
length))
(t
(let ((index (fast-&rest-nth 0 subscripts))
(length (length (the (simple-array * (*)) array))))
(unless (and (fixnump index) (< -1 index length))
(invalid-array-index-error array index length))
index)))))
(defun array-in-bounds-p (array &rest subscripts)
"Return T if the SUBSCRIPTS are in bounds for the ARRAY, NIL otherwise."
(declare (truly-dynamic-extent subscripts))
(let ((length (length subscripts)))
(cond ((array-header-p array)
(let ((rank (%array-rank array)))
(unless (= rank length)
(error "Wrong number of subscripts, ~W, for array of rank ~W."
length rank))
(loop for i below length
for s = (fast-&rest-nth i subscripts)
always (and (typep s '(and fixnum unsigned-byte))
(< s (%array-dimension array i))))))
((/= length 1)
(error "Wrong number of subscripts, ~W, for array of rank 1."
length))
(t
(let ((subscript (fast-&rest-nth 0 subscripts)))
(and (typep subscript '(and fixnum unsigned-byte))
(< subscript
(length (truly-the (simple-array * (*)) array)))))))))
(defun array-row-major-index (array &rest subscripts)
(declare (truly-dynamic-extent subscripts))
(apply #'%array-row-major-index array subscripts))
(defun aref (array &rest subscripts)
"Return the element of the ARRAY specified by the SUBSCRIPTS."
(declare (truly-dynamic-extent subscripts))
(row-major-aref array (apply #'%array-row-major-index array subscripts)))
;;; (setf aref/bit/sbit) are implemented using setf-functions,
;;; because they have to work with (setf (apply #'aref array subscripts))
;;; All other setfs can be done using setf-functions too, but I
;;; haven't found technical advantages or disadvantages for either
;;; scheme.
(defun (setf aref) (new-value array &rest subscripts)
(declare (truly-dynamic-extent subscripts)
(type array array))
(setf (row-major-aref array (apply #'%array-row-major-index array subscripts))
new-value))
(defun row-major-aref (array index)
"Return the element of array corresponding to the row-major index. This is
SETFable."
(declare (optimize (safety 1)))
(row-major-aref array index))
(defun %set-row-major-aref (array index new-value)
(declare (optimize (safety 1)))
(setf (row-major-aref array index) new-value))
(defun svref (simple-vector index)
"Return the INDEXth element of the given Simple-Vector."
(declare (optimize (safety 1)))
(aref simple-vector index))
(defun %svset (simple-vector index new)
(declare (optimize (safety 1)))
(setf (aref simple-vector index) new))
(defun bit (bit-array &rest subscripts)
"Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS."
(declare (type (array bit) bit-array)
(truly-dynamic-extent subscripts)
(optimize (safety 1)))
(row-major-aref bit-array (apply #'%array-row-major-index bit-array subscripts)))
(defun (setf bit) (new-value bit-array &rest subscripts)
(declare (type (array bit) bit-array)
(type bit new-value)
(truly-dynamic-extent subscripts)
(optimize (safety 1)))
(setf (row-major-aref bit-array
(apply #'%array-row-major-index bit-array subscripts))
new-value))
(defun sbit (simple-bit-array &rest subscripts)
"Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS."
(declare (type (simple-array bit) simple-bit-array)
(truly-dynamic-extent subscripts)
(optimize (safety 1)))
(row-major-aref simple-bit-array
(apply #'%array-row-major-index simple-bit-array subscripts)))
(defun (setf sbit) (new-value bit-array &rest subscripts)
(declare (type (simple-array bit) bit-array)
(type bit new-value)
(truly-dynamic-extent subscripts)
(optimize (safety 1)))
(setf (row-major-aref bit-array
(apply #'%array-row-major-index bit-array subscripts))
new-value))
;;;; miscellaneous array properties
(macrolet ((widetag->type (accessor)
(let ((table
;; Using unbound-marker for empty elements would be preferable,
;; but I'd either need a cross-compiler proxy for unbound-marker,
;; or else wrap a LOAD-TIME-VALUE on the table construction form
;; which might introduce more order-sensitivity to self-build.
(sb-xc:make-array 32 ;:initial-element (make-unbound-marker)
:initial-element 0)))
(dovector (saetp *specialized-array-element-type-properties*)
(setf (aref table (ash (- (saetp-typecode saetp) 128) -2))
(funcall accessor saetp)))
`(aref ,table (- (ash (array-underlying-widetag array) -2) 32)))))
(defun array-element-ctype (array)
;; same as (SPECIFIER-TYPE (ARRAY-ELEMENT-TYPE ARRAY)) but more efficient
(widetag->type saetp-ctype))
(defun array-element-type (array)
"Return the type of the elements of the array"
(truly-the (or list symbol) (widetag->type saetp-specifier))))
(defun array-rank (array)
"Return the number of dimensions of ARRAY."
(%array-rank array))
(defun array-dimension (array axis-number)
"Return the length of dimension AXIS-NUMBER of ARRAY."
(declare (array array) (type index axis-number))
(cond ((not (array-header-p array))
(unless (= axis-number 0)
(error "Vector axis is not zero: ~S" axis-number))
(length (the (simple-array * (*)) array)))
((>= axis-number (%array-rank array))
(error "Axis number ~W is too big; ~S only has ~D dimension~:P."
axis-number array (%array-rank array)))
(t
(%array-dimension array axis-number))))
(defun array-dimensions (array)
"Return a list whose elements are the dimensions of the array"
(declare (explicit-check))
(cond ((array-header-p array)
(do ((results nil (cons (%array-dimension array index) results))
(index (1- (%array-rank array)) (1- index)))
((minusp index) results)))
((typep array 'vector)
(list (length array)))
(t
(sb-c::%type-check-error/c array 'object-not-array-error nil))))
(defun array-total-size (array)
"Return the total number of elements in the Array."
(declare (explicit-check))
(cond ((array-header-p array)
(%array-available-elements array))
((typep array 'vector)
(length array))
(t
(sb-c::%type-check-error/c array 'object-not-array-error nil))))
(defun array-displacement (array)
"Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
(declare (type array array))
(if (and (array-header-p array) ; if unsimple and
(%array-displaced-p array)) ; displaced
(values (%array-data array) (%array-displacement array))
(values nil 0)))
(defun adjustable-array-p (array)
"Return T if and only if calling ADJUST-ARRAY on ARRAY will return
the identical object."
(declare (array array))
;; Note that this appears not to be a fundamental limitation.
;; non-vector SIMPLE-ARRAYs are in fact capable of being adjusted,
;; but in practice we test using ADJUSTABLE-ARRAY-P in ADJUST-ARRAY.
;; -- CSR, 2004-03-01.
(not (typep array 'simple-array)))
;;;; fill pointer frobbing stuff
(setf (info :function :predicate-truth-constraint 'array-has-fill-pointer-p)
'(and vector (not simple-array)))
(defun array-has-fill-pointer-p (array)
"Return T if the given ARRAY has a fill pointer, or NIL otherwise."
(array-has-fill-pointer-p array))
(defun fill-pointer-error (vector)
(declare (optimize allow-non-returning-tail-call)
(optimize (sb-c::verify-arg-count 0)))
(error 'simple-type-error
:datum vector
:expected-type '(and vector (satisfies array-has-fill-pointer-p))
:format-control "~S is not an array with a fill pointer."
:format-arguments (list vector)))
(declaim (inline fill-pointer))
(defun fill-pointer (vector)
"Return the FILL-POINTER of the given VECTOR."
(declare (explicit-check))
(if (array-has-fill-pointer-p vector)
(%array-fill-pointer vector)
(fill-pointer-error vector)))
(defun %set-fill-pointer (vector new)
(declare (explicit-check))
(cond ((not (array-has-fill-pointer-p vector)) (fill-pointer-error vector))
((> (the index new) (%array-available-elements vector))
(let ((max (%array-available-elements vector)))
(error 'simple-type-error
:datum new
:expected-type (list 'integer 0 max)
:format-control "The new fill pointer, ~S, is larger than the length of the vector (~S.)"
:format-arguments (list new max))))
(t
(setf (%array-fill-pointer vector) new))))
;;; FIXME: It'd probably make sense to use a MACROLET to share the
;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro
;;; should probably be based on the VECTOR-PUSH-EXTEND code (which is
;;; new ca. sbcl-0.7.0) rather than the VECTOR-PUSH code (which dates
;;; back to CMU CL).
(defun vector-push (new-element array)
"Attempt to set the element of ARRAY designated by its fill pointer
to NEW-ELEMENT, and increment the fill pointer by one. If the fill pointer is
too large, NIL is returned, otherwise the index of the pushed element is
returned."
(declare (explicit-check))
(let ((fill-pointer (fill-pointer array)))
(cond ((= fill-pointer (%array-available-elements array))
nil)
(t
(locally (declare (optimize (safety 0)))
(setf (aref array fill-pointer) new-element))
(setf (%array-fill-pointer array) (1+ fill-pointer))
fill-pointer))))
(defun !blt-copiers-cold-init (array)
(macrolet ((init ()
`(progn
,@(loop for saetp across *specialized-array-element-type-properties*
when (and (not (member (saetp-specifier saetp) '(t nil)))
(<= (saetp-n-bits saetp) n-word-bits))
collect `(setf (svref array ,(ash (- (saetp-typecode saetp) 128) -2))
#',(intern (format nil "UB~D-BASH-COPY"
(saetp-n-bits saetp))
"SB-KERNEL"))))))
(init)))
(defmacro blt-copier-for-widetag (x) `(aref +blt-copier-for-widetag+ (ash (- ,x 128) -2)))
(defun extend-vector (vector min-extension)
(declare (optimize speed)
(vector vector))
(let* ((old-length (length vector))
(min-extension (or min-extension
(min old-length
(- array-dimension-limit old-length))))
(new-length (the index (+ old-length
(max 1 min-extension))))
(fill-pointer (1+ old-length)))
(declare (fixnum new-length min-extension))
(with-array-data ((old-data vector) (old-start)
(old-end old-length))
(let* ((widetag (%other-pointer-widetag old-data))
(n-bits-shift (aref %%simple-array-n-bits-shifts%% widetag))
(new-data
;; FIXME: mark prefix of shadow bits assigned, suffix unassigned
(allocate-vector-with-widetag #+ubsan nil
widetag new-length n-bits-shift)))
;; Copy the data
(if (= widetag simple-vector-widetag) ; the most common case
(replace (truly-the simple-vector new-data) ; transformed
(truly-the simple-vector old-data)
:start2 old-start :end2 old-end)
(let ((copier (blt-copier-for-widetag widetag)))
(if (functionp copier)
(funcall copier old-data old-start new-data 0 old-length)
(replace new-data old-data :start2 old-start :end2 old-end))))
(setf (%array-data vector) new-data
(%array-available-elements vector) new-length
(%array-fill-pointer vector) fill-pointer
(%array-displacement vector) 0
(%array-displaced-p vector) nil)
(%set-array-dimension vector 0 new-length)
vector))))
(defun vector-push-extend (new-element vector &optional min-extension)
(declare (type (or null (and index (integer 1))) min-extension))
(declare (explicit-check))
(let* ((fill-pointer (fill-pointer vector))
(new-fill-pointer (1+ fill-pointer)))
(if (= fill-pointer (%array-available-elements vector))
(extend-vector vector min-extension)
(setf (%array-fill-pointer vector) new-fill-pointer))
;; disable bounds checking
(locally (declare (optimize (safety 0)))
(setf (aref vector fill-pointer) new-element))
fill-pointer))
(defun vector-pop (array)
"Decrease the fill pointer by 1 and return the element pointed to by the
new fill pointer."
(declare (explicit-check))
(let ((fill-pointer (fill-pointer array)))
(if (zerop fill-pointer)
(error "There is nothing left to pop.")
;; disable bounds checking (and any fixnum test)
(locally (declare (optimize (safety 0)))
(aref array
(setf (%array-fill-pointer array)
(1- fill-pointer)))))))
;;;; ADJUST-ARRAY
(defun adjust-array (array dimensions &key
(element-type (array-element-type array) element-type-p)
(initial-element nil element-p)
(initial-contents nil contents-p)
fill-pointer
displaced-to (displaced-index-offset 0 offset-p))
"Adjust ARRAY's dimensions to the given DIMENSIONS and stuff."
(when (invalid-array-p array)
(invalid-array-error array))
(binding*
(((rank new-total-size) (rank-and-total-size-from-dims dimensions))
(widetag
(let ((widetag (array-underlying-widetag array)))
(unless (= (array-rank array) rank) ; "drive-by" check of the rank
(error "Expected ~D new dimension~:P for array, but received ~D."
(array-rank array) rank))
(if (or (not element-type-p)
;; Quick pass if ELEMENT-TYPE is same as the element type based on widetag
(equal element-type (widetag->element-type widetag))
(= (%vector-widetag-and-n-bits-shift element-type) widetag))
widetag
(error "The new element type, ~/sb-impl:print-type-specifier/, is incompatible ~
with old type, ~/sb-impl:print-type-specifier/."
element-type (array-element-type array)))))
(new-fill-pointer
(cond (fill-pointer
(unless (array-has-fill-pointer-p array)
(if (/= rank 1)
(error "Only vectors can have fill pointers.")
;; I believe the sentence saying that this is an error pre-dates the removal
;; of the restriction of calling ADJUST-ARRAY only on arrays that
;; are actually adjustable. Making a new array should always work,
;; so I think this may be a bug in the spec.
(fill-pointer-error array)))
(cond ((eq fill-pointer t) new-total-size)
((<= fill-pointer new-total-size) fill-pointer)
(t (make-array-bad-fill-pointer fill-pointer new-total-size " new"))))
((array-has-fill-pointer-p array)
;; "consequences are unspecified if array is adjusted to a size smaller than its fill pointer"
(let ((old-fill-pointer (%array-fill-pointer array)))
(when (< new-total-size old-fill-pointer)
(error "can't adjust vector ~S to a size (~S) smaller than ~
its current fill pointer (~S)"
array new-total-size old-fill-pointer))
old-fill-pointer))))
((initialize initial-data)
(check-make-array-initargs t element-type new-total-size))
(n-bits-shift (aref %%simple-array-n-bits-shifts%% widetag)))
(cond
(displaced-to ; super easy - just repoint ARRAY to new data
(if (adjustable-array-p array)
(set-array-header array displaced-to new-total-size new-fill-pointer
displaced-index-offset dimensions t nil)
(%make-array dimensions widetag n-bits-shift
:displaced-to displaced-to
:displaced-index-offset displaced-index-offset)))
(contents-p ; array former contents replaced by INITIAL-CONTENTS
(let ((array-data (data-vector-from-inits dimensions new-total-size widetag n-bits-shift
initialize initial-data)))
(cond ((adjustable-array-p array)
(set-array-header array array-data new-total-size new-fill-pointer
0 dimensions nil nil))
((array-header-p array)
;; simple multidimensional array.
;; fill-pointer vectors satisfy ADJUSTABLE-ARRAY-P (in SBCL, that is)
;; and therefore are handled by the first stanza of the cond.
(%make-array dimensions widetag n-bits-shift
:initial-contents initial-contents))
(t
array-data))))
((= rank 1)
(let ((old-length (array-total-size array)))
;; Because ADJUST-ARRAY has to ignore any fill-pointer when
;; copying from the old data, we can't just pass ARRAY as the
;; second argument of REPLACE.
(with-array-data ((old-data array) (old-start) (old-end old-length))
(let ((new-data
(if (and (= new-total-size old-length)
(not (and (array-header-p array) (%array-displaced-p array))))
;; if total size is unchanged, and it was not a displaced array,
;; then this array owns the data and can retain it.
old-data
(let ((data (allocate-vector-with-widetag #+ubsan t
widetag new-total-size
n-bits-shift)))
(replace data old-data
:start1 0 :end1 new-total-size
:start2 old-start :end2 old-end)
(when (and element-p (> new-total-size old-length))
(fill data initial-element :start old-length))
data))))
(if (adjustable-array-p array)
(set-array-header array new-data new-total-size new-fill-pointer
0 dimensions nil nil)
new-data)))))
(t
(let ((old-total-size (%array-available-elements array)))
(with-array-data ((old-data array) (old-start) (old-end old-total-size))
(declare (ignore old-end))
(let ((new-data (if (or (and (array-header-p array)
(%array-displaced-p array))
(> new-total-size old-total-size)
(not (adjustable-array-p array)))
(data-vector-from-inits dimensions new-total-size widetag
n-bits-shift initialize initial-data)
old-data)))
(if (or (zerop old-total-size) (zerop new-total-size))
(when element-p (fill new-data initial-element))
(zap-array-data old-data (array-dimensions array)
old-start
new-data dimensions new-total-size
element-type initial-element
element-p))
(if (adjustable-array-p array)
(set-array-header array new-data new-total-size
nil 0 dimensions nil nil)
(let ((new-array (make-array-header simple-array-widetag rank)))
(set-array-header new-array new-data new-total-size
nil 0 dimensions nil t))))))))))
;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
;;; which must be less than or equal to its current length. This can
;;; be called on vectors without a fill pointer but it is slightly
;;; dangerous to do so: shrinking the size of an object accessible
;;; to another thread could cause it to access an out-of-bounds element.
;;; GC should generally be fine no matter what happens, because it either
;;; reads the old length or the new length. If the old, and unboxed,
;;; the whole vector is skipped; if simple-vector, then at worst it reads
;;; the header word for a filler, which is a valid element (yup really!).
;;; If it reads the new length, then the next object is filler.
(defun %shrink-vector (vector new-length)
(declare (vector vector))
(unless (or (array-header-p vector) (typep vector '(simple-array nil (*))))
(let ((old-length (length vector))
(new-length new-length))
(when (simple-base-string-p vector)
;; We can blindly store the hidden #\null at NEW-LENGTH, but it would
;; appear to be an out-of-bounds access if the length is not
;; changing at all. i.e. while it's safe to always do a store,
;; the length check has to be skipped.
(locally (declare (optimize (sb-c:insert-array-bounds-checks 0)))
(setf (schar vector new-length) (code-char 0)))
;; Now treat both the old and new lengths as if they include
;; the byte that holds the implicit string terminator.
(incf old-length)
(incf new-length))
(let* ((n-bits-shift (aref %%simple-array-n-bits-shifts%%
(%other-pointer-widetag vector)))
(old-nwords (ceiling (ash old-length n-bits-shift) n-word-bits))
(new-nwords (ceiling (ash new-length n-bits-shift) n-word-bits)))
;; If we want to impose a constraint that unused bytes above the
;; new length and below the physical end are 0,
;; then now would be the time to enforce that.
(when (< new-nwords old-nwords)
(with-pinned-objects (vector)
;; VECTOR-SAP is only for unboxed vectors. Use the vop directly.
(let ((data (%primitive vector-sap vector)))
;; There is no requirement to zeroize memory corresponding
;; to unused array elements.
;; However, it's slightly nicer if the padding word (if present) is 0.
(when (oddp new-nwords)
(setf (sap-ref-word data (ash new-nwords word-shift)) 0))
(let* ((aligned-old (align-up old-nwords 2))
(aligned-new (align-up new-nwords 2)))
;; Only if physically shrunk as determined by PRIMITIVE-OBJECT-SIZE
;; will we need to (and have adequate room to) place a filler.
(when (< aligned-new aligned-old)
(let ((diff (- aligned-old aligned-new)))
;; Certainly if the vector is unboxed it can't possibly matter
;; if GC sees this bit pattern prior to setting the new length;
;; but even for SIMPLE-VECTOR, it's OK, it turns out.
(setf (sap-ref-word data (ash aligned-new word-shift))
(logior (ash (1- diff) n-widetag-bits)
filler-widetag)))))))))))
;; Only arrays have fill-pointers, but vectors have their length
;; parameter in the same place.
(setf (%array-fill-pointer vector) new-length)
vector)
(defun shrink-vector (vector new-length)
(declare (vector vector))
(cond
((eq (length vector) new-length)
vector)
((array-has-fill-pointer-p vector)
(setf (%array-fill-pointer vector) new-length)
vector)
(t (subseq vector 0 new-length))))
;;; BIG THREAD SAFETY NOTE
;;;
;;; ADJUST-ARRAY/SET-ARRAY-HEADER, and its callees are very
;;; thread unsafe. They are nonatomic, and can mess with parallel
;;; code using the same arrays.
;;;
;;; A likely seeming fix is an additional level of indirection:
;;; ARRAY-HEADER -> ARRAY-INFO -> ... where ARRAY-HEADER would
;;; hold nothing but the pointer to ARRAY-INFO, and ARRAY-INFO
;;; would hold everything ARRAY-HEADER now holds. This allows
;;; consing up a new ARRAY-INFO and replacing it atomically in
;;; the ARRAY-HEADER.
;;;
;;; %WALK-DISPLACED-ARRAY-BACKPOINTERS is an especially nasty
;;; one: not only is it needed extremely rarely, which makes
;;; any thread safety bugs involving it look like rare random
;;; corruption, but because it walks the chain *upwards*, which
;;; may violate user expectations.
;;; Fill in array header with the provided information, and return the array.
(defun set-array-header (array data length fill-pointer displacement dimensions
displacedp newp)
(labels ((%walk-displaced-array-backpointers (array new-length)
(dolist (p (%array-displaced-from array))
(let ((from (weak-pointer-value p)))
(when (and from (eq array (%array-data from)))
(let ((requires (+ (%array-available-elements from)
(%array-displacement from))))
(unless (>= new-length requires)
;; ANSI sayeth (ADJUST-ARRAY dictionary entry):
;;
;; "If A is displaced to B, the consequences are unspecified if B is
;; adjusted in such a way that it no longer has enough elements to
;; satisfy A.
;;
;; since we're hanging on a weak pointer here, we can't signal an
;; error right now: the array that we're looking at might be
;; garbage. Instead, we set all dimensions to zero so that next
;; safe access to the displaced array will trap. Additionally, we
;; save the original dimensions, so we can signal a more
;; understandable error when the time comes.
(%walk-displaced-array-backpointers from 0)
(setf (%array-fill-pointer from) 0
(%array-available-elements from) 0
(%array-displaced-p from) (array-dimensions array))
(dotimes (i (%array-rank from))
(%set-array-dimension from i 0)))))))))
(if newp
(setf (%array-displaced-from array) nil)
(%walk-displaced-array-backpointers array length))
(when displacedp
(%save-displaced-array-backpointer array data))
(setf (%array-data array) data)
(setf (%array-available-elements array) length)
(cond (fill-pointer
(setf (%array-fill-pointer array) fill-pointer)
(logior-header-bits array +array-fill-pointer-p+))
(t
(setf (%array-fill-pointer array) length)
(reset-header-bits array +array-fill-pointer-p+)))
(setf (%array-displacement array) displacement)
(populate-dimensions array dimensions (array-rank array))
(setf (%array-displaced-p array) displacedp)
array))
;;; User visible extension
(declaim (ftype (sfunction (array) (simple-array * (*))) array-storage-vector))
(defun array-storage-vector (array)
"Returns the underlying storage vector of ARRAY, which must be a non-displaced array.
In SBCL, if ARRAY is a of type \(SIMPLE-ARRAY * \(*)), it is its own storage
vector. Multidimensional arrays, arrays with fill pointers, and adjustable
arrays have an underlying storage vector with the same ARRAY-ELEMENT-TYPE as
ARRAY, which this function returns.
Important note: the underlying vector is an implementation detail. Even though
this function exposes it, changes in the implementation may cause this
function to be removed without further warning."
;; KLUDGE: Without TRULY-THE the system is not smart enough to figure out that
;; the return value is always of the known type.
(truly-the (simple-array * (*))
(cond ((not (array-header-p array))
array)
((%array-displaced-p array)
(error "~S cannot be used with displaced arrays. Use ~S instead."
'array-storage-vector 'array-displacement))
(t
(%array-data array)))))
;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
;;; This does the grinding work for ADJUST-ARRAY. It zaps the data
;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to
;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET
;;; is a displaced offset to be added to computed indices of OLD-DATA.
(defun zap-array-data (old-data old-dims offset new-data new-dims new-length
element-type initial-element initial-element-p)
(declare (list old-dims new-dims)
(fixnum new-length))
;; OLD-DIMS comes from array-dimensions, which returns a fresh list
;; at least in SBCL.
;; NEW-DIMS comes from the user.
(setf old-dims (nreverse old-dims)
new-dims (reverse new-dims))
(cond ((eq old-data new-data)
;; NEW-LENGTH, ELEMENT-TYPE, INITIAL-ELEMENT, and
;; INITIAL-ELEMENT-P are used when OLD-DATA and NEW-DATA are
;; EQ; in this case, a temporary must be used and filled
;; appropriately. specified initial-element.
;; FIXME: transforming this TYPEP to someting a bit faster
;; would be a win...
(unless (or (not initial-element-p)
(typep initial-element element-type))
(error "~S can't be used to initialize an array of type ~
~/sb-impl:print-type-specifier/."
initial-element element-type))
(let ((temp (if initial-element-p
(make-array new-length :initial-element initial-element)
(make-array new-length))))
(declare (simple-vector temp))
(zap-array-data-aux old-data old-dims offset temp new-dims)
(dotimes (i new-length)
(setf (aref new-data i) (aref temp i)))
;; Kill the temporary vector to prevent garbage retention.
(%shrink-vector temp 0)))
(t
;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
;; already been filled with any
(zap-array-data-aux old-data old-dims offset new-data new-dims))))
(defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
(declare (fixnum offset))
(let ((limits (mapcar (lambda (x y)
(declare (fixnum x y))
(1- (the fixnum (min x y))))
old-dims new-dims)))
(macrolet ((bump-index-list (index limits)
`(do ((subscripts ,index (cdr subscripts))
(limits ,limits (cdr limits)))
((null subscripts) :eof)
(cond ((< (the fixnum (car subscripts))
(the fixnum (car limits)))
(rplaca subscripts
(1+ (the fixnum (car subscripts))))
(return ,index))
(t (rplaca subscripts 0))))))
(do ((index (make-list (length old-dims) :initial-element 0)
(bump-index-list index limits)))
((eq index :eof))
(setf (aref new-data (row-major-index-from-dims index new-dims))
(aref old-data
(+ (the fixnum (row-major-index-from-dims index old-dims))
offset)))))))
;;; Figure out the row-major-order index of an array reference from a
;;; list of subscripts and a list of dimensions. This is for internal
;;; calls only, and the subscripts and dim-list variables are assumed
;;; to be reversed from what the user supplied.
(defun row-major-index-from-dims (rev-subscripts rev-dim-list)
(do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
(rev-dim-list rev-dim-list (cdr rev-dim-list))
(chunk-size 1)
(result 0))
((null rev-dim-list) result)
(declare (fixnum chunk-size result))
(setq result (+ result
(the fixnum (* (the fixnum (car rev-subscripts))
chunk-size))))
(setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
;;;; some bit stuff
(defun bit-array-same-dimensions-p (array1 array2)
(declare (type (array bit) array1 array2))
(let ((rank (array-rank array1)))
(and (= rank (array-rank array2))
(if (= rank 1)
(= (array-total-size array1)
(array-total-size array2))
(dotimes (index rank t)
(when (/= (%array-dimension array1 index)
(%array-dimension array2 index))
(return nil)))))))
(defun copy-array-header (array)
(let* ((rank (%array-rank array))
(size (%array-available-elements array))
(result (make-array-header simple-array-widetag
rank)))
(loop for i below rank
do (%set-array-dimension result i
(%array-dimension array i)))
;; fill-pointer-p defaults to 0
(setf (%array-displaced-from result) nil
(%array-displaced-p result) nil
(%array-fill-pointer result) size
(%array-available-elements result) size)
result))
(defun pick-result-array (result-bit-array bit-array-1)
(case result-bit-array
((t) bit-array-1)
((nil)
(if (vectorp bit-array-1)
(make-array (array-total-size bit-array-1)
:element-type 'bit
:initial-element 0)
(let ((header (copy-array-header bit-array-1)))
(setf (%array-data header)
(make-array (%array-available-elements bit-array-1)
:element-type 'bit
:initial-element 0))
header)))
(t
(unless (bit-array-same-dimensions-p bit-array-1
result-bit-array)
(error "~S and ~S don't have the same dimensions."
bit-array-1 result-bit-array))
result-bit-array)))
;;; This used to be a DEFMACRO, but depending on the target's support for Unicode,
;;; it got a constant-folding-error in the FORMAT call when producing the load-time
;;; macro. CONCATENATE-FORMAT-P returns true, so then we want to know whether the
;;; result is a base-string which entails calling SB-KERNEL:SIMPLE-BASE-STRING-P
;;; which has no definition in the cross-compiler. (We could add one of course)
;;; Bit array operations are allowed to leave arbitrary values in the
;;; trailing bits of the result. Examples:
;;; * (format t "~b~%" (%vector-raw-bits (bit-not #*1001) 0))
;;; 1111111111111111111111111111111111111111111111111111111111110110
;;; * (format t "~b~%" (%vector-raw-bits (bit-nor #*1001 #*1010) 0))
;;; 1111111111111111111111111111111111111111111111111111111111110010
;;; But because reading is more common than writing, it seems that a better
;;; technique might be to enforce an invariant that the last word contain 0
;;; in all unused bits so that EQUAL and SXHASH become far simpler.
(macrolet ((def-bit-array-op (name function)
`(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
,(format nil
"Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
All the arrays must have the same rank and dimensions."
(symbol-name function))
(declare (type (array bit) bit-array-1 bit-array-2)
(type (or (array bit) (member t nil)) result-bit-array))
(unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
(error "~S and ~S don't have the same dimensions."
bit-array-1 bit-array-2))
(let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
(if (and (simple-bit-vector-p bit-array-1)
(simple-bit-vector-p bit-array-2)
(simple-bit-vector-p result-bit-array))
(locally (declare (optimize (speed 3) (safety 0)))
(,name bit-array-1 bit-array-2 result-bit-array))
(with-array-data ((data1 bit-array-1) (start1) (end1))
(with-array-data ((data2 bit-array-2) (start2) (end2))
(with-array-data ((data3 result-bit-array) (start3) (end3))
(if (and (zerop start1)
(zerop start2)
(zerop start3)
(= (length data1) end1)
(= (length data2) end2)
(= (length data3) end3))
(locally (declare (optimize (speed 3) (safety 0)))
(,name data1 data2 data3))
(do ((index-1 start1 (1+ index-1))
(index-2 start2 (1+ index-2))
(index-3 start3 (1+ index-3)))
((>= index-3 end3))
(declare (type index index-1 index-2 index-3))
(setf (sbit data3 index-3)
(logand (,function (sbit data1 index-1)
(sbit data2 index-2))
1))))
result-bit-array))))))))
(def-bit-array-op bit-and logand)
(def-bit-array-op bit-ior logior)
(def-bit-array-op bit-xor logxor)
(def-bit-array-op bit-eqv logeqv)
(def-bit-array-op bit-nand lognand)
(def-bit-array-op bit-nor lognor)
(def-bit-array-op bit-andc1 logandc1)
(def-bit-array-op bit-andc2 logandc2)
(def-bit-array-op bit-orc1 logorc1)
(def-bit-array-op bit-orc2 logorc2)
) ; end MACROLET
(defun bit-not (bit-array &optional result-bit-array)
"Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
created. Both arrays must have the same rank and dimensions."
(declare (type (array bit) bit-array)
(type (or (array bit) (member t nil)) result-bit-array))
(let ((result-bit-array (pick-result-array result-bit-array bit-array)))
(if (and (simple-bit-vector-p bit-array)
(simple-bit-vector-p result-bit-array))
(locally (declare (optimize (speed 3) (safety 0)))
(bit-not bit-array result-bit-array))
(with-array-data ((src bit-array) (src-start) (src-end))
(with-array-data ((dst result-bit-array) (dst-start) (dst-end))
(if (and (zerop src-start)
(zerop dst-start)
(= src-end (length src))
(= dst-end (length dst)))
(locally (declare (optimize (speed 3) (safety 0)))
(bit-not src dst))
(do ((src-index src-start (1+ src-index))
(dst-index dst-start (1+ dst-index)))
((>= dst-index dst-end))
(declare (type index src-index dst-index))
(setf (sbit dst dst-index)
(logxor (sbit src src-index) 1))))
result-bit-array)))))
;;;; array type dispatching
;;; Given DISPATCH-FOO as the DISPATCH-NAME argument (unevaluated),
;;; defines the functions
;;;
;;; DISPATCH-FOO/SIMPLE-BASE-STRING
;;; DISPATCH-FOO/SIMPLE-CHARACTER-STRING
;;; DISPATCH-FOO/SIMPLE-ARRAY-SINGLE-FLOAT
;;; ...
;;;
;;; PARAMS are the function parameters in the definition of each
;;; specializer function. The array being specialized must be the
;;; first parameter in PARAMS. A type declaration for this parameter
;;; is automatically inserted into the body of each function.
;;;
;;; The dispatch table %%FOO-FUNS%% is defined and populated by these
;;; functions. The table is padded by the function
;;; HAIRY-FOO-DISPATCH-ERROR, also defined by DEFINE-ARRAY-DISPATCH.
;;;
;;; Finally, the DISPATCH-FOO macro is defined which does the actual
;;; dispatching when called. It expects arguments that match PARAMS.
;;;
(defmacro sb-impl::!define-array-dispatch (style dispatch-name params &body body)
#-(or x86 x86-64) (setq style :call)
(let ((table-name (symbolicate "%%" dispatch-name "-FUNS%%"))
(error-name (symbolicate "HAIRY-" dispatch-name "-ERROR")))
(declare (ignorable table-name))
`(progn
(defun ,error-name (,(first params) &rest rest)
(declare (ignore rest))
(error 'type-error
:datum ,(first params)
:expected-type '(simple-array * (*))))
,@(ecase style
(:call
`((define-load-time-global ,table-name ,(sb-xc:make-array (1+ widetag-mask)))
;; This SUBSTITUTE call happens ** after ** all the SETFs below it.
;; DEFGLOBAL's initial value is dumped by genesis as a vector filled
;; with 0 (it would not work if the vector held function objects).
;; Then the SETFs happen, as cold-load can process %SVSET, which
;; is great, because it means that hairy sequence dispatch may occur
;; as early as you'd like in cold-init without regard to file order.
;; However when it comes to actually executing the toplevel forms
;; that were compiled into thunks of target code to invoke,
;; all the known good entries must be preserved.
(nsubstitute #',error-name 0 ,table-name)
,@(loop for info across *specialized-array-element-type-properties*
for typecode = (saetp-typecode info)
for specifier = (saetp-specifier info)
for primitive-type-name = (saetp-primitive-type-name info)
collect (let ((fun-name (symbolicate (string dispatch-name)
"/" primitive-type-name)))
`(progn
(defun ,fun-name ,params
(declare (type (simple-array ,specifier (*))
,(first params)))
,@body)
(setf (svref ,table-name ,typecode) #',fun-name))))
(defmacro ,dispatch-name (&rest args)
(check-type (first args) symbol)
(let ((tag (gensym "TAG")))
`(funcall
(truly-the function
(let ((,tag 0))
(when (%other-pointer-p ,(first args))
(setf ,tag (%other-pointer-widetag ,(first args))))
(svref (truly-the (simple-vector 256) (load-time-value ,',table-name t))
,tag)))
,@args)))))
(:jump-table
(multiple-value-bind (body decls) (parse-body body nil)
`((declaim (inline ,dispatch-name))
(defun ,dispatch-name ,params
,@decls
(case (if (%other-pointer-p ,(first params))
(ash (%other-pointer-widetag ,(first params)) -2)
0)
;; All widetags have to be listed so that the jump table logic doesn't
;; give up due to deciding that it's a waste of space. It could probably
;; be based on the SPACE compilation policy. However, I would imagine that
;; it is almost always a win to use 4x or 5x table words as cases
;; given the amount of code that has to be emitted if not a table.
;; This table has only 2.5x as many words as relevant (non-error) cases.
(,(loop for i below 64
unless (find i *specialized-array-element-type-properties*
:key (lambda (x) (ash (saetp-typecode x) -2)))
collect i)
(,error-name ,@params))
,@(loop
for info across *specialized-array-element-type-properties*
collect `(,(ash (saetp-typecode info) -2)
(let ((,(first params)
(truly-the (simple-array ,(saetp-specifier info) (*))
,(first params))))
,@body))))))))))))
(defun sb-kernel::check-array-shape (array dimensions)
(when (let ((dimensions dimensions))
(dotimes (i (array-rank array))
(unless (eql (array-dimension array i) (pop dimensions))
(return t))))
(error "malformed :INITIAL-CONTENTS: ~S should have dimensions ~S"
(make-array dimensions :displaced-to (%array-data array)
:element-type (array-element-type array))
(array-dimensions array)))
array)
;;; Horrible kludge for the "static-vectors" system
;;; which uses an internal symbol in SB-IMPL.
(import '%vector-widetag-and-n-bits-shift 'sb-impl)
(defun make-weak-vector (length &key (initial-contents nil contents-p)
(initial-element nil element-p))
(declare (index length))
(when (and element-p contents-p)
(error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
;; Explicitly compute a widetag with the weakness bit ORed in.
(let ((type (logior (ash vector-weak-flag n-widetag-bits) simple-vector-widetag)))
;; These allocation calls are the transforms of MAKE-ARRAY for a vector with
;; the respective initializing keyword arg. This is badly OAOO-violating and
;; almost makes me want to cry, but not quite enough for me to improve it.
(if contents-p
(let ((contents-length (length initial-contents)))
(if (= length contents-length)
(replace (truly-the simple-vector
(allocate-vector #+ubsan nil type length length))
initial-contents)
(error "~S has ~D elements, vector length is ~D."
:initial-contents contents-length length)))
(fill (truly-the simple-vector
(allocate-vector #+ubsan nil type length length))
;; 0 is the usual default, but NIL makes more sense for weak vectors
;; as it is the value assigned to broken hearts.
(if element-p initial-element nil)))))
(defun weak-vector-p (x)
(and (simple-vector-p x)
#+(or x86 x86-64) (test-header-bit x vector-weak-flag)
#-(or x86 x86-64) (logtest (get-header-data x) vector-weak-flag)))