* 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
;; SB!KERNEL.)
"%PRIMITIVE"
"%STANDARD-CHAR-P"
+ "*ALLOW-WITH-INTERRUPTS*"
"*FOREIGN-LOCK*"
- "*IN-INTERRUPTION*"
"*INTERRUPTS-ENABLED*"
"*INTERRUPT-PENDING*"
"*LINKAGE-INFO*"
"*TASK-NOTIFY*" "*TASK-SELF*" "*TTY*" "*TYPESCRIPTPORT*"
"ADD-FD-HANDLER"
"ALLOCATE-SYSTEM-MEMORY"
+ "ALLOW-WITH-INTERRUPTS"
"BEEP" "BITS"
"BYTES"
"BREAKPOINT-ERROR"
"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"
*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
(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)
;;; 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
#!+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
;; 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*
"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
(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
(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)
;; 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)
;;; 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))
;;; 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))))
(,without-gcing-body))
(when (or *gc-pending* #!+sb-thread *stop-for-gc-pending*)
(sb!unix::receive-pending-interrupt))))))))
-
\f
;;; EOF-OR-LOSE is a useful macro that handles EOF.
(defmacro eof-or-lose (stream eof-error-p eof-value)
;; 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
(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
(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
#!-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
(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*)
(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)))
(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
;; 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
(/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))
#!-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
;;; 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*)
"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 ()
(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))))))
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
"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
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)))))))
(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
;;; 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*))
;; interrupt handling
*alloc-signal*
*free-interrupt-context-index*
+ sb!unix::*allow-with-interrupts*
sb!unix::*interrupts-enabled*
sb!unix::*interrupt-pending*
*gc-inhibit*
(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))))
;;; 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))
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))
;; 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))))))
\f
(defvar *dfun-count* nil)
(defvar *dfun-list* nil)
;;; 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*)))
(format t "~% ~S~%" (caddr type+count+sizes)))
*dfun-count*)
(values))
-|#
+||#
(defun gfs-of-type (type)
(unless (consp type) (setq type (list type)))
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);
(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))))
(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
(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)))
;;; 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"
projects / sbcl.git / commitdiff