(fixnum index))
(%check-bound array bound 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 :fail-inline? t))
+ (%with-array-data-macro array start end :check-bounds t :check-fill-pointer nil))
(defun %data-vector-and-index (array index)
(if (array-header-p array)
(%with-array-data array index nil)
(values vector index))
(values array index)))
-
-;;; It'd waste space to expand copies of error handling in every
-;;; inline %WITH-ARRAY-DATA, so we have them call this function
-;;; instead. This is just a wrapper which is known never to return.
-(defun failed-%with-array-data (array start end)
- (declare (notinline %with-array-data))
- (%with-array-data array start end)
- (bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?"))
\f
;;;; MAKE-ARRAY
(eval-when (:compile-toplevel :execute)
;;; 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.
-(macrolet ((%define (table-name extra-params)
- `(funcall
- (the function
- (let ((tag 0)
- (offset
- #.(ecase sb!c:*backend-byte-order*
- (:little-endian
- (- sb!vm:other-pointer-lowtag))
- (:big-endian
- ;; I'm not completely sure of what this
- ;; 3 represents symbolically. It's
- ;; just what all the LOAD-TYPE vops
- ;; are doing.
- (- 3 sb!vm:other-pointer-lowtag)))))
- ;; WIDETAG-OF needs extra code to handle
- ;; LIST and FUNCTION lowtags. We're only
- ;; dispatching on other pointers, so let's
- ;; do the lowtag extraction manually.
- (when (sb!vm::%other-pointer-p array)
- (setf tag
- (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address array))
- offset)))
- ;; SYMBOL-GLOBAL-VALUE is a performance hack
- ;; for threaded builds.
- (svref (sb!vm::symbol-global-value ',table-name) tag)))
- array index ,@extra-params))
- (define (accessor-name slow-accessor-name table-name extra-params
- check-bounds)
- `(progn
- (defvar ,table-name)
- (defun ,accessor-name (array index ,@extra-params)
- (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)))
- (%define ,table-name ,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-vector array)))
- (%define ,table-name ,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)))))))
+(macrolet ((def (name table-name)
+ `(progn
+ (defvar ,table-name)
+ (defmacro ,name (array-var)
+ `(the function
+ (let ((tag 0)
+ (offset
+ #.(ecase sb!c:*backend-byte-order*
+ (:little-endian
+ (- sb!vm:other-pointer-lowtag))
+ (:big-endian
+ (- (1- sb!vm:n-word-bytes) sb!vm:other-pointer-lowtag)))))
+ ;; WIDETAG-OF needs extra code to handle LIST and
+ ;; FUNCTION lowtags. We're only dispatching on
+ ;; other pointers, so let's do the lowtag
+ ;; extraction manually.
+ (when (sb!vm::%other-pointer-p ,array-var)
+ (setf tag
+ (sb!sys:sap-ref-8 (int-sap (get-lisp-obj-address ,array-var))
+ offset)))
+ ;; SYMBOL-GLOBAL-VALUE is a performance hack
+ ;; for threaded builds.
+ (svref (sb!vm::symbol-global-value ',',table-name) tag)))))))
+ (def !find-data-vector-setter *data-vector-setters*)
+ (def !find-data-vector-setter/check-bounds *data-vector-setters/check-bounds*)
+ (def !find-data-vector-reffer *data-vector-reffers*)
+ (def !find-data-vector-reffer/check-bounds *data-vector-reffers/check-bounds*))
+
+(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 (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-vector 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
- *data-vector-reffers* nil (progn))
+ !find-data-vector-reffer
+ nil (progn))
(define hairy-data-vector-set slow-hairy-data-vector-set
- *data-vector-setters* (new-value) (progn))
+ !find-data-vector-setter
+ (new-value) (progn))
(define hairy-data-vector-ref/check-bounds
slow-hairy-data-vector-ref/check-bounds
- *data-vector-reffers/check-bounds* nil
- (%check-bound array (array-dimension array 0)))
+ !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
- *data-vector-setters/check-bounds* (new-value)
- (%check-bound array (array-dimension array 0))))
+ !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))
,@(loop for widetag in '(sb!vm:complex-vector-widetag
sb!vm:complex-vector-nil-widetag
sb!vm:complex-bit-vector-widetag
- sb!vm:complex-character-string-widetag
+ #!+sb-unicode sb!vm:complex-character-string-widetag
sb!vm:complex-base-string-widetag
sb!vm:simple-array-widetag
sb!vm:complex-array-widetag)
(defun data-vector-ref (array index)
(hairy-data-vector-ref array index))
+(defun data-vector-ref-with-offset (array index offset)
+ (hairy-data-vector-ref array (+ index offset)))
+
;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
(defun %array-row-major-index (array subscripts
&optional (invalid-index-error-p t))
(defun vector-push-extend (new-element
vector
&optional
- (extension (1+ (length vector))))
- (declare (vector vector) (fixnum extension))
+ (min-extension
+ (let ((length (length vector)))
+ (min (1+ length)
+ (- array-dimension-limit length)))))
+ (declare (vector vector) (fixnum min-extension))
(let ((fill-pointer (fill-pointer vector)))
(declare (fixnum fill-pointer))
(when (= fill-pointer (%array-available-elements vector))
- (adjust-array vector (+ fill-pointer extension)))
+ (adjust-array vector (+ fill-pointer (max 1 min-extension))))
;; disable bounds checking
(locally (declare (optimize (safety 0)))
(setf (aref vector fill-pointer) new-element))
(setf (%array-displaced-p array) displacedp)
array)
\f
+;;;; used by SORT
+
+;;; temporary vector for stable sorting vectors, allocated for each new thread
+(defvar *merge-sort-temp-vector* (vector))
+(declaim (simple-vector *merge-sort-temp-vector*))
+
;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ.
(unless (typep initial-element element-type)
(error "~S can't be used to initialize an array of type ~S."
initial-element element-type)))
- (without-interrupts
- ;; Need to disable interrupts while using the temp-vector.
- ;; An interrupt handler that also happened to call
- ;; ADJUST-ARRAY could otherwise stomp on our data here.
- (let ((temp (zap-array-data-temp new-length
- initial-element initial-element-p)))
- (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)
- ;; zero out any garbage right away
- (aref temp i) 0)))))
+ (let ((temp (zap-array-data-temp new-length
+ initial-element initial-element-p)))
+ (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)
+ ;; zero out any garbage right away
+ (aref temp i) 0))))
(t
;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has
;; already been filled with any