From 776a2f1275624352bbba37b03dabea03ec13a9e5 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 30 May 2007 13:55:59 +0000 Subject: [PATCH] 1.0.6.7: thread-safe UPDATE-DFUN * Make GET-SPINLOCK detect unwanted recursion. Despite the old comments in GET/RELEASE-SPINLOCK, we can store EQ-comperable lisp objects in SPINLOCK-VALUE -- just like we do for mutexes. (Potentially freshly consed bignums that the old comments referred to are not sanely EQ-comperable, of course.) * Implement WITH-RECURSIVE-SPINLOCK. * Adjust thread.impure.lisp accordingly. * Add a per generic function spinlock. (We could use mutexes, but since contention is presumed to be rare we don't want to pay the wakeup syscall cost for every UPDATE-DFUN call: if and when our mutexes get smart doing the wakeup only when there are threads waiting we can and should switch this -- and probably almost all uses of spinlocks -- to mutexes.) This spinlock is grabbed to ensure that the dfun state, fin function, and name are all updated atomically. --- NEWS | 6 +++++ src/code/target-thread.lisp | 26 ++++++++------------- src/code/thread.lisp | 18 +++++++++++++- src/pcl/defs.lisp | 15 ++++++++---- src/pcl/dfun.lisp | 57 ++++++++++++++++++++++++++++++++------------- tests/threads.impure.lisp | 25 +++++++++++++++++--- version.lisp-expr | 2 +- 7 files changed, 108 insertions(+), 41 deletions(-) diff --git a/NEWS b/NEWS index 6fed3ba9f..8a8c26add 100644 --- a/NEWS +++ b/NEWS @@ -1,10 +1,16 @@ ;;;; -*- 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 diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 6f6cd93d8..c2fe73c43 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -183,7 +183,6 @@ in future versions." (sb!vm::current-thread-offset-sap n)) ;;;; spinlocks -#!+sb-thread (define-structure-slot-compare-and-swap compare-and-swap-spinlock-value :structure spinlock @@ -192,24 +191,19 @@ in future versions." (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 diff --git a/src/code/thread.lisp b/src/code/thread.lisp index d327ce9b9..367b90dcf 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -23,7 +23,7 @@ #!+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) @@ -74,6 +74,22 @@ provided the default value is used for the mutex." #!-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)) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 607f6c596..59a84b1a5 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -314,7 +314,9 @@ 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 @@ -326,8 +328,9 @@ ;; 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) @@ -358,7 +361,11 @@ :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*)) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 3b02ee458..8f0ca1a91 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -1721,22 +1721,47 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (return t))))) (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))))))) (defvar *dfun-count* nil) (defvar *dfun-list* nil) diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 0b85990f0..24cd6056e 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -127,16 +127,35 @@ (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 diff --git a/version.lisp-expr b/version.lisp-expr index 227f0241b..7355f83ba 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 2.11.4.GIT