;;;; -*- coding: utf-8; -*-
changes in sbcl-1.0.7 relative to sbcl-1.0.6:
+ * minor incompatible change: the (unsupported) spinlock interface
+ has changed: free spinlock now has the value NIL, and a held spinlock
+ has the owning thread as its value.
* enhancement: name of a socket-stream is now "a socket" instead of
"a constant string".
* bug fix: the cache used by the CLOS to store precomputed effective
methods, slot offsets, and constant return values is now thread and
interrupt safe.
+ * bug fix: generic function dispatch function updating is now thread
+ and interrupt safe (in the sense that the known issues have been
+ fixed).
changes in sbcl-1.0.6 relative to sbcl-1.0.5:
* new contrib: sb-cover, an experimental code coverage tool, is included
(sb!vm::current-thread-offset-sap n))
;;;; spinlocks
-#!+sb-thread
(define-structure-slot-compare-and-swap
compare-and-swap-spinlock-value
:structure spinlock
(declaim (inline get-spinlock release-spinlock))
(defun get-spinlock (spinlock)
- (declare (optimize (speed 3) (safety 0))
- #!-sb-thread
- (ignore spinlock))
- ;; %instance-set-conditional can test for 0 (which is a fixnum) and
- ;; store any value
- #!+sb-thread
- (loop until
- (eql 0 (compare-and-swap-spinlock-value spinlock 0 1)))
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((new *current-thread*)
+ (old (compare-and-swap-spinlock-value spinlock nil new)))
+ (when old
+ (when (eq old new)
+ (error "Recursive lock attempt on ~S." spinlock))
+ #!+sb-thread
+ (loop while (compare-and-swap-spinlock-value spinlock nil new))))
t)
(defun release-spinlock (spinlock)
- (declare (optimize (speed 3) (safety 0))
- #!-sb-thread (ignore spinlock))
- ;; %instance-set-conditional cannot compare arbitrary objects
- ;; meaningfully, so (compare-and-swap-spinlock-value our-value 0)
- ;; does not work for bignum thread ids.
- #!+sb-thread
- (setf (spinlock-value spinlock) 0)
+ (declare (optimize (speed 3) (safety 0)))
+ (setf (spinlock-value spinlock) nil)
nil)
;;;; mutexes
#!+sb-doc
"Spinlock type."
(name nil :type (or null simple-string))
- (value 0))
+ (value nil))
(sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t))
&body body)
#!-sb-thread
`(locally ,@body))
+(sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body)
+ #!-sb-thread
+ (declare (ignore spinlock))
+ #!+sb-thread
+ (with-unique-names (lock inner-lock-p got-it)
+ `(let* ((,lock ,spinlock)
+ (,inner-lock-p (eq (spinlock-value ,lock) *current-thread*))
+ (,got-it nil))
+ (unwind-protect
+ (when (or ,inner-lock-p (setf ,got-it (get-spinlock ,lock)))
+ (locally ,@body))
+ (when ,got-it
+ (release-spinlock ,lock)))))
+ #!-sb-thread
+ `(locally ,@body))
+
(sb!xc:defmacro with-spinlock ((spinlock) &body body)
#!-sb-thread
(declare (ignore spinlock))
definition-source-mixin
metaobject
funcallable-standard-object)
- ((%documentation :initform nil :initarg :documentation)
+ ((%documentation
+ :initform nil
+ :initarg :documentation)
;; We need to make a distinction between the methods initially set
;; up by :METHOD options to DEFGENERIC and the ones set up later by
;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
;; tends to leave the generic function in a state consistent with
;; the most-recently-loaded state of a.lisp and b.lisp.)
- (initial-methods :initform ()
- :accessor generic-function-initial-methods))
+ (initial-methods
+ :initform ()
+ :accessor generic-function-initial-methods))
(:metaclass funcallable-standard-class))
(defclass standard-generic-function (generic-function)
:reader gf-arg-info)
(dfun-state
:initform ()
- :accessor gf-dfun-state))
+ :accessor gf-dfun-state)
+ ;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic.
+ (%lock
+ :initform (sb-thread::make-spinlock :name "GF lock")
+ :reader gf-lock))
(:metaclass funcallable-standard-class)
(:default-initargs :method-class *the-class-standard-method*
:method-combination *standard-method-combination*))
(return t)))))
\f
(defun update-dfun (generic-function &optional dfun cache info)
- ;; Save DFUN-STATE, so that COMPUTE-DISCRIMINATING-FUNCTION can
- ;; access it, and so that it's there for eg. future cache updates.
- ;;
- ;; How atomic wrt. SET-FUNCALLABLE-INSTANCE-FUN does this need to
- ;; be?
- (set-dfun generic-function dfun cache info)
- (let* ((early-p (early-gf-p generic-function))
- (dfun (if early-p
- (or dfun (make-initial-dfun generic-function))
- (compute-discriminating-function generic-function))))
- (set-funcallable-instance-function generic-function dfun)
- (let ((gf-name (if early-p
- (!early-gf-name generic-function)
- (generic-function-name generic-function))))
- (set-fun-name generic-function gf-name)
- dfun)))
+ (let ((early-p (early-gf-p generic-function)))
+ (flet ((update ()
+ ;; Save DFUN-STATE, so that COMPUTE-DISCRIMINATING-FUNCTION can
+ ;; access it, and so that it's there for eg. future cache updates.
+ (set-dfun generic-function dfun cache info)
+ (let ((dfun (if early-p
+ (or dfun (make-initial-dfun generic-function))
+ (compute-discriminating-function generic-function))))
+ (set-funcallable-instance-function generic-function dfun)
+ (let ((gf-name (if early-p
+ (!early-gf-name generic-function)
+ (generic-function-name generic-function))))
+ (set-fun-name generic-function gf-name)
+ dfun))))
+ ;; This needs to be atomic per generic function, consider:
+ ;; 1. T1 sets dfun-state to S1 and computes discr. fun using S1
+ ;; 2. T2 sets dfun-state to S2 and computes discr. fun using S2
+ ;; 3. T2 sets fin
+ ;; 4. T1 sets fin
+ ;; Oops: now dfun-state and fin don't match! Since just calling
+ ;; a generic can cause the dispatch function to be updated we
+ ;; need a lock here.
+ ;;
+ ;; We need to accept recursion, because PCL is nasty and twisty.
+ ;;
+ ;; KLUDGE: We need to disable interrupts as long as
+ ;; WITH-FOO-LOCK is interrupt unsafe. Once they are interrupt
+ ;; safe we can allow interrupts here. (But if someone some day
+ ;; manages to get rid of the need for a recursive lock here we
+ ;; _will_ need without-interrupts once again.)
+ ;;
+ ;; FIXME: When our mutexes are smart about the need to wake up
+ ;; sleepers we can put a mutex here instead -- but in the meantime
+ ;; we use a spinlock to avoid a syscall for every dfun update.
+ ;;
+ ;; KLUDGE: No need to lock during bootstrap.
+ (if early-p
+ (update)
+ (sb-sys:without-interrupts
+ (sb-thread::with-recursive-spinlock ((gf-lock generic-function))
+ (update)))))))
\f
(defvar *dfun-count* nil)
(defvar *dfun-list* nil)
(assert (ours-p (mutex-value l)) nil "5"))
(assert (eql (mutex-value l) nil) nil "6")))
+(labels ((ours-p (value)
+ (eq *current-thread* value)))
+ (let ((l (make-spinlock :name "rec")))
+ (assert (eql (spinlock-value l) nil) nil "1")
+ (with-recursive-spinlock (l)
+ (assert (ours-p (spinlock-value l)) nil "3")
+ (with-recursive-spinlock (l)
+ (assert (ours-p (spinlock-value l)) nil "4"))
+ (assert (ours-p (spinlock-value l)) nil "5"))
+ (assert (eql (spinlock-value l) nil) nil "6")))
+
(with-test (:name (:mutex :nesting-mutex-and-recursive-lock))
(let ((l (make-mutex :name "a mutex")))
(with-mutex (l)
(with-recursive-lock (l)))))
+(with-test (:name (:spinlock :nesting-spinlock-and-recursive-spinlock))
+ (let ((l (make-spinlock :name "a spinlock")))
+ (with-spinlock (l)
+ (with-recursive-spinlock (l)))))
+
(let ((l (make-spinlock :name "spinlock")))
- (assert (eql (spinlock-value l) 0) nil "1")
+ (assert (eql (spinlock-value l) nil) ((spinlock-value l))
+ "spinlock not free (1)")
(with-spinlock (l)
- (assert (eql (spinlock-value l) 1) nil "2"))
- (assert (eql (spinlock-value l) 0) nil "3"))
+ (assert (eql (spinlock-value l) *current-thread*) ((spinlock-value l))
+ "spinlock not taken"))
+ (assert (eql (spinlock-value l) nil) ((spinlock-value l))
+ "spinlock not free (2)"))
;; test that SLEEP actually sleeps for at least the given time, even
;; if interrupted by another thread exiting/a gc/anything
;;; 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".)
-"1.0.6.6"
+"1.0.6.7"
projects / sbcl.git / commitdiff