(defvar *all-threads* ())
(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)))
+
(defun list-all-threads ()
#!+sb-doc
"Return a list of the live threads."
- (with-mutex (*all-threads-lock*)
+ (with-all-threads-lock
(copy-list *all-threads*)))
(declaim (inline current-thread-sap))
(define-alien-routine "signal_interrupt_thread"
integer (os-thread unsigned-long))
- (define-alien-routine "block_blockable_signals"
+ (define-alien-routine "block_deferrable_signals"
void)
#!+sb-lutex
(sb!alien:define-alien-routine ("lutex_lock" %lutex-lock)
int (lutex unsigned-long))
+ (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock)
+ int (lutex unsigned-long))
+
(sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock)
int (lutex unsigned-long))
int (word unsigned-long) (n unsigned-long))))
;;; used by debug-int.lisp to access interrupt contexts
-#!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
+#!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
#!-sb-thread
(defun sb!vm::current-thread-offset-sap (n)
(declare (type (unsigned-byte 27) n))
(sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
(* n sb!vm:n-word-bytes)))
+#!+sb-thread
+(defun sb!vm::current-thread-offset-sap (n)
+ (declare (type (unsigned-byte 27) n))
+ (sb!vm::current-thread-offset-sap n))
+
;;;; spinlocks
(declaim (inline get-spinlock release-spinlock))
(format *debug-io* "Thread: ~A~%" *current-thread*)
(sb!debug:backtrace most-positive-fixnum *debug-io*)
(force-output *debug-io*))
- ;; FIXME: sb-lutex and (not wait-p)
#!+sb-lutex
- (when wait-p
- (with-lutex-address (lutex (mutex-lutex mutex))
- (%lutex-lock lutex))
+ (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
+ (if wait-p
+ (%lutex-lock lutex)
+ (%lutex-trylock lutex))))
(setf (mutex-value mutex) new-value))
#!-sb-lutex
(let (old)
;;; Remove thread from its session, if it has one.
#!+sb-thread
(defun handle-thread-exit (thread)
- (with-mutex (*all-threads-lock*)
- (/show0 "HANDLING THREAD EXIT")
- #!+sb-lutex
- (when (thread-interruptions-lock thread)
- (/show0 "FREEING MUTEX LUTEX")
- (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread)))
- (%lutex-destroy lutex)))
- (setq *all-threads* (delete thread *all-threads*)))
- (when *session*
- (%delete-thread-from-session thread *session*)))
+ (/show0 "HANDLING THREAD EXIT")
+ ;; We're going down, can't handle interrupts sanely anymore.
+ ;; GC remains enabled.
+ (block-deferrable-signals)
+ ;; Lisp-side cleanup
+ (with-all-threads-lock
+ (setf (thread-%alive-p thread) nil)
+ (setf (thread-os-thread thread) nil)
+ (setq *all-threads* (delete thread *all-threads*))
+ (when *session*
+ (%delete-thread-from-session thread *session*)))
+ #!+sb-lutex
+ (when (thread-interruptions-lock thread)
+ (/show0 "FREEING MUTEX LUTEX")
+ (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread)))
+ (%lutex-destroy lutex))))
(defun terminate-session ()
#!+sb-doc
(real-function (coerce function 'function))
(initial-function
(lambda ()
- ;; in time we'll move some of the binding presently done in C
- ;; here too
+ ;; In time we'll move some of the binding presently done in C
+ ;; here too.
+ ;;
+ ;; KLUDGE: Here we have a magic list of variables that are
+ ;; not thread-safe for one reason or another. As people
+ ;; report problems with the thread safety of certain
+ ;; variables, (e.g. "*print-case* in multiple threads
+ ;; broken", sbcl-devel 2006-07-14), we add a few more
+ ;; bindings here. The Right Thing is probably some variant
+ ;; of Allegro's *cl-default-special-bindings*, as that is at
+ ;; least accessible to users to secure their own libraries.
+ ;; --njf, 2006-07-15
(let ((*current-thread* thread)
(sb!kernel::*restart-clusters* nil)
(sb!kernel::*handler-clusters* nil)
(sb!kernel::*condition-restarts* nil)
+ (sb!impl::*step-out* nil)
+ ;; internal printer variables
+ (sb!impl::*previous-case* nil)
+ (sb!impl::*previous-readtable-case* nil)
+ (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small!
+ (sb!impl::*zap-array-data-temp* (vector)) ;
+ (sb!impl::*internal-symbol-output-fun* nil)
(sb!impl::*descriptor-handlers* nil)) ; serve-event
(setf (thread-os-thread thread) (current-thread-sap-id))
- (with-mutex (*all-threads-lock*)
+ (with-all-threads-lock
(push thread *all-threads*))
(with-session-lock (*session*)
(push thread (session-threads *session*)))
;; threads, it's time to enable signals
(sb!unix::reset-signal-mask)
(funcall real-function))
- ;; we're going down, can't handle
- ;; interrupts sanely anymore
- (let ((sb!impl::*gc-inhibit* t))
- (block-blockable-signals)
- (setf (thread-%alive-p thread) nil)
- (setf (thread-os-thread thread) nil)
- ;; and remove what can be the last
- ;; reference to this thread
- (handle-thread-exit thread)))))))
+ (handle-thread-exit thread))))))
(values))))
;; Keep INITIAL-FUNCTION pinned until the child thread is
;; initialized properly.
(if (eql tl-val sb!vm::no-tls-value-marker-widetag)
(sb!vm::symbol-global-value symbol)
(sb!kernel:make-lisp-obj tl-val))))
+
+(defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
+ (sb!vm::locked-symbol-global-value-add symbol-name delta))
+
+;;; Stepping
+
+(defun thread-stepping ()
+ (sb!kernel:make-lisp-obj
+ (sap-ref-word (current-thread-sap)
+ (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))))
+
+(defun (setf thread-stepping) (value)
+ (setf (sap-ref-word (current-thread-sap)
+ (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))
+ (sb!kernel:get-lisp-obj-address value)))
projects / sbcl.git / blobdiff