*cold-init-complete-p* nil
*type-system-initialized* nil)
+ (show-and-call thread-init-or-reinit)
(show-and-call !typecheckfuns-cold-init)
;; Anyone might call RANDOM to initialize a hash value or something;
(show-and-call os-cold-init-or-reinit)
- (show-and-call thread-init-or-reinit)
(show-and-call stream-cold-init-or-reset)
(show-and-call !loader-cold-init)
(show-and-call !foreign-cold-init)
(declare (ignore mutex))
`(locally ,@body))
+(defun make-spinlock (&key name value)
+ (declare (ignore name value))
+ nil)
+
+(defun get-spinlock (spinlock)
+ (declare (ignore spinlock))
+ nil)
+(defun release-spinlock (spinlock)
+ (declare (ignore spinlock))
+ nil)
+(defmacro with-spinlock ((spinlock) &body body)
+ (declare (ignore spinlock))
+ `(locally ,@body))
(sb!alien:unsigned 32))
val))
+(declaim (inline maybe-handle-pending-gc))
+(defun maybe-handle-pending-gc ()
+ (when (and (not *gc-inhibit*)
+ (or #!+sb-thread *stop-for-gc-pending*
+ *gc-pending*))
+ (sb!unix::receive-pending-interrupt)))
+
;;; These work both regardless of whether we're inside WITHOUT-GCING
;;; or not.
(defun gc-on ()
#!+sb-doc
"Enable the garbage collector."
(setq *gc-inhibit* nil)
- (when (and (not *gc-inhibit*)
- (or #!+sb-thread *stop-for-gc-pending*
- *gc-pending*))
- (sb!unix::receive-pending-interrupt))
+ (maybe-handle-pending-gc)
nil)
(defun gc-off ()
;; +MAGIC-HASH-VECTOR-VALUE+ represents EQ-based hashing on the
;; respective key.
(hash-vector nil :type (or null (simple-array (unsigned-byte
- #.sb!vm:n-word-bits) (*)))))
+ #.sb!vm:n-word-bits) (*))))
+ ;; This lock is acquired by %PUTHASH, REMHASH, CLRHASH and GETHASH.
+ (spinlock (sb!thread::make-spinlock)))
;; as explained by pmai on openprojects #lisp IRC 2002-07-30: #x80000000
;; is bigger than any possible nonEQ hash value, and thus indicates an
pending gc. Similarly, if gc is triggered in another thread then it
waits until gc is enabled in this thread."
`(unwind-protect
- (let ((*gc-inhibit* t))
- ,@body)
- ;; the test is racy, but it can err only on the overeager side
- (when (and (not *gc-inhibit*)
- (or #!+sb-thread *stop-for-gc-pending*
- *gc-pending*))
- (sb!unix::receive-pending-interrupt))))
+ (let ((*gc-inhibit* t))
+ ,@body)
+ ;; the test is racy, but it can err only on the overeager side
+ (sb!kernel::maybe-handle-pending-gc)))
\f
;;; EOF-OR-LOSE is a useful macro that handles EOF.
\f
;;;; utilities
+;; This stuff is performance critical and unwind-protect is too
+;; slow. And without the locking the next vector can get cyclic
+;; causing looping in a WITHOUT-GCING form, SHRINK-VECTOR can corrupt
+;; memory and who knows what else.
+(defmacro with-spinlock-and-without-gcing ((spinlock) &body body)
+ #!-sb-thread
+ (declare (ignore spinlock))
+ `(unwind-protect
+ (let ((*gc-inhibit* t))
+ #!+sb-thread
+ (sb!thread::get-spinlock ,spinlock)
+ ,@body)
+ #!+sb-thread
+ (sb!thread::release-spinlock ,spinlock)
+ ;; the test is racy, but it can err only on the overeager side
+ (sb!kernel::maybe-handle-pending-gc)))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant max-hash sb!xc:most-positive-fixnum))
:hash-vector (unless (eq test 'eq)
(make-array size+1
:element-type '(unsigned-byte #.sb!vm:n-word-bits)
- :initial-element +magic-hash-vector-value+)))))
+ :initial-element +magic-hash-vector-value+))
+ :spinlock (sb!thread::make-spinlock))))
(declare (type index size+1 scaled-size length))
;; Set up the free list, all free. These lists are 0 terminated.
(do ((i 1 (1+ i)))
"Three argument version of GETHASH"
(declare (type hash-table hash-table)
(values t (member t nil)))
- (without-gcing
+ (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
(cond ((= (get-header-data (hash-table-table hash-table))
sb!vm:vector-must-rehash-subtype)
(rehash-without-growing hash-table))
(defun %puthash (key hash-table value)
(declare (type hash-table hash-table))
(aver (hash-table-index-vector hash-table))
- (without-gcing
+ (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
;; We need to rehash here so that a current key can be found if it
;; exists. Check that there is room for one more entry. May not be
;; needed if the key is already present.
(when hash-vector
(if (not eq-based)
(setf (aref hash-vector free-kv-slot) hashing)
- (aver (= (aref hash-vector free-kv-slot) +magic-hash-vector-value+))))
+ (aver (= (aref hash-vector free-kv-slot)
+ +magic-hash-vector-value+))))
;; Push this slot into the next chain.
(setf (aref next-vector free-kv-slot) next)
was such an entry, or NIL if not."
(declare (type hash-table hash-table)
(values (member t nil)))
- (without-gcing
+ (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
;; We need to rehash here so that a current key can be found if it
;; exists.
(cond ((= (get-header-data (hash-table-table hash-table))
(hash-table-next-free-kv hash-table))
(setf (hash-table-next-free-kv hash-table) slot-location)
(when hash-vector
- (setf (aref hash-vector slot-location) +magic-hash-vector-value+))
+ (setf (aref hash-vector slot-location)
+ +magic-hash-vector-value+))
(decf (hash-table-number-entries hash-table))
t))
(cond ((zerop next)
"This removes all the entries from HASH-TABLE and returns the hash table
itself."
(declare (optimize speed))
- (let* ((kv-vector (hash-table-table hash-table))
- (next-vector (hash-table-next-vector hash-table))
- (hash-vector (hash-table-hash-vector hash-table))
- (size (length next-vector))
- (index-vector (hash-table-index-vector hash-table)))
- ;; Disable GC tricks.
- (set-header-data kv-vector sb!vm:vector-normal-subtype)
- ;; Mark all slots as empty by setting all keys and values to magic
- ;; tag.
- (aver (eq (aref kv-vector 0) hash-table))
- (fill kv-vector +empty-ht-slot+ :start 2)
- ;; Set up the free list, all free.
- (do ((i 1 (1+ i)))
- ((>= i (1- size)))
- (setf (aref next-vector i) (1+ i)))
- (setf (aref next-vector (1- size)) 0)
- (setf (hash-table-next-free-kv hash-table) 1)
- (setf (hash-table-needing-rehash hash-table) 0)
- ;; Clear the index-vector.
- (fill index-vector 0)
- ;; Clear the hash-vector.
- (when hash-vector
- (fill hash-vector +magic-hash-vector-value+)))
- (setf (hash-table-cache hash-table) nil)
- (setf (hash-table-number-entries hash-table) 0)
+ (with-spinlock-and-without-gcing ((hash-table-spinlock hash-table))
+ (let* ((kv-vector (hash-table-table hash-table))
+ (next-vector (hash-table-next-vector hash-table))
+ (hash-vector (hash-table-hash-vector hash-table))
+ (size (length next-vector))
+ (index-vector (hash-table-index-vector hash-table)))
+ ;; Disable GC tricks.
+ (set-header-data kv-vector sb!vm:vector-normal-subtype)
+ ;; Mark all slots as empty by setting all keys and values to magic
+ ;; tag.
+ (aver (eq (aref kv-vector 0) hash-table))
+ (fill kv-vector +empty-ht-slot+ :start 2)
+ ;; Set up the free list, all free.
+ (do ((i 1 (1+ i)))
+ ((>= i (1- size)))
+ (setf (aref next-vector i) (1+ i)))
+ (setf (aref next-vector (1- size)) 0)
+ (setf (hash-table-next-free-kv hash-table) 1)
+ (setf (hash-table-needing-rehash hash-table) 0)
+ ;; Clear the index-vector.
+ (fill index-vector 0)
+ ;; Clear the hash-vector.
+ (when hash-vector
+ (fill hash-vector +magic-hash-vector-value+)))
+ (setf (hash-table-cache hash-table) nil)
+ (setf (hash-table-number-entries hash-table) 0))
hash-table)
\f
;;;; MAPHASH
;;;; spinlocks
-(defstruct spinlock
- #!+sb-doc
- "Spinlock type."
- (name nil :type (or null simple-string))
- (value 0))
-
(declaim (inline get-spinlock release-spinlock))
;;; The bare 2 here and below are offsets of the slots in the struct.
;;; There ought to be some better way to get these numbers
-(defun get-spinlock (spinlock new-value)
+(defun get-spinlock (spinlock)
(declare (optimize (speed 3) (safety 0))
#!-sb-thread
(ignore spinlock new-value))
;; store any value
#!+sb-thread
(loop until
- (eql (sb!vm::%instance-set-conditional spinlock 2 0 new-value) 0)))
+ (eql (sb!vm::%instance-set-conditional spinlock 2 0 1) 0)))
(defun release-spinlock (spinlock)
(declare (optimize (speed 3) (safety 0))
(defmacro with-spinlock ((spinlock) &body body)
(sb!int:with-unique-names (lock)
`(let ((,lock ,spinlock))
- (get-spinlock ,lock *current-thread*)
+ (get-spinlock ,lock)
(unwind-protect
(progn ,@body)
(release-spinlock ,lock)))))
;;;; mutexes
-(defstruct mutex
- #!+sb-doc
- "Mutex type."
- (name nil :type (or null simple-string))
- (value nil))
-
#!+sb-doc
(setf (sb!kernel:fdocumentation 'make-mutex 'function)
"Create a mutex."
(in-package "SB!THREAD")
+(def!struct mutex
+ #!+sb-doc
+ "Mutex type."
+ (name nil :type (or null simple-string))
+ (value nil))
+
+(def!struct spinlock
+ #!+sb-doc
+ "Spinlock type."
+ (name nil :type (or null simple-string))
+ (value 0))
+
(sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t))
&body body)
#!+sb-doc
allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
provided the default value is used for the mutex."
#!-sb-thread
- (declare (ignore mutex)) #!+sb-thread
+ (declare (ignore mutex))
+ #!+sb-thread
(with-unique-names (mutex1 inner-lock-p)
`(let* ((,mutex1 ,mutex)
(,inner-lock-p (eq (mutex-value ,mutex1) *current-thread*)))
(with-mutex (l)
(with-recursive-lock (l)))))
-(let ((l (make-spinlock :name "spinlock"))
- (p *current-thread*))
+(let ((l (make-spinlock :name "spinlock")))
(assert (eql (spinlock-value l) 0) nil "1")
(with-spinlock (l)
- (assert (eql (spinlock-value l) p) nil "2"))
+ (assert (eql (spinlock-value l) 1) nil "2"))
(assert (eql (spinlock-value l) 0) nil "3"))
;; test that SLEEP actually sleeps for at least the given time, even
(format t "~&binding test done~%")
+;; Try to corrupt the NEXT-VECTOR. Operations on a hash table with a
+;; cyclic NEXT-VECTOR can loop endlessly in a WITHOUT-GCING form
+;; causing the next gc hang SBCL.
+(with-test (:name (:hash-table-thread-safety))
+ (let* ((hash (make-hash-table))
+ (threads (list (sb-thread:make-thread
+ (lambda ()
+ (loop
+ ;;(princ "1") (force-output)
+ (setf (gethash (random 100) hash) 'h))))
+ (sb-thread:make-thread
+ (lambda ()
+ (loop
+ ;;(princ "2") (force-output)
+ (remhash (random 100) hash))))
+ (sb-thread:make-thread
+ (lambda ()
+ (loop
+ (sleep (random 1.0))
+ (sb-ext:gc :full t)))))))
+ (unwind-protect
+ (sleep 5)
+ (mapc #'sb-thread:terminate-thread threads))))
+(format t "~&hash table test done~%")
#| ;; a cll post from eric marsden
| (defun crash ()
| (setq *debugger-hook*
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.6.49"
+"0.9.6.50"
projects / sbcl.git / commitdiff