From: Nikodemus Siivola Date: Fri, 8 Jun 2007 12:15:44 +0000 (+0000) Subject: 1.0.6.36: ALLOW-WITH-INTERRUPTS and interrupt safe WITH-MUTEX &co X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=c548f73e8dd676d6ec4576eba6ab661a5061bdfe;p=sbcl.git 1.0.6.36: ALLOW-WITH-INTERRUPTS and interrupt safe WITH-MUTEX &co * Remove the *IN-INTERRUPTION* kludge, and replace it with a general-purpose mechanism. * New variable: *ALLOW-WITH-INTERRRUPTS*. WITH-INTERRUPTS is a no-op unless it is true and interrupts are inhibited. * WITHOUT-INTERRUPTS binds *ALLOW-WITH-INTERRUPTS* to NIL, and establishes ALLOW-WITH-INTERRUPTS and WITH-LOCAL-INTERRUPTS as local macros. ALLOW-WITH-INTERRUPTS binds *ALLOW-WITH-INTERRUPTS* to the value it held before entry to WITHOUT-INTERRUPTS. WITH-LOCAL-INTERRUPTS is equivalent to (allow-with-interrups (with-interrupts ...)) but somewhat more efficient. * Use the above to make WITH-MUTEX &co interrupt-safe, but still interruptible: WITH-FOO becomes (without-interrupts (unwind-protect (when (setf foo (allow-with-interrupts (get-foo))) (with-local-interrupts ...)) (when foo (release-foo foo)))) and GET-FOO wraps it's waiting section inside a WITH-INTERRUPTS. * While at it, rewrite WITH-MUTEX &co to use CALL-WITH-FOO style expansions. * Write CALL-WITH-SYSTEM-MUTEX as a more efficient alternative to: (without-interrupt (with-mutex ...)) ; and (without-gcing (with-mutex ...)) Similarly for CALL-WITH-RECURSIVE-SYSTEM-SPINLOCK, for the benefit of PCL. * No need to signal a WARNING for WITH-INTERRUPTS inside a WITHOUT-GCING, as *ALLOW-WITH-INTERRUPTS* is always false there, so interrupts will not be enabled. --- diff --git a/NEWS b/NEWS index 7180341..69f3111 100644 --- a/NEWS +++ b/NEWS @@ -10,16 +10,21 @@ 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: WITHOUT-INTERRUPTS now binds ALLOW-WITH-INTERRUPTS and + WITH-LOCAL-INTERRUPTS as local macros. Refer to documentation string + for details. * enhancement: name of a socket-stream is now "a socket" instead of "a constant string". * enhancement: SB-POSIX now supports lockf(). (Thanks to Zach Beane.) * enhancement: SB-POSIX now supports getcwd(). (Thanks to Tassilo Horn.) + * bug fix: WITH-MUTEX and WITH-RECURSIVE-LOCK are now interrupt safe + on Linux. * 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). + 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/package-data-list.lisp-expr b/package-data-list.lisp-expr index 850288c..2b8f049 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1948,8 +1948,8 @@ SB-KERNEL) have been undone, but probably more remain." ;; SB!KERNEL.) "%PRIMITIVE" "%STANDARD-CHAR-P" + "*ALLOW-WITH-INTERRUPTS*" "*FOREIGN-LOCK*" - "*IN-INTERRUPTION*" "*INTERRUPTS-ENABLED*" "*INTERRUPT-PENDING*" "*LINKAGE-INFO*" @@ -1962,6 +1962,7 @@ SB-KERNEL) have been undone, but probably more remain." "*TASK-NOTIFY*" "*TASK-SELF*" "*TTY*" "*TYPESCRIPTPORT*" "ADD-FD-HANDLER" "ALLOCATE-SYSTEM-MEMORY" + "ALLOW-WITH-INTERRUPTS" "BEEP" "BITS" "BYTES" "BREAKPOINT-ERROR" @@ -2031,8 +2032,10 @@ SB-KERNEL) have been undone, but probably more remain." "WAIT-UNTIL-FD-USABLE" "WITH-DEADLINE" "WITH-FD-HANDLER" - "WITH-INTERRUPTS" "WITH-PINNED-OBJECTS" "WITHOUT-GCING" - "WITHOUT-INTERRUPTS" "WORDS")) + "WITH-INTERRUPTS" "WITH-LOCAL-INTERRUPTS" + "WITH-PINNED-OBJECTS" "WITHOUT-GCING" + "WITHOUT-INTERRUPTS" + "WORDS")) #s(sb-cold:package-data :name "SB!UNIX" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 1ce59d2..c9b734a 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -96,6 +96,7 @@ *gc-inhibit* t *gc-pending* nil #!+sb-thread *stop-for-gc-pending* #!+sb-thread nil + *allow-with-interrupts* t *interrupts-enabled* t *interrupt-pending* nil *break-on-signals* nil @@ -289,15 +290,15 @@ UNIX-like systems, UNIX-STATUS is used as the status code." (defun reinit () (setf *default-external-format* nil) (setf sb!alien::*default-c-string-external-format* nil) - (without-interrupts - (without-gcing - (os-cold-init-or-reinit) - (thread-init-or-reinit) - (stream-reinit) - #!-win32 - (signal-cold-init-or-reinit) - (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t) - (float-cold-init-or-reinit))) + ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS. + (without-gcing + (os-cold-init-or-reinit) + (thread-init-or-reinit) + (stream-reinit) + #!-win32 + (signal-cold-init-or-reinit) + (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t) + (float-cold-init-or-reinit)) (gc-reinit) (foreign-reinit) (time-reinit) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 67e730b..16b4999 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -29,7 +29,11 @@ ;;; use address-dependent (and thus GC-dependent) hashes, and we only ;;; have a single thread of control. (defmacro without-interrupts (&rest forms) - `(progn ,@forms)) + `(macrolet ((allow-with-interrupts (&body body) + `(progn ,@body)) + (with-local-interrupts (&body body) + `(progn ,@body))) + ,@forms)) ;;; The GENESIS function works with fasl code which would, in the ;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp index 3850da8..757e4d9 100644 --- a/src/code/deadline.lisp +++ b/src/code/deadline.lisp @@ -62,8 +62,11 @@ Experimental." #!+sb-doc "Signals a timeout condition while inhibiting further timeouts due to deadlines while the condition is being handled." - (let ((*deadline* nil)) - (apply #'error datum arguments))) + ;; FIXME: Maybe we should make ERROR do WITH-INTERRUPTS instead of + ;; putting it all over the place (now that we have ALLOW-WITH-INTERRUPTS.) + (with-interrupts + (let ((*deadline* nil)) + (apply #'error datum arguments)))) (defun signal-deadline () #!+sb-doc diff --git a/src/code/early-impl.lisp b/src/code/early-impl.lisp index b5ff9ba..01ae58d 100644 --- a/src/code/early-impl.lisp +++ b/src/code/early-impl.lisp @@ -33,7 +33,7 @@ ;; pseudo-atomicity too, but they handle it without ;; messing with special variables.) #!+(or x86 x86-64) *pseudo-atomic-bits* - *in-interruption* + *allow-with-interrupts* *interrupts-enabled* *interrupt-pending* *free-interrupt-context-index* diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 7bef99d..50665f7 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -27,12 +27,11 @@ "Mutex for access to *AVAILABLE-BUFFERS*.") (defmacro with-available-buffers-lock ((&optional) &body body) - ;; WITHOUT-INTERRUPTS because streams are low-level enough to be + ;; CALL-WITH-SYSTEM-MUTEX because streams are low-level enough to be ;; async signal safe, and in particular a C-c that brings up the ;; debugger while holding the mutex would lose badly - `(without-interrupts - (sb!thread:with-mutex (*available-buffers-mutex*) - ,@body))) + `(sb!thread::call-with-system-mutex (lambda () ,@body) + *available-buffers-mutex*)) (defconstant bytes-per-buffer (* 4 1024) #!+sb-doc diff --git a/src/code/final.lisp b/src/code/final.lisp index 597d5d0..d6619ed 100644 --- a/src/code/final.lisp +++ b/src/code/final.lisp @@ -16,6 +16,11 @@ (defvar *finalizer-store-lock* (sb!thread:make-mutex :name "Finalizer store lock.")) +(defmacro with-finalizer-store-lock (&body body) + `(sb!thread::call-with-system-mutex (lambda () ,@body) + *finalizer-store-lock* + t)) + (defun finalize (object function) #!+sb-doc "Arrange for the designated FUNCTION to be called when there @@ -57,10 +62,9 @@ Examples: (finalize \"oops\" #'oops) (oops)) ; causes GC and re-entry to #'oops due to the finalizer ; -> ERROR, caught, WARNING signalled" - (sb!sys:without-gcing - (sb!thread:with-mutex (*finalizer-store-lock*) - (push (cons (make-weak-pointer object) function) - *finalizer-store*))) + (with-finalizer-store-lock + (push (cons (make-weak-pointer object) function) + *finalizer-store*)) object) (defun cancel-finalization (object) @@ -69,24 +73,22 @@ Examples: ;; Check for NIL to avoid deleting finalizers that are waiting to be ;; run. (when object - (sb!sys:without-gcing - (sb!thread:with-mutex (*finalizer-store-lock*) - (setf *finalizer-store* - (delete object *finalizer-store* - :key (lambda (pair) - (weak-pointer-value (car pair))))))) + (with-finalizer-store-lock + (setf *finalizer-store* + (delete object *finalizer-store* + :key (lambda (pair) + (weak-pointer-value (car pair)))))) object)) (defun run-pending-finalizers () (let (pending) - (sb!sys:without-gcing - (sb!thread:with-mutex (*finalizer-store-lock*) - (setf *finalizer-store* - (delete-if (lambda (pair) - (when (null (weak-pointer-value (car pair))) - (push (cdr pair) pending) - t)) - *finalizer-store*)))) + (with-finalizer-store-lock + (setf *finalizer-store* + (delete-if (lambda (pair) + (when (null (weak-pointer-value (car pair))) + (push (cdr pair) pending) + t)) + *finalizer-store*))) ;; We want to run the finalizer bodies outside the lock in case ;; finalization of X causes finalization to be added for Y. (dolist (fun pending) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index ea4fe4c..5c4f9fc 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -154,9 +154,7 @@ ;;; accesses it, that's why we need without-interrupts. (defmacro with-active-processes-lock (() &body body) #-win32 - `(without-interrupts - (sb-thread:with-mutex (*active-processes-lock*) - ,@body)) + `(sb-thread::call-with-system-mutex (lambda () ,@body) *active-processes-lock*) #+win32 `(progn ,@body)) diff --git a/src/code/signal.lisp b/src/code/signal.lisp index cc21007..fca9c58 100644 --- a/src/code/signal.lisp +++ b/src/code/signal.lisp @@ -36,59 +36,145 @@ ;;; any system calls, and by then the cost of the extra system calls ;;; are lost in the noise when compared with the cost of delivering ;;; the signal in the first place. +;;; +;;; The conditional bindings done by this code here are worth the +;;; trouble as binding is more expensive then read & test -- so +;;; (if *foo* +;;; (foo) +;;; (let ((*foo* t)) +;;; (foo))) +;;; is faster then +;;; (let ((*foo* t)) +;;; (foo)) +;;; provided that the first branch is true "often enough". (defvar *interrupts-enabled* t) (defvar *interrupt-pending* nil) - -;;; KLUDGE: This tells INTERRUPT-THREAD that it is being invoked as an -;;; interruption, so that if the thread being interrupted is the -;;; current thread it knows to enable interrupts. INVOKE-INTERRUPTION -;;; binds it to T, and WITHOUT-INTERRUPTS binds it to NIL, so that if -;;; interrupts are disable between INTERRUPT-THREAD and this we don't -;;; accidentally re-enable them. -(defvar *in-interruption* nil) +(defvar *allow-with-interrupts* t) (sb!xc:defmacro without-interrupts (&body body) #!+sb-doc - "Execute BODY with all deferrable interrupts deferred. Deferrable interrupts -include most blockable POSIX signals, and SB-THREAD:INTERRUPT-THREAD. Does not -interfere with garbage collection, and unlike in many traditional Lisps using -userspace threads, in SBCL WITHOUT-INTERRUPTS does not inhibit scheduling of -other threads." - (let ((name (gensym "WITHOUT-INTERRUPTS-BODY-"))) - `(flet ((,name () ,@body)) - (if *interrupts-enabled* - (unwind-protect - (let ((*interrupts-enabled* nil) - (*in-interruption* nil)) - (,name)) - ;; If we were interrupted in the protected section, then - ;; the interrupts are still blocked and it remains so - ;; until the pending interrupt is handled. - ;; - ;; If we were not interrupted in the protected section, - ;; but here, then even if the interrupt handler enters - ;; another WITHOUT-INTERRUPTS, the pending interrupt will - ;; be handled immediately upon exit from said - ;; WITHOUT-INTERRUPTS, so it is as if nothing has - ;; happened. - (when *interrupt-pending* - (receive-pending-interrupt))) - (,name))))) + "Executes BODY with all deferrable interrupts disabled. Deferrable +interrupts arriving during execution of the BODY take effect after BODY has +been executed. + +Deferrable interrupts include most blockable POSIX signals, and +SB-THREAD:INTERRUPT-THREAD. Does not interfere with garbage collection, and +unlike in many traditional Lisps using userspace threads, in SBCL +WITHOUT-INTERRUPTS does not inhibit scheduling of other threads. + +Binds ALLOW-WITH-INTERRUPTS and WITH-LOCAL-INTERRUPTS as a local macros. + +ALLOW-WITH-INTERRUPTS allows the WITH-INTERRUPTS to take effect during the +dynamic scope of its body, unless there is an outer WITHOUT-INTERRUPTS without +a corresponding ALLOW-WITH-INTERRUPTS. + +WITH-LOCAL-INTERRUPTS executes its body with interrupts enabled provided that +for there is an ALLOW-WITH-INTERRUPTS for every WITHOUT-INTERRUPTS surrounding +the current one. WITH-LOCAL-INTERRUPTS is equivalent to: + + (allow-with-interrupts (with-interrupts ...)) + +Care must be taken not to let either ALLOW-WITH-INTERRUPTS or +WITH-LOCAL-INTERRUPTS appear in a function that escapes from inside the +WITHOUT-INTERRUPTS in: + + (without-interrupts + ;; The body of the lambda would be executed with WITH-INTERRUPTS allowed + ;; regardless of the interrupt policy in effect when it is called. + (lambda () (allow-with-interrupts ...))) + + (without-interrupts + ;; The body of the lambda would be executed with interrupts enabled + ;; regardless of the interrupt policy in effect when it is called. + (lambda () (with-local-interrupts ...))) +" + (with-unique-names (outer-allow-with-interrupts) + `(call-without-interrupts + (lambda (,outer-allow-with-interrupts) + (declare (disable-package-locks allow-with-interrupts with-interrupts) + (ignorable ,outer-allow-with-interrupts)) + (macrolet ((allow-with-interrupts (&body allow-forms) + `(call-allowing-with-interrupts + (lambda () ,@allow-forms) + ,',outer-allow-with-interrupts)) + (with-local-interrupts (&body with-forms) + `(call-with-local-interrupts + (lambda () ,@with-forms) + ,',outer-allow-with-interrupts))) + (declare (enable-package-locks allow-with-interrupts with-interrupts)) + ,@body))))) (sb!xc:defmacro with-interrupts (&body body) #!+sb-doc - "Allow interrupts while executing BODY. As interrupts are normally allowed, -this is only useful inside a SB-SYS:WITHOUT-INTERRUPTS. Signals a runtime -warning if used inside the dynamic countour of SB-SYS:WITHOUT-GCING." - (let ((name (gensym))) - `(flet ((,name () ,@body)) - (if *interrupts-enabled* - (,name) - (progn - (when sb!kernel:*gc-inhibit* - (warn "Re-enabling interrupts while GC is inhibited.")) - (let ((*interrupts-enabled* t)) - (when *interrupt-pending* - (receive-pending-interrupt)) - (,name))))))) + "Executes BODY with deferrable interrupts conditionally enabled. If there +are pending interrupts they take effect prior to executing BODY. + +As interrupts are normally allowed WITH-INTERRUPTS only makes sense if there +is an outer WITHOUT-INTERRUPTS with a corresponding ALLOW-WITH-INTERRUPTS: +interrupts are not enabled if any outer WITHOUT-INTERRUPTS is not accompanied +by ALLOW-WITH-INTERRUPTS." + `(call-with-interrupts + (lambda () ,@body) + (and (not *interrupts-enabled*) *allow-with-interrupts*))) + +(defun call-allowing-with-interrupts (function allowp) + (declare (function function)) + (if allowp + (let ((*allow-with-interrupts* t)) + (funcall function)) + (funcall function))) + +(defun call-with-interrupts (function allowp) + (declare (function function)) + (if allowp + (let ((*interrupts-enabled* t)) + (when *interrupt-pending* + (receive-pending-interrupt)) + (funcall function)) + (funcall function))) + +;; Distinct from CALL-WITH-INTERRUPTS as it needs to bind both *A-W-I* +;; and *I-E*. +(defun call-with-local-interrupts (function allowp) + (declare (function function)) + (if allowp + (let* ((*allow-with-interrupts* t) + (*interrupts-enabled* t)) + (when *interrupt-pending* + (receive-pending-interrupt)) + (funcall function)) + (funcall function))) + +(defun call-without-interrupts (function) + (declare (function function)) + (flet ((run-without-interrupts () + (if *allow-with-interrupts* + (let ((*allow-with-interrupts* nil)) + (funcall function t)) + (funcall function nil)))) + (if *interrupts-enabled* + (unwind-protect + (let ((*interrupts-enabled* nil)) + (run-without-interrupts)) + ;; If we were interrupted in the protected section, then the + ;; interrupts are still blocked and it remains so until the + ;; pending interrupt is handled. + ;; + ;; If we were not interrupted in the protected section, but + ;; here, then even if the interrupt handler enters another + ;; WITHOUT-INTERRUPTS, the pending interrupt will be handled + ;; immediately upon exit from said WITHOUT-INTERRUPTS, so it + ;; is as if nothing has happened. + (when *interrupt-pending* + (receive-pending-interrupt))) + (run-without-interrupts)))) + +;;; A low-level operation that assumes that *INTERRUPTS-ENABLED* is false, +;;; and *ALLOW-WITH-INTERRUPTS* is true. +(defun %check-interrupts () + ;; Here we check for pending interrupts first, because reading a special + ;; is faster then binding it! + (when *interrupt-pending* + (let ((*interrupts-enabled* t)) + (receive-pending-interrupt)))) diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index ad91f85..b953cbc 100644 --- a/src/code/sysmacs.lisp +++ b/src/code/sysmacs.lisp @@ -72,7 +72,6 @@ maintained." (,without-gcing-body)) (when (or *gc-pending* #!+sb-thread *stop-for-gc-pending*) (sb!unix::receive-pending-interrupt)))))))) - ;;; EOF-OR-LOSE is a useful macro that handles EOF. (defmacro eof-or-lose (stream eof-error-p eof-value) diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index aaebc76..a59e730 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -21,9 +21,7 @@ ;; FIXME: Should we not reset the _entire_ mask, just restore it ;; to the state before we got the interrupt? (reset-signal-mask) - ;; Tell INTERRUPT-THREAD it's ok to re-enable interrupts. - (let ((*in-interruption* t)) - (funcall function)))) + (allow-with-interrupts (funcall function)))) (defmacro in-interruption ((&rest args) &body body) #!+sb-doc diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index c2fe73c..5eb299e 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -60,12 +60,7 @@ in future versions." (defvar *all-threads-lock* (make-mutex :name "all threads lock")) (defmacro with-all-threads-lock (&body body) - #!-sb-thread - `(locally ,@body) - #!+sb-thread - `(without-interrupts - (with-mutex (*all-threads-lock*) - ,@body))) + `(call-with-system-mutex (lambda () ,@body) *all-threads-lock*)) (defun list-all-threads () #!+sb-doc @@ -115,25 +110,25 @@ in future versions." (declaim (inline %lutex-init %lutex-wait %lutex-wake %lutex-lock %lutex-unlock)) - (sb!alien:define-alien-routine ("lutex_init" %lutex-init) + (define-alien-routine ("lutex_init" %lutex-init) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_wait" %lutex-wait) + (define-alien-routine ("lutex_wait" %lutex-wait) int (queue-lutex unsigned-long) (mutex-lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_wake" %lutex-wake) + (define-alien-routine ("lutex_wake" %lutex-wake) int (lutex unsigned-long) (n int)) - (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock) + (define-alien-routine ("lutex_lock" %lutex-lock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock) + (define-alien-routine ("lutex_trylock" %lutex-trylock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock) + (define-alien-routine ("lutex_unlock" %lutex-unlock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy) + (define-alien-routine ("lutex_destroy" %lutex-destroy) int (lutex unsigned-long)) ;; FIXME: Defining a whole bunch of alien-type machinery just for @@ -160,13 +155,17 @@ in future versions." #!-sb-lutex (progn - (declaim (inline futex-wait futex-wake)) + (declaim (inline futex-wait %futex-wait futex-wake)) - (sb!alien:define-alien-routine "futex_wait" + (define-alien-routine ("futex_wait" %futex-wait) int (word unsigned-long) (old-value unsigned-long) (to-sec long) (to-usec unsigned-long)) - (sb!alien:define-alien-routine "futex_wake" + (defun futex-wait (word old to-sec to-usec) + (with-interrupts + (%futex-wait word old to-sec to-usec))) + + (define-alien-routine "futex_wake" int (word unsigned-long) (n unsigned-long)))) ;;; used by debug-int.lisp to access interrupt contexts @@ -190,6 +189,7 @@ in future versions." (declaim (inline get-spinlock release-spinlock)) +;; Should always be called with interrupts disabled. (defun get-spinlock (spinlock) (declare (optimize (speed 3) (safety 0))) (let* ((new *current-thread*) @@ -198,8 +198,17 @@ in future versions." (when (eq old new) (error "Recursive lock attempt on ~S." spinlock)) #!+sb-thread - (loop while (compare-and-swap-spinlock-value spinlock nil new)))) - t) + (flet ((cas () + (unless (compare-and-swap-spinlock-value spinlock nil new) + (return-from get-spinlock t)))) + (if (and (not *interrupts-enabled*) *allow-with-interrupts*) + ;; If interrupts are enabled, but we are allowed to enabled them, + ;; check for pending interrupts every once in a while. + (loop + (loop repeat 128 do (cas)) ; 128 is arbitrary here + (sb!unix::%check-interrupts)) + (loop (cas))))) + t)) (defun release-spinlock (spinlock) (declare (optimize (speed 3) (safety 0))) @@ -228,9 +237,8 @@ in future versions." (defun get-mutex (mutex &optional (new-value *current-thread*) (waitp t)) #!+sb-doc - "Acquire MUTEX, setting it to NEW-VALUE or some suitable default -value if NIL. If WAITP is non-NIL and the mutex is in use, sleep -until it is available." + "Acquire MUTEX, setting it to NEW-VALUE or some suitable default value if +NIL. If WAITP is non-NIL and the mutex is in use, sleep until it is available." (declare (type mutex mutex) (optimize (speed 3))) (/show0 "Entering GET-MUTEX") (unless new-value @@ -254,10 +262,15 @@ until it is available." ;; on Darwin pthread_foo_timedbar functions are not supported: ;; this means that we probably need to use the Carbon multiprocessing ;; functions on Darwin. + ;; + ;; FIXME: This is definitely not interrupt safe: what happens if + ;; we get hit (1) during the lutex calls (ok, they may be safe, + ;; but has that been checked?) (2) after the lutex call, but + ;; before setting the mutex value. #!+sb-lutex (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) (if waitp - (%lutex-lock lutex) + (with-interrupts (%lutex-lock lutex)) (%lutex-trylock lutex)))) (setf (mutex-value mutex) new-value)) #!-sb-lutex @@ -328,6 +341,7 @@ time we reacquire MUTEX and return to the caller." (/show0 "CONDITION-WAITing") #!+sb-lutex (progn + ;; FIXME: This doesn't look interrupt safe! (setf (mutex-value mutex) nil) (with-lutex-address (queue-lutex-address (waitqueue-lutex queue)) (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) @@ -336,8 +350,8 @@ time we reacquire MUTEX and return to the caller." #!-sb-lutex (unwind-protect (let ((me *current-thread*)) - ;; XXX we should do something to ensure that the result of this setf - ;; is visible to all CPUs + ;; FIXME: should we do something to ensure that the result + ;; of this setf is visible to all CPUs? (setf (waitqueue-data queue) me) (release-mutex mutex) ;; Now we go to sleep using futex-wait. If anyone else @@ -445,13 +459,7 @@ this semaphore, then N of them is woken up." ;;; funny situations (like getting a sigint while holding the session ;;; lock) occur (defmacro with-session-lock ((session) &body body) - #!-sb-thread (declare (ignore session)) - #!-sb-thread - `(locally ,@body) - #!+sb-thread - `(without-interrupts - (with-mutex ((session-lock ,session)) - ,@body))) + `(call-with-system-mutex (lambda () ,@body) (session-lock ,session))) (defun new-session () (make-session :threads (list *current-thread*) @@ -723,9 +731,7 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." "The thread that was not interrupted.") (defmacro with-interruptions-lock ((thread) &body body) - `(without-interrupts - (with-mutex ((thread-interruptions-lock ,thread)) - ,@body))) + `(call-with-system-mutex (lambda () ,@body) (thread-interruptions-lock ,thread))) ;; Called from the signal handler in C. (defun run-interruption () @@ -734,8 +740,6 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." (let ((interruption (with-interruptions-lock (*current-thread*) (pop (thread-interruptions *current-thread*))))) (if interruption - ;; This is safe because it's the IN-INTERRUPTION that - ;; has disabled interrupts. (with-interrupts (funcall interruption)) (return)))))) @@ -755,29 +759,19 @@ nature: if you interrupt a thread that was holding important locks then do something that turns out to need those locks, you probably won't like the effect." #!-sb-thread (declare (ignore thread)) - (flet ((interrupt-self () - ;; *IN-INTERRUPTION* is true IFF we're being called as an - ;; interruption without an intervening WITHOUT-INTERRUPTS, - ;; in which case it is safe to enable interrupts. Otherwise - ;; interrupts are either already enabled, or there is an outer - ;; WITHOUT-INTERRUPTS we know nothing about, which makes it - ;; unsafe to enable interrupts. - (if *in-interruption* - (with-interrupts (funcall function)) - (funcall function)))) - #!-sb-thread - (interrupt-self) - #!+sb-thread - (if (eq thread *current-thread*) - (interrupt-self) - (let ((os-thread (thread-os-thread thread))) - (cond ((not os-thread) - (error 'interrupt-thread-error :thread thread)) - (t - (with-interruptions-lock (thread) - (push function (thread-interruptions thread))) - (when (minusp (signal-interrupt-thread os-thread)) - (error 'interrupt-thread-error :thread thread)))))))) + #!-sb-thread + (with-interrupts (funcall function)) + #!+sb-thread + (if (eq thread *current-thread*) + (with-interrupts (funcall function)) + (let ((os-thread (thread-os-thread thread))) + (cond ((not os-thread) + (error 'interrupt-thread-error :thread thread)) + (t + (with-interruptions-lock (thread) + (push function (thread-interruptions thread))) + (when (minusp (signal-interrupt-thread os-thread)) + (error 'interrupt-thread-error :thread thread))))))) (defun terminate-thread (thread) #!+sb-doc diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 367b90d..f0c5110 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -31,25 +31,11 @@ "Acquire MUTEX for the dynamic scope of BODY, setting it to NEW-VALUE or some suitable default value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep until it is available" - #!-sb-thread (declare (ignore mutex value wait-p)) - #!+sb-thread - (with-unique-names (got mutex1) - `(let ((,mutex1 ,mutex) - ,got) - (/show0 "WITH-MUTEX") - (unwind-protect - ;; FIXME: async unwind in SETQ form - (when (setq ,got (get-mutex ,mutex1 ,value ,wait-p)) - (locally - ,@body)) - (when ,got - (release-mutex ,mutex1))))) - ;; KLUDGE: this separate expansion for (NOT SB-THREAD) is not - ;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented. - ;; However, there would be a (possibly slight) performance hit in - ;; using them. - #!-sb-thread - `(locally ,@body)) + `(call-with-mutex + (lambda () ,@body) + ,mutex + ,value + ,wait-p)) (sb!xc:defmacro with-recursive-lock ((mutex) &body body) #!+sb-doc @@ -57,51 +43,136 @@ and the mutex is in use, sleep until it is available" further recursive lock attempts for the same mutex succeed. It is 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 - (with-unique-names (mutex1 inner-lock-p) - `(let* ((,mutex1 ,mutex) - (,inner-lock-p (eq (mutex-value ,mutex1) *current-thread*))) - (unwind-protect - (progn - (unless ,inner-lock-p - (get-mutex ,mutex1)) - (locally - ,@body)) - (unless ,inner-lock-p - (release-mutex ,mutex1))))) - #!-sb-thread - `(locally ,@body)) + `(call-with-recursive-lock + (lambda () ,@body) + ,mutex)) (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)) + `(call-with-recursive-spinlock + (lambda () ,@body) + ,spinlock)) (sb!xc:defmacro with-spinlock ((spinlock) &body body) - #!-sb-thread - (declare (ignore spinlock)) - #!-sb-thread - `(locally ,@body) - #!+sb-thread - (with-unique-names (lock got-it) - `(let ((,lock ,spinlock) - (,got-it nil)) - (unwind-protect - (progn - (setf ,got-it (get-spinlock ,lock)) - (locally ,@body)) - (when ,got-it - (release-spinlock ,lock)))))) + `(call-with-spinlock + (lambda () ,@body) + ,spinlock)) + +;;; KLUDGE: this separate implementation for (NOT SB-THREAD) is not +;;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented. +;;; However, there would be a (possibly slight) performance hit in +;;; using them. +#!-sb-thread +(progn + (defun call-with-system-mutex (function mutex &optional without-gcing-p) + (declare (ignore mutex) + (function function)) + (if without-gcing-p + (without-gcing + (funcall function)) + (without-interrupts + (funcall function)))) + + (defun call-with-system-spinlock (function lock &optional without-gcing-p) + (declare (ignore lock) + (function function)) + (if without-gcing-p + (without-gcing + (funcall function)) + (without-interrupts + (funcall function)))) + + (defun call-with-mutex (function mutex value waitp) + (declare (ignore mutex value waitp) + (function function)) + (funcall function)) + + (defun call-with-recursive-lock (function mutex) + (declare (ignore mutex) (function function)) + (funcall function)) + + (defun call-with-spinlock (function spinlock) + (declare (ignore spinlock) (function function)) + (funcall function)) + + (defun call-with-recursive-spinlock (function spinlock) + (declare (ignore spinlock) (function function)) + (funcall function))) + +#!+sb-thread +(progn + (defun call-with-system-mutex (function mutex &optional without-gcing-p) + (declare (function function)) + (flet ((%call-with-system-mutex () + (let (got-it) + (unwind-protect + (when (setf got-it (get-mutex mutex)) + (funcall function)) + (when got-it + (release-mutex mutex)))))) + (if without-gcing-p + (without-gcing + (%call-with-system-mutex)) + (without-interrupts + (%call-with-system-mutex))))) + + (defun call-with-recursive-system-spinlock (function lock &optional without-gcing-p) + (declare (function function)) + (flet ((%call-with-system-spinlock () + (let ((inner-lock-p (eq *current-thread* (spinlock-value lock))) + (got-it nil)) + (unwind-protect + (when (or inner-lock-p (setf got-it (get-spinlock lock))) + (funcall function)) + (when got-it + (release-spinlock lock)))))) + (if without-gcing-p + (without-gcing + (%call-with-system-spinlock)) + (without-interrupts + (%call-with-system-spinlock))))) + + (defun call-with-mutex (function mutex value waitp) + (declare (function function)) + (let ((got-it nil)) + (without-interrupts + (unwind-protect + (when (setq got-it (allow-with-interrupts + (get-mutex mutex value waitp))) + (with-local-interrupts (funcall function))) + (when got-it + (release-mutex mutex)))))) + + (defun call-with-recursive-lock (function mutex) + (declare (function function)) + (let ((inner-lock-p (eq (mutex-value mutex) *current-thread*)) + (got-it nil)) + (without-interrupts + (unwind-protect + (when (or inner-lock-p (setf got-it (allow-with-interrupts + (get-mutex mutex)))) + (with-local-interrupts (funcall function))) + (when got-it + (release-mutex mutex)))))) + + (defun call-with-spinlock (function spinlock) + (declare (function function)) + (let ((got-it nil)) + (without-interrupts + (unwind-protect + (when (setf got-it (allow-with-interrupts + (get-spinlock spinlock))) + (with-local-interrupts (funcall function))) + (when got-it + (release-spinlock spinlock)))))) + + (defun call-with-recursive-spinlock (function spinlock) + (declare (function function)) + (let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*)) + (got-it nil)) + (without-interrupts + (unwind-protect + (when (or inner-lock-p (setf got-it (allow-with-interrupts + (get-spinlock spinlock)))) + (with-local-interrupts (funcall function))) + (when got-it + (release-spinlock spinlock))))))) diff --git a/src/code/timer.lisp b/src/code/timer.lisp index 5352385..7862876 100644 --- a/src/code/timer.lisp +++ b/src/code/timer.lisp @@ -203,9 +203,7 @@ from now. For timers with a repeat interval it returns true." (defmacro with-scheduler-lock ((&optional) &body body) ;; don't let the SIGALRM handler mess things up - `(sb!sys:without-interrupts - (sb!thread:with-mutex (*scheduler-lock*) - ,@body))) + `(sb!thread::call-with-system-mutex (lambda () ,@body) *scheduler-lock*)) (defun under-scheduler-lock-p () #!-sb-thread diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 416949b..eddb5f8 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -26,6 +26,7 @@ ;;; FIXME: These could be converted to DEFVARs. (declaim (special #!+(or x86 x86-64) *pseudo-atomic-bits* + *allow-with-interrupts* *interrupts-enabled* *interrupt-pending* *type-system-initialized*)) diff --git a/src/compiler/generic/parms.lisp b/src/compiler/generic/parms.lisp index f1d56dc..c39ffe5 100644 --- a/src/compiler/generic/parms.lisp +++ b/src/compiler/generic/parms.lisp @@ -52,6 +52,7 @@ ;; interrupt handling *alloc-signal* *free-interrupt-context-index* + sb!unix::*allow-with-interrupts* sb!unix::*interrupts-enabled* sb!unix::*interrupt-pending* *gc-inhibit* diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 5ce3ac1..c559b61 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -343,7 +343,10 @@ (setf length (* 2 length))) (tagbody :again - (setf (cache-vector copy) (make-array length :initial-element '..empty..) + ;; Blow way the old vector first, so a GC potentially triggered by + ;; MAKE-ARRAY can collect it. + (setf (cache-vector copy) #() + (cache-vector copy) (make-array length :initial-element '..empty..) (cache-depth copy) 0 (cache-mask copy) (compute-cache-mask length (cache-line-size cache)) (cache-limit copy) (compute-limit (/ length (cache-line-size cache)))) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 6fc21e6..3be7f77 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -260,8 +260,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; This is the most general case. In this case, the accessor ;;; generic function has seen more than one class of argument and ;;; more than one slot index. A cache vector stores the wrappers -;;; and corresponding slot indexes. Because each cache line is -;;; more than one element long, a cache lock count is used. +;;; and corresponding slot indexes. + (defstruct (dfun-info (:constructor nil) (:copier nil)) (cache nil)) @@ -1664,7 +1664,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 all-applicable-p (all-sorted-p t) function-p) - (if (null methods) + (if (null methods) (if function-p (lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) @@ -1772,9 +1772,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; where we can end up in a metacircular loop here? In ;; case there are, better fetch it while interrupts are ;; still enabled... - (sb-sys:without-interrupts - (sb-thread::with-recursive-spinlock (lock) - (update)))))))) + (sb-thread::call-with-recursive-system-spinlock #'update lock)))))) (defvar *dfun-count* nil) (defvar *dfun-list* nil) @@ -1784,7 +1782,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; I'm aware of, but they look like they might be useful for ;;; debugging or performance tweaking or something, so I've just ;;; commented them out instead of deleting them. -- WHN 2001-03-28 -#| (defun list-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) (a (assq sym *dfun-list*))) @@ -1847,7 +1844,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (format t "~% ~S~%" (caddr type+count+sizes))) *dfun-count*) (values)) -|# +||# (defun gfs-of-type (type) (unless (consp type) (setq type (list type))) diff --git a/src/runtime/thread.c b/src/runtime/thread.c index 9871f9f..0bc37a2 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -462,6 +462,7 @@ create_thread_struct(lispobj initial_function) { bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,make_fixnum(0),th); bind_variable(INTERRUPT_PENDING, NIL,th); bind_variable(INTERRUPTS_ENABLED,T,th); + bind_variable(ALLOW_WITH_INTERRUPTS,T,th); bind_variable(GC_PENDING,NIL,th); #ifdef LISP_FEATURE_SB_THREAD bind_variable(STOP_FOR_GC_PENDING,NIL,th); diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 24cd605..eb4fe5a 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -16,6 +16,8 @@ (use-package :test-util) (use-package "ASSERTOID") +(setf sb-unix::*on-dangerous-select* :error) + (defun wait-for-threads (threads) (mapc (lambda (thread) (sb-thread:join-thread thread :default nil)) threads) (assert (not (some #'sb-thread:thread-alive-p threads)))) @@ -489,6 +491,7 @@ (format t "~&thread startup sigmask test done~%") +;; FIXME: What is this supposed to test? (sb-debug::enable-debugger) (let* ((main-thread *current-thread*) (interruptor-thread @@ -496,7 +499,8 @@ (sleep 2) (interrupt-thread main-thread #'break) (sleep 2) - (interrupt-thread main-thread #'continue))))) + (interrupt-thread main-thread #'continue)) + :name "interruptor"))) (with-session-lock (*session*) (sleep 3)) (loop while (thread-alive-p interruptor-thread))) diff --git a/version.lisp-expr b/version.lisp-expr index 1c260b8..fc46069 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.35" +"1.0.6.36"