* 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
;; 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.
("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
(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*))))
(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)
(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))
("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")
(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)
(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
: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"
(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)
(terpri)
(/show0 "going into toplevel loop")
(handling-end-of-the-world
- (thread-init-or-reinit)
(toplevel-init)
(critically-unreachable "after TOPLEVEL-INIT")))
;;;; initialization functions
(defun thread-init-or-reinit ()
+ (sb!thread::init-initial-thread)
(sb!thread::init-job-control)
(sb!thread::get-foreground))
(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)
;; 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)
"~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)
(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
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*
--- /dev/null
+;;;; 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*)
(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)))
(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.
;; 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.
"Disable the garbage collector."
(setq *gc-inhibit* 1)
nil)
-
--- /dev/null
+;;;; 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))))
;;; 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)
\f
;;;; C routines that actually do all the work of establishing signal handlers
(sb!alien:define-alien-routine ("install_handler" install-handler)
(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
-;;;; 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.
(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
-
-(define-alien-routine ("create_thread" %create-thread)
- unsigned-long
- (lisp-fun-address unsigned-long))
-
-(define-alien-routine reap-dead-threads void)
-
-(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)
- (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 ()
+(defstruct (thread (:constructor %make-thread))
+ name
+ %sap)
+
+(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)
+
+(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))))
+
+(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))))))
+
+(defun thread-alive-p (thread)
+ (not (eq :dead (thread-state thread))))
+
+;; 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 list-all-threads ()
+ (with-mutex (*all-threads-lock*)
+ (copy-list *all-threads*)))
+
+(declaim (inline current-thread-sap))
+(defun current-thread-sap ()
+ (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot))
+
+(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))))
;;; 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)
(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))
(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)
(release-mutex ,mutex)))))
#!-sb-thread
`(locally ,@body))
-
(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))
(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)
sb!kernel::memory-fault-error
sb!di::handle-breakpoint
fdefinition-object
- #!+sb-thread sb!thread::handle-thread-exit
;; free pointers
;;
sb!kernel::memory-fault-error
sb!di::handle-breakpoint
fdefinition-object
- #!+sb-thread sb!thread::handle-thread-exit
;; free pointers
;;
#+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)
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. */
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);
thread_sigmask(SIG_SETMASK,&new,0);
}
-
+void block_blockable_signals ()
+{
+ sigset_t block;
+ sigemptyset(&block);
+ sigaddset_blockable(&block);
+ thread_sigmask(SIG_BLOCK, &block, 0);
+}
\f
/*
{
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;
* 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;
* 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);
* 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));
* 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 &&
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, ¤t);
+ if (sigismember(¤t,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)
{
}
#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
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) {
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+
#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);
#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 */
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));
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;
* 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) {
}
#ifdef LISP_FEATURE_SB_THREAD
-os_thread_t create_thread(lispobj initial_function) {
+
+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. */
+ 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;
- pthread_attr_t attr;
+ boolean success;
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
- /* 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) {
+
+ /* 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;
- }
-}
-#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;
+ RELEASE_ALL_THREADS_LOCK("create_thread")
+
+ if (success)
+ return th;
+ else
+ return 0;
}
+#endif
#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()
/* 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));
}
* 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
-
#if !defined(_INCLUDE_THREAD_H_)
#define _INCLUDE_THREAD_H_
#include <unistd.h>
#include <stddef.h>
#include "sbcl.h"
+#include "globals.h"
#include "runtime.h"
#include "os.h"
#include "interrupt.h"
#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 *)))
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)
}
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);
#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
* 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
/* 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"
: "r" (value), "m" (*word)
: "memory", "cc");
} while(eax!=0);
+#else
+ *word=value;
+#endif
}
static inline void
*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 */
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 */
};
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 */
(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))
;;; 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)
(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"))
;; 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))))
(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)
(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)
(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))))
(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))
(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)
(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)
(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)
;;; 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"
projects / sbcl.git / commitdiff