(in-package "SB!THREAD")
+;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is
+;;; necessary because threads are only supported with the conservative
+;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS)
+;;; are treated as references.
+
;;; set the doc here because in early-thread FDOCUMENTATION is not
;;; available, yet
#!+sb-doc
(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))
(sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
(defun init-initial-thread ()
+ (/show0 "Entering INIT-INITIAL-THREAD")
(let ((initial-thread (%make-thread :name "initial thread"
:%alive-p t
:os-thread (current-thread-sap-id))))
(define-alien-routine "signal_interrupt_thread"
integer (os-thread unsigned-long))
- (define-alien-routine "block_blockable_signals"
+ (define-alien-routine "block_deferrable_signals"
void)
- (declaim (inline futex-wait futex-wake))
-
- (sb!alien:define-alien-routine "futex_wait"
- int (word unsigned-long) (old-value unsigned-long))
-
- (sb!alien:define-alien-routine "futex_wake"
- int (word unsigned-long) (n unsigned-long)))
+ #!+sb-lutex
+ (progn
+ (declaim (inline %lutex-init %lutex-wait %lutex-wake
+ %lutex-lock %lutex-unlock))
+
+ (sb!alien:define-alien-routine ("lutex_init" %lutex-init)
+ int (lutex unsigned-long))
+
+ (sb!alien: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)
+ int (lutex unsigned-long) (n int))
+
+ (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock)
+ int (lutex unsigned-long))
+
+ (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock)
+ int (lutex unsigned-long))
+
+ (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy)
+ int (lutex unsigned-long))
+
+ ;; FIXME: Defining a whole bunch of alien-type machinery just for
+ ;; passing primitive lutex objects directly to foreign functions
+ ;; doesn't seem like fun right now. So instead we just manually
+ ;; pin the lutex, get its address, and let the callee untag it.
+ (defmacro with-lutex-address ((name lutex) &body body)
+ `(let ((,name ,lutex))
+ (with-pinned-objects (,name)
+ (let ((,name (sb!kernel:get-lisp-obj-address ,name)))
+ ,@body))))
+
+ (defun make-lutex ()
+ (/show0 "Entering MAKE-LUTEX")
+ ;; Suppress GC until the lutex has been properly registered with
+ ;; the GC.
+ (without-gcing
+ (let ((lutex (sb!vm::%make-lutex)))
+ (/show0 "LUTEX=..")
+ (/hexstr lutex)
+ (with-lutex-address (lutex lutex)
+ (%lutex-init lutex))
+ lutex))))
+
+ #!-sb-lutex
+ (progn
+ (declaim (inline futex-wait futex-wake))
+
+ (sb!alien:define-alien-routine "futex_wait"
+ int (word unsigned-long) (old-value unsigned-long))
+
+ (sb!alien:define-alien-routine "futex_wake"
+ 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)))
-;;;; spinlocks
+#!+sb-thread
+(defun sb!vm::current-thread-offset-sap (n)
+ (declare (type (unsigned-byte 27) n))
+ (sb!vm::current-thread-offset-sap n))
-(defstruct spinlock
- #!+sb-doc
- "Spinlock type."
- (name nil :type (or null simple-string))
- (value 0))
+;;;; spinlocks
(declaim (inline get-spinlock release-spinlock))
;;; The bare 2 here and below are offsets of the slots in the struct.
;;; There ought to be some better way to get these numbers
-(defun get-spinlock (spinlock new-value)
+(defun get-spinlock (spinlock)
(declare (optimize (speed 3) (safety 0))
#!-sb-thread
(ignore spinlock new-value))
;; store any value
#!+sb-thread
(loop until
- (eql (sb!vm::%instance-set-conditional spinlock 2 0 new-value) 0)))
+ (eql (sb!vm::%instance-set-conditional spinlock 2 0 1) 0)))
(defun release-spinlock (spinlock)
(declare (optimize (speed 3) (safety 0))
(defmacro with-spinlock ((spinlock) &body body)
(sb!int:with-unique-names (lock)
`(let ((,lock ,spinlock))
- (get-spinlock ,lock *current-thread*)
+ (get-spinlock ,lock)
(unwind-protect
(progn ,@body)
(release-spinlock ,lock)))))
;;;; mutexes
-(defstruct mutex
- #!+sb-doc
- "Mutex type."
- (name nil :type (or null simple-string))
- (value nil))
-
#!+sb-doc
(setf (sb!kernel:fdocumentation 'make-mutex 'function)
"Create a mutex."
(sb!kernel:fdocumentation 'mutex-value 'function)
"The value of the mutex. NIL if the mutex is free. Setfable.")
-#!+sb-thread
-(declaim (inline mutex-value-address))
-#!+sb-thread
-(defun mutex-value-address (mutex)
- (declare (optimize (speed 3)))
- (sb!ext:truly-the
- sb!vm:word
- (+ (sb!kernel:get-lisp-obj-address mutex)
- (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
+#!+(and sb-thread (not sb-lutex))
+(progn
+ (declaim (inline mutex-value-address))
+ (defun mutex-value-address (mutex)
+ (declare (optimize (speed 3)))
+ (sb!ext:truly-the
+ sb!vm:word
+ (+ (sb!kernel:get-lisp-obj-address mutex)
+ (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))))
(defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t))
#!+sb-doc
value if NIL. If WAIT-P 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
(setq new-value *current-thread*))
#!-sb-thread
(setf (mutex-value mutex) new-value)
t)
#!+sb-thread
- (let (old)
+ (progn
(when (eql new-value (mutex-value mutex))
(warn "recursive lock attempt ~S~%" mutex)
(format *debug-io* "Thread: ~A~%" *current-thread*)
(sb!debug:backtrace most-positive-fixnum *debug-io*)
(force-output *debug-io*))
- (loop
- (unless
- (setf old (sb!vm::%instance-set-conditional mutex 2 nil new-value))
- (return t))
- (unless wait-p (return nil))
- (futex-wait (mutex-value-address mutex)
- (sb!kernel:get-lisp-obj-address old)))))
+ ;; FIXME: sb-lutex and (not wait-p)
+ #!+sb-lutex
+ (when wait-p
+ (with-lutex-address (lutex (mutex-lutex mutex))
+ (%lutex-lock lutex))
+ (setf (mutex-value mutex) new-value))
+ #!-sb-lutex
+ (let (old)
+ (loop
+ (unless
+ (setf old (sb!vm::%instance-set-conditional mutex 2 nil
+ new-value))
+ (return t))
+ (unless wait-p (return nil))
+ (with-pinned-objects (mutex old)
+ (futex-wait (mutex-value-address mutex)
+ (sb!kernel:get-lisp-obj-address old)))))))
(defun release-mutex (mutex)
#!+sb-doc
"Release MUTEX by setting it to NIL. Wake up threads waiting for
this mutex."
(declare (type mutex mutex))
+ (/show0 "Entering RELEASE-MUTEX")
(setf (mutex-value mutex) nil)
#!+sb-thread
- (futex-wake (mutex-value-address mutex) 1))
+ (progn
+ #!+sb-lutex
+ (with-lutex-address (lutex (mutex-lutex mutex))
+ (%lutex-unlock lutex))
+ #!-sb-lutex
+ (futex-wake (mutex-value-address mutex) 1)))
;;;; waitqueues/condition variables
#!+sb-doc
"Waitqueue type."
(name nil :type (or null simple-string))
+ #!+(and sb-lutex sb-thread)
+ (lutex (make-lutex))
+ #!-sb-lutex
(data nil))
(defun make-waitqueue (&key name)
(setf (sb!kernel:fdocumentation 'waitqueue-name 'function)
"The name of the waitqueue. Setfable.")
-#!+sb-thread
-(declaim (inline waitqueue-data-address))
-#!+sb-thread
-(defun waitqueue-data-address (waitqueue)
- (declare (optimize (speed 3)))
- (sb!ext:truly-the
- sb!vm:word
- (+ (sb!kernel:get-lisp-obj-address waitqueue)
- (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
+#!+(and sb-thread (not sb-lutex))
+(progn
+ (declaim (inline waitqueue-data-address))
+ (defun waitqueue-data-address (waitqueue)
+ (declare (optimize (speed 3)))
+ (sb!ext:truly-the
+ sb!vm:word
+ (+ (sb!kernel:get-lisp-obj-address waitqueue)
+ (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))))
(defun condition-wait (queue mutex)
#!+sb-doc
#!-sb-thread (error "Not supported in unithread builds.")
#!+sb-thread
(let ((value (mutex-value mutex)))
+ (/show0 "CONDITION-WAITing")
+ #!+sb-lutex
+ (progn
+ (setf (mutex-value mutex) nil)
+ (with-lutex-address (queue-lutex-address (waitqueue-lutex queue))
+ (with-lutex-address (mutex-lutex-address (mutex-lutex mutex))
+ (%lutex-wait queue-lutex-address mutex-lutex-address)))
+ (setf (mutex-value mutex) value))
+ #!-sb-lutex
(unwind-protect
(let ((me *current-thread*))
;; XXX we should do something to ensure that the result of this setf
;; this comment, it will change queue->data, and so
;; futex-wait returns immediately instead of sleeping.
;; Ergo, no lost wakeup
- (futex-wait (waitqueue-data-address queue)
- (sb!kernel:get-lisp-obj-address me)))
+ (with-pinned-objects (queue me)
+ (futex-wait (waitqueue-data-address queue)
+ (sb!kernel:get-lisp-obj-address me))))
;; If we are interrupted while waiting, we should do these things
;; before returning. Ideally, in the case of an unhandled signal,
;; we should do them before entering the debugger, but this is
#!-sb-thread (error "Not supported in unithread builds.")
#!+sb-thread
(declare (type (and fixnum (integer 1)) n))
+ (/show0 "Entering CONDITION-NOTIFY")
#!+sb-thread
- (let ((me *current-thread*))
+ (progn
+ #!+sb-lutex
+ (with-lutex-address (lutex (waitqueue-lutex queue))
+ (%lutex-wake lutex n))
;; no problem if >1 thread notifies during the comment in
;; condition-wait: as long as the value in queue-data isn't the
;; waiting thread's id, it matters not what it is
;; XXX we should do something to ensure that the result of this setf
;; is visible to all CPUs
- (setf (waitqueue-data queue) me)
- (futex-wake (waitqueue-data-address queue) n)))
+ #!-sb-lutex
+ (let ((me *current-thread*))
+ (progn
+ (setf (waitqueue-data queue) me)
+ (with-pinned-objects (queue)
+ (futex-wake (waitqueue-data-address queue) n))))))
(defun condition-broadcast (queue)
#!+sb-doc
"Notify all threads waiting on QUEUE."
- (condition-notify queue most-positive-fixnum))
+ (condition-notify queue
+ ;; On a 64-bit platform truncating M-P-F to an int results
+ ;; in -1, which wakes up only one thread.
+ (ldb (byte 29 0)
+ most-positive-fixnum)))
;;;; semaphores
`(locally ,@body)
#!+sb-thread
`(without-interrupts
- (with-mutex ((session-lock ,session))
- ,@body)))
+ (with-mutex ((session-lock ,session))
+ ,@body)))
(defun new-session ()
(make-session :threads (list *current-thread*)
:interactive-threads (list *current-thread*)))
(defun init-job-control ()
- (setf *session* (new-session)))
+ (/show0 "Entering INIT-JOB-CONTROL")
+ (setf *session* (new-session))
+ (/show0 "Exiting INIT-JOB-CONTROL"))
(defun %delete-thread-from-session (thread session)
(with-session-lock (session)
;;; Remove thread from its session, if it has one.
#!+sb-thread
(defun handle-thread-exit (thread)
- (with-mutex (*all-threads-lock*)
- (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
#!+sb-thread
(let ((was-foreground t))
(loop
+ (/show0 "Looping in GET-FOREGROUND")
(with-session-lock (*session*)
(let ((int-t (session-interactive-threads *session*)))
(when (eq (car int-t) *current-thread*)
(sb!unix::unix-setsid)
(let* ((sb!impl::*stdin*
(make-fd-stream in :input t :buffering :line
- :dual-channel-p t))
+ :dual-channel-p t))
(sb!impl::*stdout*
(make-fd-stream out :output t :buffering :line
:dual-channel-p t))
(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.
(with-pinned-objects (initial-function)
(let ((os-thread
- ;; don't let the child inherit *CURRENT-THREAD* because that
- ;; can prevent gc'ing this thread while the child runs
- (let ((*current-thread* nil))
- (%create-thread
- (sb!kernel:get-lisp-obj-address initial-function)))))
+ (%create-thread
+ (sb!kernel:get-lisp-obj-address initial-function))))
(when (zerop os-thread)
(error "Can't create a new thread"))
(wait-on-semaphore setup-sem)
;; Called from the signal handler.
(defun run-interruption ()
(in-interruption ()
- (let ((interruption (with-interruptions-lock (*current-thread*)
- (pop (thread-interruptions *current-thread*)))))
- (with-interrupts
- (funcall interruption)))))
+ (loop
+ (let ((interruption (with-interruptions-lock (*current-thread*)
+ (pop (thread-interruptions *current-thread*)))))
+ (if interruption
+ (with-interrupts
+ (funcall interruption))
+ (return))))))
;; The order of interrupt execution is peculiar. If thread A
;; interrupts thread B with I1, I2 and B for some reason receives I1
(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