common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.9.2.9: thread objects

Browse source 
* Public interface changes
    ** proper thread objects instead of thread ids
    ** (MAKE-THREAD FN &KEY NAME) => THREAD
    ** (THREAD-NAME THREAD): threads have names (useful for debugging,
    logging)
    ** (THREAD-ALIVE-P THREAD)
    ** *CURRENT-THREAD* special is bound in each thread
    ** (LIST-ALL-THREADS) returns a list of all active threads
  * Notes
    ** thread-init moved earlier in cold-init and reinit
    ** the lisp side does not ever use os_thread_t (it was problematic due
       to pthread_t being opaque) but struct thread *
    ** threads are reaped (i.e. the thread is pthread_joined and struct
       thread* is freed) by the thread object's finalizer. This makes
       it easy to implement resetting threads. Running threads are kept
       in sb-thread::*all-threads*.
    ** threads block all blockable signals when going down:
       interrupt-thread and others cannot catch it at an inappropriate
       moment, for instance calling quit outside the catch %end-of-the-world
    ** target-thread.lisp renamed target-multithread.lisp,
       target-thread.lisp now contains the generic thread support
    ** new file early-thread.lisp: define *current-thread*
    ** removed thread state STOPPING that was only used for assertions and
       complicated matters
    ** renumbered thread states
    ** sb-thread::release-spinlock now releases the locks with
       non-fixnum value, but is no longer safe to call multiple times
    ** much simplified locking for threads and gc
    ** fixed deadlocking bugs introduced by the pthread merge
This commit is contained in:
Gabor Melis 2005-07-01 08:48:08 +00:00
parent a6831e56ae
commit 94ea2b2082
31 changed files with 830 additions and 737 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
NEWS
View file

@ -5,6 +5,13 @@ changes in sbcl-0.9.3 relative to sbcl-0.9.2:
* Support for the koi8-r external format. (thanks to Ivan Boldyrev)
* Bug fix: OPEN no longer fails when *PRINT-READABLY* is T. (thanks
to Zach Beane)
* threads
** incompatible change: the threading api now works with thread
objects instead of thread ids
** bug fix: threads are protected from signals and interruption when
starting up or going down
** bug fix: a race where an exiting thread could lose its stack to gc
** fixed numerous gc deadlocks introduced in the pthread merge
changes in sbcl-0.9.2 relative to sbcl-0.9.1:
* numerous signal handling fixes to increase stability

4
build-order.lisp-expr
View file

@ -121,6 +121,7 @@
;; mostly needed by stuff from comcom, but also used by "x86-vm"
("src/code/debug-var-io")
("src/code/early-thread")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; basic machinery for the target Lisp. Note that although most of these
;;; files are flagged :NOT-HOST, a few might not be.
@ -637,8 +638,9 @@
("src/code/sharpm" :not-host) ; uses stuff from "code/reader"
("src/code/alloc" :not-host)
#!+sb-thread
("src/code/target-thread" :not-host)
#!+sb-thread
("src/code/target-multithread" :not-host)
#!-sb-thread
("src/code/target-unithread" :not-host)
;; defines SB!DI:DO-DEBUG-FUN-BLOCKS, needed by target-disassem.lisp

67
contrib/sb-aclrepl/repl.lisp
View file

@ -301,23 +301,21 @@
(values))
#+sb-thread
(defun thread-pids ()
"Return a list of the pids for all threads"
(let ((offset (* 4 sb-vm::thread-os-thread-slot)))
(sb-thread::mapcar-threads
#'(lambda (sap) (sb-sys:sap-ref-32 sap offset)))))
(defun all-threads ()
"Return a list of all threads"
(sb-thread:list-all-threads))
#+sb-thread
(defun other-thread-pids ()
"Returns a list of pids for all threads except the current process"
(delete (sb-thread:current-thread-id) (thread-pids) :test #'eql))
(defun other-threads ()
"Returns a list of all threads except the current one"
(delete sb-thread:*current-thread* (all-threads)))
(defun exit-cmd (&optional (status 0))
#+sb-thread
(let ((other-pids (other-thread-pids)))
(when other-pids
(let ((other-threads (other-threads)))
(when other-threads
(format *output* "There exists the following processes~%")
(format *output* "~{~5d~%~}" other-pids)
(format *output* "~{~A~%~}" other-threads)
(format *output* "Do you want to exit lisp anyway [n]? ")
(force-output *output*)
(let ((input (string-trim-whitespace (read-line *input*))))
@ -325,9 +323,9 @@
(or (char= #\y (char input 0))
(char= #\Y (char input 0))))
;; loop in case more threads get created while trying to exit
(do ((pids other-pids (other-thread-pids)))
((eq nil pids))
(map nil #'sb-thread:destroy-thread pids)
(do ((threads other-threads (other-threads)))
((eq nil threads))
(map nil #'sb-thread:destroy-thread threads)
(sleep 0.2))
(return-from exit-cmd)))))
(sb-ext:quit :unix-status status)
@ -566,43 +564,21 @@
(defun processes-cmd ()
#+sb-thread
(let ((pids (thread-pids))
(current-pid (sb-thread:current-thread-id)))
(dolist (pid pids)
(format *output* "~&~D" pid)
(when (= pid current-pid)
(format *output* " [current listener]"))))
(dolist (thread (all-threads))
(format *output* "~&~A" thread)
(when (= thread sb-thread:*current-thread*)
(format *output* " [current listener]")))
#-sb-thread
(format *output* "~&Threads are not supported in this version of sbcl")
(values))
(defun kill-cmd (&rest selected-pids)
(defun kill-cmd (&rest selected-threads)
#+sb-thread
(let ((pids (thread-pids)))
(dolist (selected-pid selected-pids)
(if (find selected-pid pids :test #'eql)
(progn
(sb-thread:destroy-thread selected-pid)
(format *output* "~&Thread ~A destroyed" selected-pid))
(format *output* "~&No thread ~A exists" selected-pid))))
(dolist (thread selected-threads)
(sb-thread:destroy-thread thread)
(format *output* "~&Thread ~A destroyed" thread))
#-sb-thread
(declare (ignore selected-pids))
#-sb-thread
(format *output* "~&Threads are not supported in this version of sbcl")
(values))
(defun signal-cmd (signal &rest selected-pids)
#+sb-thread
(let ((pids (thread-pids)))
(dolist (selected-pid selected-pids)
(if (find selected-pid pids :test #'eql)
(progn
(sb-unix:unix-kill selected-pid signal)
(format *output* "~&Signal ~A sent to thread ~A"
signal selected-pid))
(format *output* "~&No thread ~A exists" selected-pid))))
#-sb-thread
(declare (ignore signal selected-pids))
(declare (ignore selected-threads))
#-sb-thread
(format *output* "~&Threads are not supported in this version of sbcl")
(values))
@ -658,7 +634,6 @@
("inspect" 2 inspect-cmd "inspect an object")
("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string)
#+sb-thread ("kill" 2 kill-cmd "kill (destroy) processes")
#+sb-thread ("signal" 2 signal-cmd "send a signal to processes")
#+sb-thread ("focus" 2 focus-cmd "focus the top level on a process")
("local" 3 local-cmd "print the value of a local variable")
("pwd" 3 pwd-cmd "print current directory")

13
doc/manual/threading.texinfo
View file

@ -58,12 +58,11 @@ if you want a bounded wait.
(defvar *a-mutex* (make-mutex :name "my lock"))
(defun thread-fn ()
(let ((id (current-thread-id)))
(format t "Thread ~A running ~%" id)
(with-mutex (*a-mutex*)
(format t "Thread ~A got the lock~%" id)
(sleep (random 5)))
(format t "Thread ~A dropped lock, dying now~%" id)))
(format t "Thread ~A running ~%" *current-thread*)
(with-mutex (*a-mutex*)
(format t "Thread ~A got the lock~%" *current-thread*)
(sleep (random 5)))
(format t "Thread ~A dropped lock, dying now~%" *current-thread*)))
(make-thread #'thread-fn)
(make-thread #'thread-fn)
@ -130,7 +129,7 @@ it.
(let ((head (car *buffer*)))
(setf *buffer* (cdr *buffer*))
(format t "reader ~A woke, read ~A~%"
(current-thread-id) head))))))
*current-thread* head))))))
(defun writer ()
(loop

7
package-data-list.lisp-expr
View file

@ -1587,14 +1587,15 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
:name "SB!THREAD"
:use ("CL" "SB!ALIEN" "SB!INT")
:doc "public (but low-level): native thread support"
:export ("MAKE-THREAD"
:export ("*CURRENT-THREAD*" "MAKE-THREAD" "THREAD"
"THREAD-NAME" "THREAD-ALIVE-P"
"LIST-ALL-THREADS"
"MAKE-LISTENER-THREAD" "DESTROY-THREAD" "TERMINATE-THREAD"
"INTERRUPT-THREAD" "WITH-RECURSIVE-LOCK"
"MUTEX" "MAKE-MUTEX" "GET-MUTEX" "RELEASE-MUTEX" "WITH-MUTEX"
"MUTEX-VALUE" "WAITQUEUE" "MAKE-WAITQUEUE"
"CONDITION-WAIT" "CONDITION-NOTIFY" "CONDITION-BROADCAST"
"WITH-RECURSIVE-LOCK" "RELEASE-FOREGROUND" "WITH-NEW-SESSION"
"CURRENT-THREAD-ID"))
"WITH-RECURSIVE-LOCK" "RELEASE-FOREGROUND" "WITH-NEW-SESSION"))
#s(sb-cold:package-data
:name "SB!LOOP"

5
src/code/cold-init.lisp
View file

@ -213,6 +213,7 @@
(show-and-call os-cold-init-or-reinit)
(show-and-call thread-init-or-reinit)
(show-and-call stream-cold-init-or-reset)
(show-and-call !loader-cold-init)
(show-and-call !foreign-cold-init)
@ -259,7 +260,6 @@
(terpri)
(/show0 "going into toplevel loop")
(handling-end-of-the-world
(thread-init-or-reinit)
(toplevel-init)
(critically-unreachable "after TOPLEVEL-INIT")))
@ -278,6 +278,7 @@ UNIX-like systems, UNIX-STATUS is used as the status code."
;;;; initialization functions
(defun thread-init-or-reinit ()
(sb!thread::init-initial-thread)
(sb!thread::init-job-control)
(sb!thread::get-foreground))
@ -285,6 +286,7 @@ UNIX-like systems, UNIX-STATUS is used as the status code."
(without-interrupts
(without-gcing
(os-cold-init-or-reinit)
(thread-init-or-reinit)
(stream-reinit)
(signal-cold-init-or-reinit)
(setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
@ -297,7 +299,6 @@ UNIX-like systems, UNIX-STATUS is used as the status code."
;; call site.
(set-floating-point-modes
:traps '(:overflow #!-netbsd :invalid :divide-by-zero))))
(thread-init-or-reinit)
(gc-reinit)
;; make sure TIME works correctly from saved cores
(setf *internal-real-time-base-seconds* nil)

4
src/code/debug.lisp
View file

@ -530,7 +530,7 @@ reset to ~S."
"~2&~@<debugger invoked on a ~S in thread ~A: ~
~2I~_~A~:>~%"
(type-of *debug-condition*)
(sb!thread:current-thread-id)
sb!thread:*current-thread*
*debug-condition*)
(error (condition)
(setf *nested-debug-condition* condition)
@ -606,7 +606,7 @@ reset to ~S."
(format *error-output*
"~&~@<unhandled ~S in thread ~S: ~2I~_~A~:>~2%"
(type-of condition)
(sb!thread:current-thread-id)
sb!thread:*current-thread*
condition)
;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
;; even if we hit an error within BACKTRACE (e.g. a bug in

1
src/code/early-impl.lisp
View file

@ -22,7 +22,6 @@
sb!vm::*current-catch-block*
sb!vm::*current-unwind-protect-block*
sb!vm::*alien-stack*
#!+sb-thread sb!thread::*foreground-thread-stack*
sb!vm::*control-stack-start*
sb!vm::*control-stack-end*
sb!vm::*binding-stack-start*

12
src/code/early-thread.lisp Normal file
View file

@ -0,0 +1,12 @@
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!THREAD")
(defvar *current-thread*)

7
src/code/exhaust.lisp
View file

@ -14,11 +14,8 @@
(define-alien-routine ("protect_control_stack_guard_page"
%protect-control-stack-guard-page)
sb!alien:void
(thread-id #!+sb-thread sb!alien:unsigned-long
#!-sb-thread sb!alien:int)
(thread-sap system-area-pointer)
(protect-p sb!alien:int))
(defun protect-control-stack-guard-page (n)
(%protect-control-stack-guard-page
(sb!thread:current-thread-id) (if n 1 0)))
(sb!thread::thread-%sap sb!thread:*current-thread*) (if n 1 0)))

8
src/code/gc.lisp
View file

@ -208,8 +208,8 @@ environment these hooks may run in any thread.")
(sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC")
(defun sub-gc (&key (gen 0))
(unless (eql (sb!thread:current-thread-id)
(sb!thread::mutex-value *already-in-gc*))
(unless (eq sb!thread:*current-thread*
(sb!thread::mutex-value *already-in-gc*))
;; With gencgc, unless *NEED-TO-COLLECT-GARBAGE* every allocation
;; in this function triggers another gc, potentially exceeding
;; maximum interrupt nesting.
@ -235,8 +235,7 @@ environment these hooks may run in any thread.")
;; current belief is that it is part of the normal order
;; of things and not a bug.
(when (plusp freed)
(incf *n-bytes-freed-or-purified* freed)))
(sb!thread::reap-dead-threads)))
(incf *n-bytes-freed-or-purified* freed)))))
;; Outside the mutex, these may cause another GC. FIXME: it can
;; potentially exceed maximum interrupt nesting by triggering
;; GCs.
@ -298,4 +297,3 @@ environment these hooks may run in any thread.")
"Disable the garbage collector."
(setq *gc-inhibit* 1)
nil)

387
src/code/target-multithread.lisp Normal file
View file

@ -0,0 +1,387 @@
;;;; support for threads in the target machine
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!THREAD")
(define-alien-routine ("create_thread" %create-thread)
system-area-pointer
(lisp-fun-address unsigned-long))
(define-alien-routine reap-dead-thread void
(thread-sap system-area-pointer))
(defvar *session* nil)
;;;; queues, locks
;; spinlocks use 0 as "free" value: higher-level locks use NIL
(declaim (inline get-spinlock release-spinlock))
(defun get-spinlock (lock offset new-value)
(declare (optimize (speed 3) (safety 0)))
;; %instance-set-conditional can test for 0 (which is a fixnum) and
;; store any value
(loop until
(eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
(defun release-spinlock (lock offset)
(declare (optimize (speed 3) (safety 0)))
;; %instance-set-conditional cannot compare arbitrary objects
;; meaningfully, so
;; (sb!vm::%instance-set-conditional lock offset our-value 0)
;; does not work for bignum thread ids.
(sb!vm::%instance-set lock offset 0))
(defmacro with-spinlock ((queue) &body body)
`(unwind-protect
(progn
(get-spinlock ,queue 2 *current-thread*)
,@body)
(release-spinlock ,queue 2)))
;;;; the higher-level locking operations are based on waitqueues
(declaim (inline waitqueue-data-address mutex-value-address))
(defstruct waitqueue
(name nil :type (or null simple-string))
(lock 0)
(data nil))
;;; The bare 4 here and 5 below are offsets of the slots in the struct.
;;; There ought to be some better way to get these numbers
(defun waitqueue-data-address (lock)
(declare (optimize (speed 3)))
(sb!ext:truly-the
(unsigned-byte 32)
(+ (sb!kernel:get-lisp-obj-address lock)
(- (* 4 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
(defstruct (mutex (:include waitqueue))
(value nil))
(defun mutex-value-address (lock)
(declare (optimize (speed 3)))
(sb!ext:truly-the
(unsigned-byte 32)
(+ (sb!kernel:get-lisp-obj-address lock)
(- (* 5 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
(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))
;;;; mutex
(defun get-mutex (lock &optional new-value (wait-p t))
"Acquire LOCK, setting it to NEW-VALUE or some suitable default value
if NIL. If WAIT-P is non-NIL and the lock is in use, sleep until it
is available"
(declare (type mutex lock) (optimize (speed 3)))
(let (old)
(unless new-value (setf new-value *current-thread*))
(when (eql new-value (mutex-value lock))
(warn "recursive lock attempt ~S~%" lock)
(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 lock 4 nil new-value))
(return t))
(unless wait-p (return nil))
(futex-wait (mutex-value-address lock)
(sb!kernel:get-lisp-obj-address old)))))
(defun release-mutex (lock)
(declare (type mutex lock))
(setf (mutex-value lock) nil)
(futex-wake (mutex-value-address lock) 1))
;;;; condition variables
(defun condition-wait (queue lock)
"Atomically release LOCK and enqueue ourselves on QUEUE. Another
thread may subsequently notify us using CONDITION-NOTIFY, at which
time we reacquire LOCK and return to the caller."
(assert lock)
(let ((value (mutex-value lock)))
(unwind-protect
(let ((me *current-thread*))
;; XXX we should do something to ensure that the result of this setf
;; is visible to all CPUs
(setf (waitqueue-data queue) me)
(release-mutex lock)
;; Now we go to sleep using futex-wait. If anyone else
;; manages to grab LOCK and call CONDITION-NOTIFY during
;; 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)))
;; 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
;; better than nothing.
(get-mutex lock value))))
(defun condition-notify (queue)
"Notify one of the processes waiting on QUEUE"
(let ((me *current-thread*))
;; 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) 1)))
(defun condition-broadcast (queue)
(let ((me *current-thread*))
(setf (waitqueue-data queue) me)
(futex-wake (waitqueue-data-address queue) (ash 1 30))))
(defun make-thread (function &key name)
;; ;; don't let them interrupt us because the child is waiting for setup-p
;; (sb!sys:without-interrupts
(let* ((thread (%make-thread :name name))
(setup-p nil)
(real-function (coerce function 'function))
(thread-sap
(%create-thread
(sb!kernel:get-lisp-obj-address
(lambda ()
;; FIXME: use semaphores?
(loop until setup-p)
;; in time we'll move some of the binding presently done in C
;; here too
(let ((*current-thread* thread)
(sb!kernel::*restart-clusters* nil)
(sb!kernel::*handler-clusters* nil)
(sb!kernel::*condition-restarts* nil)
(sb!impl::*descriptor-handlers* nil) ; serve-event
(sb!impl::*available-buffers* nil)) ;for fd-stream
;; can't use handling-end-of-the-world, because that flushes
;; output streams, and we don't necessarily have any (or we
;; could be sharing them)
(unwind-protect
(catch 'sb!impl::%end-of-the-world
(with-simple-restart
(terminate-thread
(format nil "~~@<Terminate this thread (~A)~~@:>"
*current-thread*))
;; now that most things have a chance to work
;; properly without messing up other threads, it's
;; time to enable signals
(sb!unix::reset-signal-mask)
(unwind-protect
(funcall real-function)
;; we're going down, can't handle
;; interrupts sanely anymore
(sb!unix::block-blockable-signals))))
;; mark the thread dead, so that the gc does not
;; wait for it to handle sig-stop-for-gc
(%set-thread-state thread :dead)
;; and remove what can be the last reference to
;; the thread object
(handle-thread-exit thread)
0))
(values))))))
(when (sb!sys:sap= thread-sap (sb!sys:int-sap 0))
(error "Can't create a new thread"))
(setf (thread-%sap thread) thread-sap)
(with-mutex (*all-threads-lock*)
(push thread *all-threads*))
(with-mutex ((session-lock *session*))
(push thread (session-threads *session*)))
(setq setup-p t)
(sb!impl::finalize thread (lambda () (reap-dead-thread thread-sap)))
thread))
(defun destroy-thread (thread)
"Deprecated. Soon to be removed or reimplemented using pthread_cancel."
(terminate-thread thread))
;;; a moderate degree of care is expected for use of interrupt-thread,
;;; due to its 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.
(define-condition interrupt-thread-error (error)
((thread :reader interrupt-thread-error-thread :initarg :thread)
(errno :reader interrupt-thread-error-errno :initarg :errno))
(:report (lambda (c s)
(format s "interrupt thread ~A failed (~A: ~A)"
(interrupt-thread-error-thread c)
(interrupt-thread-error-errno c)
(strerror (interrupt-thread-error-errno c))))))
(defun interrupt-thread (thread function)
"Interrupt THREAD and make it run FUNCTION."
(let ((function (coerce function 'function)))
(multiple-value-bind (res err)
(sb!unix::syscall ("interrupt_thread"
system-area-pointer sb!alien:unsigned-long)
thread
(thread-%sap thread)
(sb!kernel:get-lisp-obj-address function))
(unless res
(error 'interrupt-thread-error :thread thread :errno err)))))
(defun terminate-thread (thread)
"Terminate the thread identified by THREAD, by causing it to run
SB-EXT:QUIT - the usual cleanup forms will be evaluated"
(interrupt-thread thread 'sb!ext:quit))
;;; internal use only. If you think you need to use this, either you
;;; are an SBCL developer, are doing something that you should discuss
;;; with an SBCL developer first, or are doing something that you
;;; should probably discuss with a professional psychiatrist first
(defun symbol-value-in-thread (symbol thread)
(let ((thread-sap (thread-%sap thread)))
(let* ((index (sb!vm::symbol-tls-index symbol))
(tl-val (sb!sys:sap-ref-word thread-sap
(* sb!vm:n-word-bytes index))))
(if (eql tl-val sb!vm::unbound-marker-widetag)
(sb!vm::symbol-global-value symbol)
(sb!kernel:make-lisp-obj tl-val)))))
;;;; job control, independent listeners
(defstruct session
(lock (make-mutex :name "session lock"))
(threads nil)
(interactive-threads nil)
(interactive-threads-queue (make-waitqueue)))
(defun new-session ()
(make-session :threads (list *current-thread*)
:interactive-threads (list *current-thread*)))
(defun init-job-control ()
(setf *session* (new-session)))
(defun %delete-thread-from-session (thread session)
(with-mutex ((session-lock session))
(setf (session-threads session)
(delete thread (session-threads session))
(session-interactive-threads session)
(delete thread (session-interactive-threads session)))))
(defun call-with-new-session (fn)
(%delete-thread-from-session *current-thread* *session*)
(let ((*session* (new-session)))
(funcall fn)))
(defmacro with-new-session (args &body forms)
(declare (ignore args)) ;for extensibility
(sb!int:with-unique-names (fb-name)
`(labels ((,fb-name () ,@forms))
(call-with-new-session (function ,fb-name)))))
;;; Remove thread from its session, if it has one.
(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*)))
(defun terminate-session ()
"Kill all threads in session except for this one. Does nothing if current
thread is not the foreground thread"
;; FIXME: threads created in other threads may escape termination
(let ((to-kill
(with-mutex ((session-lock *session*))
(and (eq *current-thread*
(car (session-interactive-threads *session*)))
(session-threads *session*)))))
;; do the kill after dropping the mutex; unwind forms in dying
;; threads may want to do session things
(dolist (thread to-kill)
(unless (eq thread *current-thread*)
;; terminate the thread but don't be surprised if it has
;; exited in the meantime
(handler-case (terminate-thread thread)
(interrupt-thread-error ()))))))
;;; called from top of invoke-debugger
(defun debugger-wait-until-foreground-thread (stream)
"Returns T if thread had been running in background, NIL if it was
interactive."
(declare (ignore stream))
(prog1
(with-mutex ((session-lock *session*))
(not (member *current-thread*
(session-interactive-threads *session*))))
(get-foreground)))
(defun get-foreground ()
(let ((was-foreground t))
(loop
(with-mutex ((session-lock *session*))
(let ((int-t (session-interactive-threads *session*)))
(when (eq (car int-t) *current-thread*)
(unless was-foreground
(format *query-io* "Resuming thread ~A~%" *current-thread*))
(return-from get-foreground t))
(setf was-foreground nil)
(unless (member *current-thread* int-t)
(setf (cdr (last int-t))
(list *current-thread*)))
(condition-wait
(session-interactive-threads-queue *session*)
(session-lock *session*)))))))
(defun release-foreground (&optional next)
"Background this thread. If NEXT is supplied, arrange for it to
have the foreground next"
(with-mutex ((session-lock *session*))
(setf (session-interactive-threads *session*)
(delete *current-thread* (session-interactive-threads *session*)))
(when next
(setf (session-interactive-threads *session*)
(list* next
(delete next (session-interactive-threads *session*)))))
(condition-broadcast (session-interactive-threads-queue *session*))))
(defun foreground-thread ()
(car (session-interactive-threads *session*)))
(defun make-listener-thread (tty-name)
(assert (probe-file tty-name))
(let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
(out (sb!unix:unix-dup in))
(err (sb!unix:unix-dup in)))
(labels ((thread-repl ()
(sb!unix::unix-setsid)
(let* ((sb!impl::*stdin*
(sb!sys:make-fd-stream in :input t :buffering :line
:dual-channel-p t))
(sb!impl::*stdout*
(sb!sys:make-fd-stream out :output t :buffering :line
:dual-channel-p t))
(sb!impl::*stderr*
(sb!sys:make-fd-stream err :output t :buffering :line
:dual-channel-p t))
(sb!impl::*tty*
(sb!sys:make-fd-stream err :input t :output t
:buffering :line
:dual-channel-p t))
(sb!impl::*descriptor-handlers* nil))
(with-new-session ()
(unwind-protect
(sb!impl::toplevel-repl nil)
(sb!int:flush-standard-output-streams))))))
(make-thread #'thread-repl))))

4
src/code/target-signal.lisp
View file

@ -44,6 +44,8 @@
;;; When inappropriate build options are used, this also prints messages
;;; listing the signals that were masked
(sb!alien:define-alien-routine "reset_signal_mask" sb!alien:void)
(sb!alien:define-alien-routine "block_blockable_signals" sb!alien:void)
;;;; C routines that actually do all the work of establishing signal handlers
(sb!alien:define-alien-routine ("install_handler" install-handler)
@ -85,7 +87,7 @@
(defun sigint-%break (format-string &rest format-arguments)
#!+sb-thread
(let ((foreground-thread (sb!thread::foreground-thread)))
(if (eql foreground-thread (sb!thread:current-thread-id))
(if (eq foreground-thread sb!thread:*current-thread*)
(apply #'%break 'sigint format-string format-arguments)
(sb!thread:interrupt-thread
foreground-thread

431
src/code/target-thread.lisp
View file

@ -1,4 +1,5 @@
;;;; support for threads in the target machine
;;;; support for threads in the target machine common to uni- and
;;;; multithread systems
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
@ -11,384 +12,72 @@
(in-package "SB!THREAD")
;;; FIXME it would be good to define what a thread id is or isn't (our
;;; current assumption is that it's a fixnum). It so happens that on
;;; Linux it's a pid, but it might not be on posix thread implementations
(defstruct (thread (:constructor %make-thread))
name
%sap)
(define-alien-routine ("create_thread" %create-thread)
unsigned-long
(lisp-fun-address unsigned-long))
(def!method print-object ((thread thread) stream)
(if (thread-name thread)
(print-unreadable-object (thread stream :type t :identity t)
(prin1 (thread-name thread) stream))
(print-unreadable-object (thread stream :type t :identity t)
;; body is empty => there is only one space between type and
;; identity
))
thread)
(define-alien-routine reap-dead-threads void)
(defun thread-state (thread)
(let ((state
(sb!kernel:make-lisp-obj
(sb!sys:sap-int
(sb!sys:sap-ref-sap (thread-%sap thread)
(* sb!vm::thread-state-slot
sb!vm::n-word-bytes))))))
(ecase state
(0 :starting)
(1 :running)
(2 :suspended)
(3 :dead))))
(defvar *session* nil)
(defun %set-thread-state (thread state)
(setf (sb!sys:sap-ref-sap (thread-%sap thread)
(* sb!vm::thread-state-slot
sb!vm::n-word-bytes))
(sb!sys:int-sap
(sb!kernel:get-lisp-obj-address
(ecase state
(:starting 0)
(:running 1)
(:suspended 2)
(:dead 3))))))
;;;; queues, locks
(defun thread-alive-p (thread)
(not (eq :dead (thread-state thread))))
;; spinlocks use 0 as "free" value: higher-level locks use NIL
(declaim (inline get-spinlock release-spinlock))
;; A thread is eligible for gc iff it has finished and there are no
;; more references to it. This list is supposed to keep a reference to
;; all running threads.
(defvar *all-threads* ())
(defvar *all-threads-lock* (make-mutex :name "all threads lock"))
(defun get-spinlock (lock offset new-value)
(declare (optimize (speed 3) (safety 0)))
;; %instance-set-conditional can test for 0 (which is a fixnum) and
;; store any value
(loop until
(eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
(defun list-all-threads ()
(with-mutex (*all-threads-lock*)
(copy-list *all-threads*)))
(defun release-spinlock (lock offset)
(declare (optimize (speed 3) (safety 0)))
;; %instance-set-conditional cannot compare arbitrary objects
;; meaningfully, so
;; (sb!vm::%instance-set-conditional lock offset our-value 0)
;; does not work for bignum thread ids.
(sb!vm::%instance-set lock offset 0))
(declaim (inline current-thread-sap))
(defun current-thread-sap ()
(sb!vm::current-thread-offset-sap sb!vm::thread-this-slot))
(defmacro with-spinlock ((queue) &body body)
(with-unique-names (pid)
`(let ((,pid (current-thread-id)))
(unwind-protect
(progn
(get-spinlock ,queue 2 ,pid)
,@body)
(release-spinlock ,queue 2)))))
;;;; the higher-level locking operations are based on waitqueues
(declaim (inline waitqueue-data-address mutex-value-address))
(defstruct waitqueue
(name nil :type (or null simple-string))
(lock 0)
(data nil))
;;; The bare 4 here and 5 below are offsets of the slots in the struct.
;;; There ought to be some better way to get these numbers
(defun waitqueue-data-address (lock)
(declare (optimize (speed 3)))
(sb!ext:truly-the
(unsigned-byte 32)
(+ (sb!kernel:get-lisp-obj-address lock)
(- (* 4 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
(defstruct (mutex (:include waitqueue))
(value nil))
(defun mutex-value-address (lock)
(declare (optimize (speed 3)))
(sb!ext:truly-the
(unsigned-byte 32)
(+ (sb!kernel:get-lisp-obj-address lock)
(- (* 5 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
(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))
;;;; mutex
(defun get-mutex (lock &optional new-value (wait-p t))
"Acquire LOCK, setting it to NEW-VALUE or some suitable default value
if NIL. If WAIT-P is non-NIL and the lock is in use, sleep until it
is available"
(declare (type mutex lock) (optimize (speed 3)))
(let ((pid (current-thread-id))
old)
(unless new-value (setf new-value pid))
(when (eql new-value (mutex-value lock))
(warn "recursive lock attempt ~S~%" lock))
(loop
(unless
(setf old (sb!vm::%instance-set-conditional lock 4 nil new-value))
(return t))
(unless wait-p (return nil))
(futex-wait (mutex-value-address lock)
(sb!kernel:get-lisp-obj-address old)))))
(defun release-mutex (lock)
(declare (type mutex lock))
(setf (mutex-value lock) nil)
(futex-wake (mutex-value-address lock) 1))
;;;; condition variables
(defun condition-wait (queue lock)
"Atomically release LOCK and enqueue ourselves on QUEUE. Another
thread may subsequently notify us using CONDITION-NOTIFY, at which
time we reacquire LOCK and return to the caller."
(assert lock)
(let ((value (mutex-value lock)))
(unwind-protect
(let ((me (current-thread-id)))
;; XXX we should do something to ensure that the result of this setf
;; is visible to all CPUs
(setf (waitqueue-data queue) me)
(release-mutex lock)
;; Now we go to sleep using futex-wait. If anyone else
;; manages to grab LOCK and call CONDITION-NOTIFY during
;; 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)))
;; 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
;; better than nothing.
(get-mutex lock value))))
(defun condition-notify (queue)
"Notify one of the processes waiting on QUEUE"
(let ((me (current-thread-id)))
;; 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) 1)))
(defun condition-broadcast (queue)
(let ((me (current-thread-id)))
(setf (waitqueue-data queue) me)
(futex-wake (waitqueue-data-address queue) (ash 1 30))))
(defun make-thread (function)
(let* ((real-function (coerce function 'function))
(tid
(%create-thread
(sb!kernel:get-lisp-obj-address
(lambda ()
;; in time we'll move some of the binding presently done in C
;; here too
(let ((sb!kernel::*restart-clusters* nil)
(sb!kernel::*handler-clusters* nil)
(sb!kernel::*condition-restarts* nil)
(sb!impl::*descriptor-handlers* nil) ; serve-event
(sb!impl::*available-buffers* nil)) ;for fd-stream
;; can't use handling-end-of-the-world, because that flushes
;; output streams, and we don't necessarily have any (or we
;; could be sharing them)
(catch 'sb!impl::%end-of-the-world
(with-simple-restart
(terminate-thread
(format nil "~~@<Terminate this thread (~A)~~@:>"
(current-thread-id)))
;; now that most things have a chance to work
;; properly without messing up other threads, it's
;; time to enable signals
(sb!unix::reset-signal-mask)
(funcall real-function))
0))
(values))))))
(when (zerop tid) (error "Can't create a new thread"))
(with-mutex ((session-lock *session*))
(pushnew tid (session-threads *session*)))
tid))
(defun destroy-thread (thread-id)
"Deprecated. Soon to be removed or reimplemented using pthread_cancel."
(terminate-thread thread-id))
;;; a moderate degree of care is expected for use of interrupt-thread,
;;; due to its 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. Used with thought
;;; though, it's a good deal gentler than the last-resort functions above
(define-condition interrupt-thread-error (error)
((thread :reader interrupt-thread-error-thread :initarg :thread)
(errno :reader interrupt-thread-error-errno :initarg :errno))
(:report (lambda (c s)
(format s "interrupt thread ~A failed (~A: ~A)"
(interrupt-thread-error-thread c)
(interrupt-thread-error-errno c)
(strerror (interrupt-thread-error-errno c))))))
(defun interrupt-thread (thread function)
"Interrupt THREAD and make it run FUNCTION."
(let ((function (coerce function 'function)))
(multiple-value-bind (res err)
(sb!unix::syscall ("interrupt_thread"
sb!alien:unsigned-long sb!alien:unsigned-long)
thread
thread
(sb!kernel:get-lisp-obj-address function))
(unless res
(error 'interrupt-thread-error :thread thread :errno err)))))
(defun terminate-thread (thread-id)
"Terminate the thread identified by THREAD-ID, by causing it to run
SB-EXT:QUIT - the usual cleanup forms will be evaluated"
(interrupt-thread thread-id 'sb!ext:quit))
(declaim (inline current-thread-id))
(defun current-thread-id ()
(declaim (inline current-thread-sap-id))
(defun current-thread-sap-id ()
(sb!sys:sap-int
(sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
;;;; iterate over the in-memory threads
(defun mapcar-threads (function)
"Call FUNCTION once for each known thread, giving it the thread structure as argument"
(let ((function (coerce function 'function)))
(loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
then (sb!sys:sap-ref-sap thread (* sb!vm:n-word-bytes
sb!vm::thread-next-slot))
until (sb!sys:sap= thread (sb!sys:int-sap 0))
collect (funcall function thread))))
(defun thread-sap-from-id (id)
(let ((thread (alien-sap (extern-alien "all_threads" (* t)))))
(loop
(when (sb!sys:sap= thread (sb!sys:int-sap 0)) (return nil))
;; FIXME: 32/64 bit
(let ((pid (sb!sys:sap-ref-32 thread (* sb!vm:n-word-bytes
sb!vm::thread-os-thread-slot))))
(when (= pid id) (return thread))
(setf thread (sb!sys:sap-ref-sap thread (* sb!vm:n-word-bytes
sb!vm::thread-next-slot)))))))
;;; internal use only. If you think you need to use this, either you
;;; are an SBCL developer, are doing something that you should discuss
;;; with an SBCL developer first, or are doing something that you
;;; should probably discuss with a professional psychiatrist first
(defun symbol-value-in-thread (symbol thread-id)
(let ((thread (thread-sap-from-id thread-id)))
(when thread
(let* ((index (sb!vm::symbol-tls-index symbol))
(tl-val (sb!sys:sap-ref-word thread
(* sb!vm:n-word-bytes index))))
(if (eql tl-val sb!vm::unbound-marker-widetag)
(sb!vm::symbol-global-value symbol)
(sb!kernel:make-lisp-obj tl-val))))))
;;;; job control, independent listeners
(defstruct session
(lock (make-mutex :name "session lock"))
(threads nil)
(interactive-threads nil)
(interactive-threads-queue (make-waitqueue)))
(defun new-session ()
(let ((tid (current-thread-id)))
(make-session :threads (list tid)
:interactive-threads (list tid))))
(defun init-job-control ()
(setf *session* (new-session)))
(defun %delete-thread-from-session (tid session)
(with-mutex ((session-lock session))
(setf (session-threads session)
(delete tid (session-threads session))
(session-interactive-threads session)
(delete tid (session-interactive-threads session)))))
(defun call-with-new-session (fn)
(%delete-thread-from-session (current-thread-id) *session*)
(let ((*session* (new-session))) (funcall fn)))
(defmacro with-new-session (args &body forms)
(declare (ignore args)) ;for extensibility
(sb!int:with-unique-names (fb-name)
`(labels ((,fb-name () ,@forms))
(call-with-new-session (function ,fb-name)))))
;;; Remove thread id TID from its session, if it has one. This is
;;; called from C mark_thread_dead().
(defun handle-thread-exit (tid)
(when *session*
(%delete-thread-from-session tid *session*)))
(defun terminate-session ()
"Kill all threads in session except for this one. Does nothing if current
thread is not the foreground thread"
(reap-dead-threads)
;; FIXME: threads created in other threads may escape termination
(let* ((tid (current-thread-id))
(to-kill
(with-mutex ((session-lock *session*))
(and (eql tid (car (session-interactive-threads *session*)))
(session-threads *session*)))))
;; do the kill after dropping the mutex; unwind forms in dying
;; threads may want to do session things
(dolist (p to-kill)
(unless (eql p tid)
;; terminate the thread but don't be surprised if it has
;; exited in the meantime
(handler-case (terminate-thread p)
(interrupt-thread-error ()))))))
;;; called from top of invoke-debugger
(defun debugger-wait-until-foreground-thread (stream)
"Returns T if thread had been running in background, NIL if it was
interactive."
(declare (ignore stream))
(prog1
(with-mutex ((session-lock *session*))
(not (member (current-thread-id)
(session-interactive-threads *session*))))
(get-foreground)))
(defun get-foreground ()
(let ((was-foreground t))
(loop
(with-mutex ((session-lock *session*))
(let ((tid (current-thread-id))
(int-t (session-interactive-threads *session*)))
(when (eql (car int-t) tid)
(unless was-foreground
(format *query-io* "Resuming thread ~A~%" tid))
(return-from get-foreground t))
(setf was-foreground nil)
(unless (member tid int-t)
(setf (cdr (last int-t))
(list tid)))
(condition-wait
(session-interactive-threads-queue *session*)
(session-lock *session*)))))))
(defun release-foreground (&optional next)
"Background this thread. If NEXT is supplied, arrange for it to have the foreground next"
(with-mutex ((session-lock *session*))
(let ((tid (current-thread-id)))
(setf (session-interactive-threads *session*)
(delete tid (session-interactive-threads *session*)))
(when next
(setf (session-interactive-threads *session*)
(list* next
(delete next (session-interactive-threads *session*)))))
(condition-broadcast (session-interactive-threads-queue *session*)))))
(defun foreground-thread ()
(car (session-interactive-threads *session*)))
(defun make-listener-thread (tty-name)
(assert (probe-file tty-name))
(let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
(out (sb!unix:unix-dup in))
(err (sb!unix:unix-dup in)))
(labels ((thread-repl ()
(sb!unix::unix-setsid)
(let* ((sb!impl::*stdin*
(sb!sys:make-fd-stream in :input t :buffering :line :dual-channel-p t))
(sb!impl::*stdout*
(sb!sys:make-fd-stream out :output t :buffering :line :dual-channel-p t))
(sb!impl::*stderr*
(sb!sys:make-fd-stream err :output t :buffering :line :dual-channel-p t))
(sb!impl::*tty*
(sb!sys:make-fd-stream err :input t :output t :buffering :line :dual-channel-p t))
(sb!impl::*descriptor-handlers* nil))
(with-new-session ()
(unwind-protect
(sb!impl::toplevel-repl nil)
(sb!int:flush-standard-output-streams))))))
(make-thread #'thread-repl))))
(defun init-initial-thread ()
(let ((initial-thread (%make-thread :name "initial thread"
:%sap (current-thread-sap))))
(setq *current-thread* initial-thread)
;; Either *all-threads* is empty or it contains exactly one thread
;; in case we are in reinit since saving core with multiple
;; threads doesn't work.
(setq *all-threads* (list initial-thread))))

19
src/code/target-unithread.lisp
View file

@ -13,19 +13,12 @@
;;; used bu debug-int.lisp to access interrupt contexts
#!-sb-fluid (declaim (inline sb!vm::current-thread-offset-sap))
(defun sb!vm::current-thread-offset-sap (n)
(defun sb!vm::current-thread-offset-sap (n)
(declare (type (unsigned-byte 27) n))
(sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
(* n sb!vm:n-word-bytes)))
(sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
(* n sb!vm:n-word-bytes)))
(defun current-thread-id ()
;; FIXME: 32/64
(sb!sys:sap-ref-32 (alien-sap (extern-alien "all_threads" (* t)))
(* sb!vm::thread-os-thread-slot sb!vm:n-word-bytes)))
(defun reap-dead-threads ())
;;;; queues, locks
;;;; queues, locks
;; spinlocks use 0 as "free" value: higher-level locks use NIL
(defun get-spinlock (lock offset new-value)
@ -53,7 +46,7 @@
(when (and old-value wait-p)
(error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~
new-value ~S, but has already been acquired (with value ~S)."
lock wait-p new-value old-value))
lock wait-p new-value old-value))
(setf (mutex-value lock) new-value)
t))
@ -62,7 +55,7 @@
(setf (mutex-value lock) nil))
;; FIXME need suitable stub or ERROR-signaling definitions for
;; FIXME need suitable stub or ERROR-signaling definitions for
;; condition-wait (queue lock)
;; condition-notify (queue)

1
src/code/thread.lisp
View file

@ -53,4 +53,3 @@
(release-mutex ,mutex)))))
#!-sb-thread
`(locally ,@body))

3
src/compiler/generic/genesis.lisp
View file

@ -1276,8 +1276,7 @@ core and return a descriptor to it."
(frob sb!kernel::undefined-alien-function-error)
(frob sb!kernel::memory-fault-error)
(frob sb!di::handle-breakpoint)
(frob sb!di::handle-fun-end-breakpoint)
(frob sb!thread::handle-thread-exit))
(frob sb!di::handle-fun-end-breakpoint))
(cold-set 'sb!vm::*current-catch-block* (make-fixnum-descriptor 0))
(cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0))

3
src/compiler/generic/objdef.lisp
View file

@ -377,7 +377,8 @@
(this :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
(prev :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
(next :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
(state) ; running, stopping, stopped, dead
;; starting, running, suspended, dead
(state)
#!+(or x86 x86-64) (pseudo-atomic-atomic)
#!+(or x86 x86-64) (pseudo-atomic-interrupted)
(interrupt-fun)

1
src/compiler/x86-64/parms.lisp
View file

@ -168,7 +168,6 @@
sb!kernel::memory-fault-error
sb!di::handle-breakpoint
fdefinition-object
#!+sb-thread sb!thread::handle-thread-exit
;; free pointers
;;

1
src/compiler/x86/parms.lisp
View file

@ -274,7 +274,6 @@
sb!kernel::memory-fault-error
sb!di::handle-breakpoint
fdefinition-object
#!+sb-thread sb!thread::handle-thread-exit
;; free pointers
;;

13
src/pcl/low.lisp
View file

@ -352,16 +352,11 @@
#+sb-thread
(progn
(defstruct spinlock (value 0))
(defvar *pcl-lock* (make-spinlock))
(defvar *pcl-lock* (sb-thread:make-waitqueue))
(defmacro with-pcl-lock (&body body)
`(progn
(sb-thread::get-spinlock *pcl-lock* 1 (sb-thread::current-thread-id))
(unwind-protect
(progn ,@body)
(setf (spinlock-value *pcl-lock*) 0))))
);progn
(defmacro with-pcl-lock (&body body)
`(sb-thread::with-spinlock (*pcl-lock*)
,@body)))
#-sb-thread
(defmacro with-pcl-lock (&body body)

6
src/runtime/gencgc.c
View file

@ -4154,8 +4154,10 @@ alloc(long nbytes)
sigaddset_blockable(&new_mask);
thread_sigmask(SIG_BLOCK,&new_mask,&old_mask);
if((!data->pending_handler) &&
maybe_defer_handler(interrupt_maybe_gc_int,data,0,0,0)) {
if(!data->pending_handler) {
if(!maybe_defer_handler(interrupt_maybe_gc_int,data,0,0,0))
lose("Not in atomic: %d.\n",
SymbolValue(PSEUDO_ATOMIC_ATOMIC,thread));
/* Leave the signals blocked just as if it was
* deferred the normal way and set the
* pending_mask. */

38
src/runtime/interrupt.c
View file

@ -75,8 +75,6 @@ static void store_signal_data_for_later (struct interrupt_data *data,
os_context_t *context);
boolean interrupt_maybe_gc_int(int signal, siginfo_t *info, void *v_context);
extern volatile lispobj all_threads_lock;
void sigaddset_blockable(sigset_t *s)
{
sigaddset(s, SIGHUP);
@ -150,7 +148,13 @@ void reset_signal_mask ()
thread_sigmask(SIG_SETMASK,&new,0);
}
void block_blockable_signals ()
{
sigset_t block;
sigemptyset(&block);
sigaddset_blockable(&block);
thread_sigmask(SIG_BLOCK, &block, 0);
}
/*
@ -261,10 +265,7 @@ undo_fake_foreign_function_call(os_context_t *context)
{
struct thread *thread=arch_os_get_current_thread();
/* Block all blockable signals. */
sigset_t block;
sigemptyset(&block);
sigaddset_blockable(&block);
thread_sigmask(SIG_BLOCK, &block, 0);
block_blockable_signals();
/* going back into Lisp */
foreign_function_call_active = 0;
@ -639,16 +640,16 @@ sig_stop_for_gc_handler(int signal, siginfo_t *info, void *void_context)
* good time to let the kernel reap any of our children in that
* awful state, to stop them from being waited for indefinitely.
* Userland reaping is done later when GC is finished */
if(thread->state!=STATE_STOPPING) {
lose("sig_stop_for_gc_handler: wrong thread state: %ld\n",
fixnum_value(thread->state));
if(thread->state!=STATE_RUNNING) {
lose("sig_stop_for_gc_handler: wrong thread state: %ld\n",
fixnum_value(thread->state));
}
thread->state=STATE_STOPPED;
thread->state=STATE_SUSPENDED;
sigemptyset(&ss); sigaddset(&ss,SIG_STOP_FOR_GC);
sigwaitinfo(&ss,0);
if(thread->state!=STATE_STOPPED) {
lose("sig_stop_for_gc_handler: wrong thread state on wakeup: %ld\n",
if(thread->state!=STATE_SUSPENDED) {
lose("sig_stop_for_gc_handler: wrong thread state on wakeup: %ld\n",
fixnum_value(thread->state));
}
thread->state=STATE_RUNNING;
@ -839,6 +840,9 @@ void interrupt_thread_handler(int num, siginfo_t *info, void *v_context)
* thread interrupt execution is undefined. */
struct thread *th=arch_os_get_current_thread();
struct cons *c;
if (th->state != STATE_RUNNING)
lose("interrupt_thread_handler: thread %ld in wrong state: %d\n",
th->os_thread,fixnum_value(th->state));
get_spinlock(&th->interrupt_fun_lock,(long)th);
c=((struct cons *)native_pointer(th->interrupt_fun));
arrange_return_to_lisp_function(context,c->car);
@ -869,8 +873,8 @@ boolean handle_guard_page_triggered(os_context_t *context,void *addr){
* protection so the error handler has some headroom, protect the
* previous page so that we can catch returns from the guard page
* and restore it. */
protect_control_stack_guard_page(th->os_thread,0);
protect_control_stack_return_guard_page(th->os_thread,1);
protect_control_stack_guard_page(th,0);
protect_control_stack_return_guard_page(th,1);
arrange_return_to_lisp_function
(context, SymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR));
@ -882,8 +886,8 @@ boolean handle_guard_page_triggered(os_context_t *context,void *addr){
* unprotect this one. This works even if we somehow missed
* the return-guard-page, and hit it on our way to new
* exhaustion instead. */
protect_control_stack_guard_page(th->os_thread,1);
protect_control_stack_return_guard_page(th->os_thread,0);
protect_control_stack_guard_page(th,1);
protect_control_stack_return_guard_page(th,0);
return 1;
}
else if (addr >= undefined_alien_address &&

377
src/runtime/thread.c
View file

@ -28,10 +28,53 @@
int dynamic_values_bytes=4096*sizeof(lispobj); /* same for all threads */
struct thread *all_threads;
volatile lispobj all_threads_lock;
volatile lispobj thread_start_lock;
extern struct interrupt_data * global_interrupt_data;
extern int linux_no_threads_p;
/* When trying to get all_threads_lock one should make sure that
* sig_stop_for_gc is not blocked. Else there would be a possible
* deadlock: gc locks it, other thread blocks signals, gc sends stop
* request to other thread and waits, other thread blocks on lock. */
void check_sig_stop_for_gc_can_arrive_or_lose()
{
/* Get the current sigmask, by blocking the empty set. */
sigset_t empty,current;
sigemptyset(&empty);
thread_sigmask(SIG_BLOCK, &empty, &current);
if (sigismember(&current,SIG_STOP_FOR_GC))
lose("SIG_STOP_FOR_GC is blocked\n");
if (SymbolValue(INTERRUPTS_ENABLED,arch_os_get_current_thread()) == NIL)
lose("interrupts disabled\n");
if (arch_pseudo_atomic_atomic(NULL))
lose("n pseudo atomic\n");
}
#ifdef QSHOW_SIGNALS
#define FSHOW_SIGNAL FSHOW
#else
#define FSHOW_SIGNAL(args)
#endif
#define GET_ALL_THREADS_LOCK(name) \
{ \
sigset_t _newset,_oldset; \
sigemptyset(&_newset); \
sigaddset_blockable(&_newset); \
sigdelset(&_newset,SIG_STOP_FOR_GC); \
thread_sigmask(SIG_BLOCK, &_newset, &_oldset); \
check_sig_stop_for_gc_can_arrive_or_lose(); \
FSHOW_SIGNAL((stderr,"/%s:waiting on lock=%ld, thread=%ld\n",name, \
all_threads_lock,arch_os_get_current_thread()->os_thread)); \
get_spinlock(&all_threads_lock,(long)arch_os_get_current_thread()); \
FSHOW_SIGNAL((stderr,"/%s:got lock, thread=%ld\n", \
name,arch_os_get_current_thread()->os_thread));
#define RELEASE_ALL_THREADS_LOCK(name) \
FSHOW_SIGNAL((stderr,"/%s:released lock\n",name)); \
release_spinlock(&all_threads_lock); \
thread_sigmask(SIG_SETMASK,&_oldset,0); \
}
int
initial_thread_trampoline(struct thread *th)
{
@ -54,14 +97,6 @@ initial_thread_trampoline(struct thread *th)
}
#ifdef LISP_FEATURE_SB_THREAD
void mark_thread_dead(struct thread *th) {
funcall1(SymbolFunction(HANDLE_THREAD_EXIT),alloc_number(th->os_thread));
/* I hope it's safe for a thread to detach itself inside a
* cancellation cleanup */
pthread_detach(th->os_thread);
th->state=STATE_DEAD;
/* FIXME: if gc hits here it will rip the stack from under us */
}
/* this is the first thing that runs in the child (which is why the
* silly calling convention). Basically it calls the user's requested
@ -71,26 +106,22 @@ void mark_thread_dead(struct thread *th) {
int
new_thread_trampoline(struct thread *th)
{
lispobj function,ret;
lispobj function;
function = th->unbound_marker;
th->unbound_marker = UNBOUND_MARKER_WIDETAG;
pthread_cleanup_push((void (*) (void *))mark_thread_dead,th);
if(arch_os_thread_init(th)==0) return 1;
if(arch_os_thread_init(th)==0) return 1;
/* wait here until our thread is linked into all_threads: see below */
while(th->os_thread<1) sched_yield();
th->state=STATE_RUNNING;
ret = funcall0(function);
/* execute cleanup */
pthread_cleanup_pop(1);
return ret;
return funcall0(function);
}
#endif /* LISP_FEATURE_SB_THREAD */
/* this is called from any other thread to create the new one, and
* initialize all parts of it that can be initialized from another
* thread
* initialize all parts of it that can be initialized from another
* thread
*/
struct thread * create_thread_struct(lispobj initial_function) {
@ -123,7 +154,7 @@ struct thread * create_thread_struct(lispobj initial_function) {
int i;
for(i=0;i<(dynamic_values_bytes/sizeof(lispobj));i++)
per_thread->dynamic_values[i]=UNBOUND_MARKER_WIDETAG;
if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG)
if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG)
SetSymbolValue
(FREE_TLS_INDEX,
make_fixnum(MAX_INTERRUPTS+
@ -132,7 +163,7 @@ struct thread * create_thread_struct(lispobj initial_function) {
#define STATIC_TLS_INIT(sym,field) \
((struct symbol *)(sym-OTHER_POINTER_LOWTAG))->tls_index= \
make_fixnum(THREAD_SLOT_OFFSET_WORDS(field))
STATIC_TLS_INIT(BINDING_STACK_START,binding_stack_start);
STATIC_TLS_INIT(BINDING_STACK_POINTER,binding_stack_pointer);
STATIC_TLS_INIT(CONTROL_STACK_START,control_stack_start);
@ -176,7 +207,7 @@ struct thread * create_thread_struct(lispobj initial_function) {
#ifndef LISP_FEATURE_SB_THREAD
/* the tls-points-into-struct-thread trick is only good for threaded
* sbcl, because unithread sbcl doesn't have tls. So, we copy the
* appropriate values from struct thread here, and make sure that
* appropriate values from struct thread here, and make sure that
* we use the appropriate SymbolValue macros to access any of the
* variable quantities from the C runtime. It's not quite OAOOM,
* it just feels like it */
@ -192,20 +223,20 @@ struct thread * create_thread_struct(lispobj initial_function) {
current_binding_stack_pointer=th->binding_stack_pointer;
current_control_stack_pointer=th->control_stack_start;
#endif
#endif
#endif
bind_variable(CURRENT_CATCH_BLOCK,make_fixnum(0),th);
bind_variable(CURRENT_UNWIND_PROTECT_BLOCK,make_fixnum(0),th);
bind_variable(CURRENT_UNWIND_PROTECT_BLOCK,make_fixnum(0),th);
bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,make_fixnum(0),th);
bind_variable(INTERRUPT_PENDING, NIL,th);
bind_variable(INTERRUPTS_ENABLED,T,th);
th->interrupt_data = (struct interrupt_data *)
os_validate(0,(sizeof (struct interrupt_data)));
if(all_threads)
if(all_threads)
memcpy(th->interrupt_data,
arch_os_get_current_thread()->interrupt_data,
sizeof (struct interrupt_data));
else
else
memcpy(th->interrupt_data,global_interrupt_data,
sizeof (struct interrupt_data));
@ -215,12 +246,6 @@ struct thread * create_thread_struct(lispobj initial_function) {
void link_thread(struct thread *th,os_thread_t kid_tid)
{
sigset_t newset,oldset;
sigemptyset(&newset);
sigaddset_blockable(&newset);
thread_sigmask(SIG_BLOCK, &newset, &oldset);
get_spinlock(&all_threads_lock,kid_tid);
if (all_threads) all_threads->prev=th;
th->next=all_threads;
th->prev=0;
@ -229,12 +254,9 @@ void link_thread(struct thread *th,os_thread_t kid_tid)
* all_threads_lock to ensure that we don't have >1 thread with
* os_thread=0 on the list at once
*/
protect_control_stack_guard_page(th->os_thread,1);
protect_control_stack_guard_page(th,1);
/* child will not start until this is set */
th->os_thread=kid_tid;
release_spinlock(&all_threads_lock);
thread_sigmask(SIG_SETMASK,&oldset,0);
}
void create_initial_thread(lispobj initial_function) {
@ -247,180 +269,185 @@ void create_initial_thread(lispobj initial_function) {
}
#ifdef LISP_FEATURE_SB_THREAD
os_thread_t create_thread(lispobj initial_function) {
struct thread *th;
os_thread_t kid_tid=0;
pthread_attr_t attr;
if(linux_no_threads_p) return 0;
th=create_thread_struct(initial_function);
if(th==0) return 0;
#ifdef QSHOW_SIGNALS
SHOW("create_thread:waiting on lock");
#endif
get_spinlock(&thread_start_lock,arch_os_get_current_thread()->os_thread);
#ifdef QSHOW_SIGNALS
SHOW("create_thread:got lock");
#endif
boolean create_os_thread(struct thread *th,os_thread_t *kid_tid)
{
/* The new thread inherits the restrictive signal mask set here,
* and enables signals again when it is set up properly. */
{
sigset_t newset,oldset;
sigemptyset(&newset);
sigaddset_blockable(&newset);
thread_sigmask(SIG_BLOCK, &newset, &oldset);
if((pthread_attr_init(&attr)) ||
(pthread_attr_setstack(&attr,th->control_stack_start,
THREAD_CONTROL_STACK_SIZE-16)) ||
(pthread_create
(&kid_tid,&attr,(void *(*)(void *))new_thread_trampoline,th)))
kid_tid=0;
thread_sigmask(SIG_SETMASK,&oldset,0);
}
if(kid_tid>0) {
pthread_attr_t attr;
sigset_t newset,oldset;
boolean r=1;
sigemptyset(&newset);
sigaddset_blockable(&newset);
thread_sigmask(SIG_BLOCK, &newset, &oldset);
if((pthread_attr_init(&attr)) ||
(pthread_attr_setstack(&attr,th->control_stack_start,
THREAD_CONTROL_STACK_SIZE-16)) ||
(pthread_create
(kid_tid,&attr,(void *(*)(void *))new_thread_trampoline,th)))
r=0;
thread_sigmask(SIG_SETMASK,&oldset,0);
return r;
}
struct thread *create_thread(lispobj initial_function) {
struct thread *th;
os_thread_t kid_tid=0;
boolean success;
if(linux_no_threads_p) return 0;
th=create_thread_struct(initial_function);
if(th==0) return 0;
/* we must not be interrupted here after a successful
* create_os_thread, because the kid will be waiting for its
* thread struct to be linked */
GET_ALL_THREADS_LOCK("create_thread")
success=create_os_thread(th,&kid_tid);
if (success)
link_thread(th,kid_tid);
/* it's started and initialized, it's safe to gc */
release_spinlock(&thread_start_lock);
#ifdef QSHOW_SIGNALS
SHOW("create_thread:released lock");
#endif
/* by now the kid might have already exited */
return kid_tid;
} else {
release_spinlock(&thread_start_lock);
#ifdef QSHOW_SIGNALS
SHOW("create_thread:released lock(failure)");
#endif
else
os_invalidate((os_vm_address_t) th->control_stack_start,
((sizeof (lispobj))
* (th->control_stack_end-th->control_stack_start)) +
BINDING_STACK_SIZE+ALIEN_STACK_SIZE+dynamic_values_bytes+
32*SIGSTKSZ);
return 0;
}
RELEASE_ALL_THREADS_LOCK("create_thread")
if (success)
return th;
else
return 0;
}
#endif
struct thread *find_thread_by_os_thread(os_thread_t tid)
{
struct thread *th;
for_each_thread(th)
if(th->os_thread==tid) return th;
return 0;
}
#if defined LISP_FEATURE_SB_THREAD
/* This is not needed unless #+SB-THREAD, as there's a trivial null
* unithread definition. */
void reap_dead_threads()
/* called from lisp from the thread object finalizer */
void reap_dead_thread(struct thread *th)
{
struct thread *th,*next,*prev=0;
th=all_threads;
while(th) {
next=th->next;
if(th->state==STATE_DEAD) {
if(th->state!=STATE_DEAD)
lose("thread %lx is not joinable, state=%d\n",th,th->state);
#ifdef LISP_FEATURE_GENCGC
gc_alloc_update_page_tables(0, &th->alloc_region);
#endif
get_spinlock(&all_threads_lock,th->os_thread);
if(prev) prev->next=next;
else all_threads=next;
release_spinlock(&all_threads_lock);
if(th->tls_cookie>=0) arch_os_thread_cleanup(th);
os_invalidate((os_vm_address_t) th->control_stack_start,
((sizeof (lispobj))
* (th->control_stack_end-th->control_stack_start)) +
BINDING_STACK_SIZE+ALIEN_STACK_SIZE+dynamic_values_bytes+
32*SIGSTKSZ);
} else
prev=th;
th=next;
{
sigset_t newset,oldset;
sigemptyset(&newset);
sigaddset_blockable(&newset);
thread_sigmask(SIG_BLOCK, &newset, &oldset);
gc_alloc_update_page_tables(0, &th->alloc_region);
release_spinlock(&all_threads_lock);
thread_sigmask(SIG_SETMASK,&oldset,0);
}
#endif
GET_ALL_THREADS_LOCK("reap_dead_thread")
FSHOW((stderr,"/reap_dead_thread: reaping %ld\n",th->os_thread));
if(th->prev)
th->prev->next=th->next;
else all_threads=th->next;
if(th->next)
th->next->prev=th->prev;
RELEASE_ALL_THREADS_LOCK("reap_dead_thread")
if(th->tls_cookie>=0) arch_os_thread_cleanup(th);
gc_assert(pthread_join(th->os_thread,NULL)==0);
os_invalidate((os_vm_address_t) th->control_stack_start,
((sizeof (lispobj))
* (th->control_stack_end-th->control_stack_start)) +
BINDING_STACK_SIZE+ALIEN_STACK_SIZE+dynamic_values_bytes+
32*SIGSTKSZ);
}
int interrupt_thread(os_thread_t tid, lispobj function)
int interrupt_thread(struct thread *th, lispobj function)
{
struct thread *th;
for_each_thread(th)
if((th->os_thread==tid) && (th->state != STATE_DEAD)) {
/* In clone_threads, if A and B both interrupt C at approximately
* the same time, it does not matter: the second signal will be
* masked until the handler has returned from the first one.
* In pthreads though, we can't put the knowledge of what function
* to call into the siginfo, so we have to store it in the
* destination thread, and do it in such a way that A won't
* clobber B's interrupt. Hence this stupid linked list.
*
* This does depend on SIG_INTERRUPT_THREAD being queued
* (as POSIX RT signals are): we need to keep
* interrupt_fun data for exactly as many signals as are
* going to be received by the destination thread.
*/
struct cons *c;
int kill_status;
/* mask the signals in case this thread is being interrupted */
sigset_t newset,oldset;
sigemptyset(&newset);
sigaddset_blockable(&newset);
thread_sigmask(SIG_BLOCK, &newset, &oldset);
get_spinlock(&th->interrupt_fun_lock,
(int)arch_os_get_current_thread());
kill_status=thread_kill(th->os_thread,SIG_INTERRUPT_THREAD);
if(kill_status==0) {
c=alloc_cons(function,th->interrupt_fun);
th->interrupt_fun=c;
}
release_spinlock(&th->interrupt_fun_lock);
thread_sigmask(SIG_SETMASK,&oldset,0);
return (kill_status ? -1 : 0);
}
/* A thread may also become dead after this test. */
if ((th->state != STATE_DEAD)) {
/* In clone_threads, if A and B both interrupt C at
* approximately the same time, it does not matter: the
* second signal will be masked until the handler has
* returned from the first one. In pthreads though, we
* can't put the knowledge of what function to call into
* the siginfo, so we have to store it in the destination
* thread, and do it in such a way that A won't clobber
* B's interrupt. Hence this stupid linked list.
*
* This does depend on SIG_INTERRUPT_THREAD being queued
* (as POSIX RT signals are): we need to keep
* interrupt_fun data for exactly as many signals as are
* going to be received by the destination thread.
*/
struct cons *c=alloc_cons(function,NIL);
int kill_status;
/* interrupt_thread_handler locks this spinlock with
* interrupts blocked and it does so for the sake of
* arrange_return_to_lisp_function, so we must also block
* them. */
sigset_t newset,oldset;
sigemptyset(&newset);
sigaddset_blockable(&newset);
thread_sigmask(SIG_BLOCK, &newset, &oldset);
get_spinlock(&th->interrupt_fun_lock,
(long)arch_os_get_current_thread());
kill_status=thread_kill(th->os_thread,SIG_INTERRUPT_THREAD);
if(kill_status==0) {
((struct cons *)native_pointer(c))->cdr=th->interrupt_fun;
th->interrupt_fun=c;
}
release_spinlock(&th->interrupt_fun_lock);
thread_sigmask(SIG_SETMASK,&oldset,0);
return (kill_status ? -1 : 0);
}
errno=EPERM; return -1;
}
/* stopping the world is a two-stage process. From this thread we signal
/* stopping the world is a two-stage process. From this thread we signal
* all the others with SIG_STOP_FOR_GC. The handler for this signal does
* the usual pseudo-atomic checks (we don't want to stop a thread while
* the usual pseudo-atomic checks (we don't want to stop a thread while
* it's in the middle of allocation) then waits for another SIG_STOP_FOR_GC.
*/
/* To avoid deadlocks when gc stops the world all clients of each
* mutex must enable or disable SIG_STOP_FOR_GC for the duration of
* holding the lock, but they must agree on which. */
void gc_stop_the_world()
{
struct thread *p,*th=arch_os_get_current_thread();
#ifdef QSHOW_SIGNALS
SHOW("gc_stop_the_world:begin");
#endif
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on lock, thread=%ld\n",
th->os_thread));
/* keep threads from starting while the world is stopped. */
get_spinlock(&thread_start_lock,th->os_thread);
#ifdef QSHOW_SIGNALS
SHOW("gc_stop_the_world:locked");
#endif
get_spinlock(&all_threads_lock,(long)th);
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:got lock, thread=%ld\n",
th->os_thread));
/* stop all other threads by sending them SIG_STOP_FOR_GC */
for(p=all_threads; p; p=p->next) {
while(p->state==STATE_STARTING) sched_yield();
if((p!=th) && (p->os_thread!=0) && (p->state==STATE_RUNNING)) {
p->state=STATE_STOPPING;
if((p!=th) && (p->state==STATE_RUNNING)) {
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:sending sig_stop to %ld\n",
p->os_thread));
if(thread_kill(p->os_thread,SIG_STOP_FOR_GC)==-1) {
/* FIXME: we can't kill the thread; assume because it died
* already */
/* we can't kill the thread; assume because it died
* since we last checked */
p->state=STATE_DEAD;
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:assuming %ld dead\n",
p->os_thread));
}
}
}
#ifdef QSHOW_SIGNALS
SHOW("gc_stop_the_world:signals sent");
#endif
/* wait for the running threads to stop */
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:signals sent\n"));
/* wait for the running threads to stop or finish */
for(p=all_threads;p;) {
if((p==th) || (p->os_thread==0) || (p->state==STATE_STARTING) ||
(p->state==STATE_DEAD) || (p->state==STATE_STOPPED)) {
gc_assert(p->os_thread!=0);
gc_assert(p->state!=STATE_STARTING);
if((p==th) || (p->state==STATE_SUSPENDED) ||
(p->state==STATE_DEAD)) {
p=p->next;
}
}
#ifdef QSHOW_SIGNALS
SHOW("gc_stop_the_world:end");
#endif
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:end\n"));
}
void gc_start_the_world()
@ -429,15 +456,12 @@ void gc_start_the_world()
/* if a resumed thread creates a new thread before we're done with
* this loop, the new thread will get consed on the front of
* all_threads, but it won't have been stopped so won't need
* restarting; there can be threads just starting from before
* gc_stop_the_world, though */
#ifdef QSHOW_SIGNALS
SHOW("gc_start_the_world:begin");
#endif
* restarting */
FSHOW_SIGNAL((stderr,"/gc_start_the_world:begin\n"));
for(p=all_threads;p;p=p->next) {
if((p!=th) && (p->os_thread!=0) && (p->state!=STATE_STARTING) &&
(p->state!=STATE_DEAD)) {
if(p->state!=STATE_STOPPED) {
gc_assert(p->os_thread!=0);
if((p!=th) && (p->state!=STATE_DEAD)) {
if(p->state!=STATE_SUSPENDED) {
lose("gc_start_the_world: wrong thread state is %ld\n",
fixnum_value(p->state));
}
@ -448,14 +472,11 @@ void gc_start_the_world()
* risk signal accumulation and lose any meaning of
* thread->state */
for(p=all_threads;p;) {
gc_assert(p->state!=STATE_STOPPING);
if((p==th) || (p->os_thread==0) || (p->state!=STATE_STOPPED)) {
if((p==th) || (p->state!=STATE_SUSPENDED)) {
p=p->next;
}
}
release_spinlock(&thread_start_lock);
#ifdef QSHOW_SIGNALS
SHOW("gc_start_the_world:end");
#endif
release_spinlock(&all_threads_lock);
FSHOW_SIGNAL((stderr,"/gc_start_the_world:end\n"));
}
#endif

10
src/runtime/thread.h
View file

@ -1,4 +1,3 @@
#if !defined(_INCLUDE_THREAD_H_)
#define _INCLUDE_THREAD_H_
@ -6,6 +5,7 @@
#include <unistd.h>
#include <stddef.h>
#include "sbcl.h"
#include "globals.h"
#include "runtime.h"
#include "os.h"
#include "interrupt.h"
@ -18,11 +18,10 @@ struct alloc_region { };
#include "genesis/static-symbols.h"
#include "genesis/thread.h"
#define STATE_RUNNING (make_fixnum(0))
#define STATE_STOPPING (make_fixnum(1))
#define STATE_STOPPED (make_fixnum(2))
#define STATE_STARTING (make_fixnum(0))
#define STATE_RUNNING (make_fixnum(1))
#define STATE_SUSPENDED (make_fixnum(2))
#define STATE_DEAD (make_fixnum(3))
#define STATE_STARTING (make_fixnum(4))
#define THREAD_SLOT_OFFSET_WORDS(c) \
(offsetof(struct thread,c)/(sizeof (struct thread *)))
@ -34,7 +33,6 @@ union per_thread_data {
extern struct thread *all_threads;
extern int dynamic_values_bytes;
extern struct thread *find_thread_by_os_thread(os_thread_t tid);
#ifdef LISP_FEATURE_SB_THREAD
#define for_each_thread(th) for(th=all_threads;th;th=th->next)

6
src/runtime/validate.c
View file

@ -80,16 +80,14 @@ validate(void)
}
void
protect_control_stack_guard_page(os_thread_t t_id, int protect_p) {
struct thread *th = find_thread_by_os_thread(t_id);
protect_control_stack_guard_page(struct thread *th, int protect_p) {
os_protect(CONTROL_STACK_GUARD_PAGE(th),
os_vm_page_size,protect_p ?
(OS_VM_PROT_READ|OS_VM_PROT_EXECUTE) : OS_VM_PROT_ALL);
}
void
protect_control_stack_return_guard_page(os_thread_t t_id, int protect_p) {
struct thread *th = find_thread_by_os_thread(t_id);
protect_control_stack_return_guard_page(struct thread *th, int protect_p) {
os_protect(CONTROL_STACK_RETURN_GUARD_PAGE(th),
os_vm_page_size,protect_p ?
(OS_VM_PROT_READ|OS_VM_PROT_EXECUTE) : OS_VM_PROT_ALL);

4
src/runtime/validate.h
View file

@ -42,8 +42,8 @@
#endif
extern void validate(void);
extern void protect_control_stack_guard_page(os_thread_t t_id, int protect_p);
extern void protect_control_stack_return_guard_page(os_thread_t t_id,
extern void protect_control_stack_guard_page(struct thread *th, int protect_p);
extern void protect_control_stack_return_guard_page(struct thread *th,
int protect_p);
extern os_vm_address_t undefined_alien_address;
#endif

28
src/runtime/x86-arch.h
View file

@ -4,9 +4,6 @@
* namespace that we control. */
#ifndef _X86_ARCH_H
#define _X86_ARCH_H
#ifndef SBCL_GENESIS_CONFIG
#error genesis/config.h (or sbcl.h) must be included before this file
#endif
#ifndef SBCL_GENESIS_CONFIG
#error genesis/config.h (or sbcl.h) must be included before this file
@ -17,19 +14,17 @@
/* FIXME: Do we also want
* #define ARCH_HAS_FLOAT_REGISTERS
* here? (The answer wasn't obvious to me when merging the
* architecture-abstracting patches for CSR's SPARC port. -- WHN
* 2002-02-15) */
#ifdef LISP_FEATURE_SB_THREAD
* architecture-abstracting patches for CSR's SPARC port. -- WHN 2002-02-15) */
extern never_returns lose(char *fmt, ...);
static inline void
get_spinlock(volatile lispobj *word,long value)
{
#ifdef LISP_FEATURE_SB_THREAD
u32 eax=0;
if(*word==value)
lose("recursive get_spinlock: 0x%x,%d\n",word,value);
lose("recursive get_spinlock: 0x%x,%ld\n",word,value);
do {
asm ("xor %0,%0\n\
lock cmpxchg %1,%2"
@ -37,6 +32,9 @@ get_spinlock(volatile lispobj *word,long value)
: "r" (value), "m" (*word)
: "memory", "cc");
} while(eax!=0);
#else
*word=value;
#endif
}
static inline void
@ -45,18 +43,4 @@ release_spinlock(volatile lispobj *word)
*word=0;
}
#else
static inline void
get_spinlock(lispobj *word, int value)
{
*word = value;
}
static inline void
release_spinlock(lispobj *word) {
*word = 0;
}
#endif /* LISP_FEATURE_SB_THREAD */
#endif /* _X86_ARCH_H */

5
src/runtime/x86-linux-os.c
View file

@ -78,8 +78,7 @@ int arch_os_thread_init(struct thread *thread) {
1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1
};
int n;
/* thread->os_thread is not set yet*/
get_spinlock(&modify_ldt_lock,(int)thread);
get_spinlock(&modify_ldt_lock,(long)thread);
n=modify_ldt(0,local_ldt_copy,sizeof local_ldt_copy);
/* get next free ldt entry */
@ -139,7 +138,7 @@ int arch_os_thread_cleanup(struct thread *thread) {
};
ldt_entry.entry_number=thread->tls_cookie;
get_spinlock(&modify_ldt_lock,thread);
get_spinlock(&modify_ldt_lock,(long)thread);
if (modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) {
modify_ldt_lock=0;
/* modify_ldt call failed: something magical is not happening */

93
tests/threads.impure.lisp
View file

@ -15,6 +15,17 @@
(in-package "SB-THREAD") ; this is white-box testing, really
(let ((old-threads (list-all-threads))
(thread (make-thread (lambda ()
(assert (find *current-thread* *all-threads*))
(sleep 2))))
(new-threads (list-all-threads)))
(assert (thread-alive-p thread))
(assert (eq thread (first new-threads)))
(assert (= (1+ (length old-threads)) (length new-threads)))
(sleep 3)
(assert (not (thread-alive-p thread))))
;;; We had appalling scaling properties for a while. Make sure they
;;; don't reappear.
(defun scaling-test (function &optional (nthreads 5))
@ -55,7 +66,7 @@
;;; elementary "can we get a lock and release it again"
(let ((l (make-mutex :name "foo"))
(p (current-thread-id)))
(p *current-thread*))
(assert (eql (mutex-value l) nil) nil "1")
(assert (eql (mutex-lock l) 0) nil "2")
(sb-thread:get-mutex l)
@ -67,7 +78,7 @@
(describe l))
(let ((l (make-waitqueue :name "spinlock"))
(p (current-thread-id)))
(p *current-thread*))
(assert (eql (waitqueue-lock l) 0) nil "1")
(with-spinlock (l)
(assert (eql (waitqueue-lock l) p) nil "2"))
@ -77,7 +88,7 @@
;; test that SLEEP actually sleeps for at least the given time, even
;; if interrupted by another thread exiting/a gc/anything
(let ((start-time (get-universal-time)))
(make-thread (lambda () (sleep 1))) ; kid waits 1 then dies ->SIG_THREAD_EXIT
(make-thread (lambda () (sleep 1) (sb-ext:gc :full t)))
(sleep 5)
(assert (>= (get-universal-time) (+ 5 start-time))))
@ -86,16 +97,16 @@
(lock (make-mutex :name "lock")))
(labels ((in-new-thread ()
(with-mutex (lock)
(assert (eql (mutex-value lock) (current-thread-id)))
(format t "~A got mutex~%" (current-thread-id))
(assert (eql (mutex-value lock) *current-thread*))
(format t "~A got mutex~%" *current-thread*)
;; now drop it and sleep
(condition-wait queue lock)
;; after waking we should have the lock again
(assert (eql (mutex-value lock) (current-thread-id))))))
(assert (eql (mutex-value lock) *current-thread*)))))
(make-thread #'in-new-thread)
(sleep 2) ; give it a chance to start
;; check the lock is free while it's asleep
(format t "parent thread ~A~%" (current-thread-id))
(format t "parent thread ~A~%" *current-thread*)
(assert (eql (mutex-value lock) nil))
(assert (eql (mutex-lock lock) 0))
(with-mutex (lock)
@ -119,7 +130,7 @@
(make-thread #'in-new-thread)
(sleep 2) ; give it a chance to start
;; check the lock is free while it's asleep
(format t "parent thread ~A~%" (current-thread-id))
(format t "parent thread ~A~%" *current-thread*)
(assert (eql (mutex-value lock) nil))
(assert (eql (mutex-lock lock) 0))
(with-recursive-lock (lock)
@ -128,13 +139,13 @@
(let ((mutex (make-mutex :name "contended")))
(labels ((run ()
(let ((me (current-thread-id)))
(let ((me *current-thread*))
(dotimes (i 100)
(with-mutex (mutex)
(sleep .1)
(assert (eql (mutex-value mutex) me)))
(assert (not (eql (mutex-value mutex) me))))
(format t "done ~A~%" (current-thread-id)))))
(format t "done ~A~%" *current-thread*))))
(let ((kid1 (make-thread #'run))
(kid2 (make-thread #'run)))
(format t "contention ~A ~A~%" kid1 kid2))))
@ -146,14 +157,14 @@
(format t "interrupting child ~A~%" child)
(interrupt-thread child
(lambda ()
(format t "child pid ~A~%" (current-thread-id))
(format t "child pid ~A~%" *current-thread*)
(when quit-p (sb-ext:quit))))
(sleep 1)
child))
;;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
;;; (d) waiting on a lock, (e) some code which we hope is likely to be
;;; in pseudo-atomic
;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
;; (d) waiting on a lock, (e) some code which we hope is likely to be
;; in pseudo-atomic
(let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child))
@ -168,18 +179,39 @@
(setf child (test-interrupt
(lambda ()
(with-mutex (lock)
(assert (eql (mutex-value lock) (current-thread-id))))
(assert (not (eql (mutex-value lock) (current-thread-id))))
(sleep 60))))
(assert (eql (mutex-value lock) *current-thread*)))
(assert (not (eql (mutex-value lock) *current-thread*)))
(sleep 10))))
;;hold onto lock for long enough that child can't get it immediately
(sleep 20)
(sleep 5)
(interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock))))
(format t "parent releasing lock~%"))
(terminate-thread child))
(format t "~&locking test done~%")
(defun alloc-stuff () (copy-list '(1 2 3 4 5)))
(let ((c (test-interrupt (lambda () (loop (alloc-stuff))))))
(progn
(let ((thread (sb-thread:make-thread (lambda () (loop (alloc-stuff))))))
(let ((killers
(loop repeat 4 collect
(sb-thread:make-thread
(lambda ()
(loop repeat 25 do
(sleep (random 2d0))
(princ ".")
(force-output)
(sb-thread:interrupt-thread
thread
(lambda ()))))))))
(loop while (some #'thread-alive-p killers) do (sleep 0.1))
(sb-thread:terminate-thread thread)))
(sb-ext:gc :full t))
(format t "~&multi interrupt test done~%")
(let ((c (make-thread (lambda () (loop (alloc-stuff))))))
;; NB this only works on x86: other ports don't have a symbol for
;; pseudo-atomic atomicity
(format t "new thread ~A~%" c)
@ -188,9 +220,11 @@
(interrupt-thread c
(lambda ()
(princ ".") (force-output)
(assert (eq (thread-state *current-thread*) :running))
(assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*)))))
(terminate-thread c))
(terpri)
(format t "~&interrupt test done~%")
(defparameter *interrupt-count* 0)
@ -212,21 +246,20 @@
(princ ".")
(force-output)
(sb-impl::atomic-incf/symbol *interrupt-count*))))
(sb-sys:with-pinned-objects (func)
(setq *interrupt-count* 0)
(dotimes (i 100)
(sleep (random 1d0))
(interrupt-thread c func))
(sleep 1)
(assert (= 100 *interrupt-count*))
(terminate-thread c))))
(setq *interrupt-count* 0)
(dotimes (i 100)
(sleep (random 1d0))
(interrupt-thread c func))
(sleep 1)
(assert (= 100 *interrupt-count*))
(terminate-thread c)))
(format t "~&interrupt test done~%")
(format t "~&interrupt count test done~%")
(let (a-done b-done)
(make-thread (lambda ()
(dotimes (i 100)
(sb-ext:gc) (princ "\\") (force-output) )
(sb-ext:gc) (princ "\\") (force-output))
(setf a-done t)))
(make-thread (lambda ()
(dotimes (i 25)

2
version.lisp-expr
View file

@ -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".)
"0.9.2.8"
"0.9.2.9"