1.0.5.9: experimental semi-synchronous deadlines
[sbcl.git] / src / code / target-thread.lisp
1 ;;;; support for threads in the target machine
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!THREAD")
13
14 ;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is
15 ;;; necessary because threads are only supported with the conservative
16 ;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS)
17 ;;; are treated as references.
18
19 ;;; set the doc here because in early-thread FDOCUMENTATION is not
20 ;;; available, yet
21 #!+sb-doc
22 (setf (fdocumentation '*current-thread* 'variable)
23       "Bound in each thread to the thread itself.")
24
25 (defstruct (thread (:constructor %make-thread))
26   #!+sb-doc
27   "Thread type. Do not rely on threads being structs as it may change
28 in future versions."
29   name
30   %alive-p
31   os-thread
32   interruptions
33   (interruptions-lock (make-mutex :name "thread interruptions lock"))
34   result
35   (result-lock (make-mutex :name "thread result lock")))
36
37 #!+sb-doc
38 (setf (fdocumentation 'thread-name 'function)
39       "The name of the thread. Setfable.")
40
41 (def!method print-object ((thread thread) stream)
42   (if (thread-name thread)
43       (print-unreadable-object (thread stream :type t :identity t)
44         (prin1 (thread-name thread) stream))
45       (print-unreadable-object (thread stream :type t :identity t)
46         ;; body is empty => there is only one space between type and
47         ;; identity
48         ))
49   thread)
50
51 (defun thread-alive-p (thread)
52   #!+sb-doc
53   "Check if THREAD is running."
54   (thread-%alive-p thread))
55
56 ;; A thread is eligible for gc iff it has finished and there are no
57 ;; more references to it. This list is supposed to keep a reference to
58 ;; all running threads.
59 (defvar *all-threads* ())
60 (defvar *all-threads-lock* (make-mutex :name "all threads lock"))
61
62 (defmacro with-all-threads-lock (&body body)
63   #!-sb-thread
64   `(locally ,@body)
65   #!+sb-thread
66   `(without-interrupts
67      (with-mutex (*all-threads-lock*)
68        ,@body)))
69
70 (defun list-all-threads ()
71   #!+sb-doc
72   "Return a list of the live threads."
73   (with-all-threads-lock
74     (copy-list *all-threads*)))
75
76 (declaim (inline current-thread-sap))
77 (defun current-thread-sap ()
78   (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot))
79
80 (declaim (inline current-thread-sap-id))
81 (defun current-thread-sap-id ()
82   (sap-int
83    (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
84
85 (defun init-initial-thread ()
86   (/show0 "Entering INIT-INITIAL-THREAD")
87   (let ((initial-thread (%make-thread :name "initial thread"
88                                       :%alive-p t
89                                       :os-thread (current-thread-sap-id))))
90     (setq *current-thread* initial-thread)
91     ;; Either *all-threads* is empty or it contains exactly one thread
92     ;; in case we are in reinit since saving core with multiple
93     ;; threads doesn't work.
94     (setq *all-threads* (list initial-thread))))
95
96 ;;;;
97
98 #!+sb-thread
99 (progn
100   ;; FIXME it would be good to define what a thread id is or isn't
101   ;; (our current assumption is that it's a fixnum).  It so happens
102   ;; that on Linux it's a pid, but it might not be on posix thread
103   ;; implementations.
104   (define-alien-routine ("create_thread" %create-thread)
105       unsigned-long (lisp-fun-address unsigned-long))
106
107   (define-alien-routine "signal_interrupt_thread"
108       integer (os-thread unsigned-long))
109
110   (define-alien-routine "block_deferrable_signals"
111       void)
112
113   #!+sb-lutex
114   (progn
115     (declaim (inline %lutex-init %lutex-wait %lutex-wake
116                      %lutex-lock %lutex-unlock))
117
118     (sb!alien:define-alien-routine ("lutex_init" %lutex-init)
119         int (lutex unsigned-long))
120
121     (sb!alien:define-alien-routine ("lutex_wait" %lutex-wait)
122         int (queue-lutex unsigned-long) (mutex-lutex unsigned-long))
123
124     (sb!alien:define-alien-routine ("lutex_wake" %lutex-wake)
125         int (lutex unsigned-long) (n int))
126
127     (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock)
128         int (lutex unsigned-long))
129
130     (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock)
131         int (lutex unsigned-long))
132
133     (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock)
134         int (lutex unsigned-long))
135
136     (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy)
137         int (lutex unsigned-long))
138
139     ;; FIXME: Defining a whole bunch of alien-type machinery just for
140     ;; passing primitive lutex objects directly to foreign functions
141     ;; doesn't seem like fun right now. So instead we just manually
142     ;; pin the lutex, get its address, and let the callee untag it.
143     (defmacro with-lutex-address ((name lutex) &body body)
144       `(let ((,name ,lutex))
145          (with-pinned-objects (,name)
146            (let ((,name (get-lisp-obj-address ,name)))
147              ,@body))))
148
149     (defun make-lutex ()
150       (/show0 "Entering MAKE-LUTEX")
151       ;; Suppress GC until the lutex has been properly registered with
152       ;; the GC.
153       (without-gcing
154         (let ((lutex (sb!vm::%make-lutex)))
155           (/show0 "LUTEX=..")
156           (/hexstr lutex)
157           (with-lutex-address (lutex lutex)
158             (%lutex-init lutex))
159           lutex))))
160
161   #!-sb-lutex
162   (progn
163     (declaim (inline futex-wait futex-wake))
164
165     (sb!alien:define-alien-routine "futex_wait"
166         int (word unsigned-long) (old-value unsigned-long)
167         (to-sec long) (to-usec unsigned-long))
168
169     (sb!alien:define-alien-routine "futex_wake"
170         int (word unsigned-long) (n unsigned-long))))
171
172 ;;; used by debug-int.lisp to access interrupt contexts
173 #!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
174 #!-sb-thread
175 (defun sb!vm::current-thread-offset-sap (n)
176   (declare (type (unsigned-byte 27) n))
177   (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
178                (* n sb!vm:n-word-bytes)))
179
180 #!+sb-thread
181 (defun sb!vm::current-thread-offset-sap (n)
182   (declare (type (unsigned-byte 27) n))
183   (sb!vm::current-thread-offset-sap n))
184
185 ;;;; spinlocks
186 #!+sb-thread
187 (define-structure-slot-compare-and-swap
188     compare-and-swap-spinlock-value
189     :structure spinlock
190     :slot value)
191
192 (declaim (inline get-spinlock release-spinlock))
193
194 (defun get-spinlock (spinlock)
195   (declare (optimize (speed 3) (safety 0))
196            #!-sb-thread
197            (ignore spinlock))
198   ;; %instance-set-conditional can test for 0 (which is a fixnum) and
199   ;; store any value
200   #!+sb-thread
201   (loop until
202        (eql 0 (compare-and-swap-spinlock-value spinlock 0 1)))
203   t)
204
205 (defun release-spinlock (spinlock)
206   (declare (optimize (speed 3) (safety 0))
207            #!-sb-thread (ignore spinlock))
208   ;; %instance-set-conditional cannot compare arbitrary objects
209   ;; meaningfully, so (compare-and-swap-spinlock-value our-value 0)
210   ;; does not work for bignum thread ids.
211   #!+sb-thread
212   (setf (spinlock-value spinlock) 0)
213   nil)
214
215 ;;;; mutexes
216
217 #!+sb-doc
218 (setf (fdocumentation 'make-mutex 'function)
219       "Create a mutex."
220       (fdocumentation 'mutex-name 'function)
221       "The name of the mutex. Setfable."
222       (fdocumentation 'mutex-value 'function)
223       "The value of the mutex. NIL if the mutex is free. Setfable.")
224
225 #!+(and sb-thread (not sb-lutex))
226 (progn
227   (define-structure-slot-addressor mutex-value-address
228       :structure mutex
229       :slot value)
230   (define-structure-slot-compare-and-swap
231       compare-and-swap-mutex-value
232       :structure mutex
233       :slot value))
234
235 (defun get-mutex (mutex &optional (new-value *current-thread*) (waitp t))
236   #!+sb-doc
237   "Acquire MUTEX, setting it to NEW-VALUE or some suitable default
238 value if NIL. If WAITP is non-NIL and the mutex is in use, sleep
239 until it is available."
240   (declare (type mutex mutex) (optimize (speed 3)))
241   (/show0 "Entering GET-MUTEX")
242   (unless new-value
243     (setq new-value *current-thread*))
244   #!-sb-thread
245   (let ((old (mutex-value mutex)))
246     (when (and old waitp)
247       (error "In unithread mode, mutex ~S was requested with WAITP ~S and ~
248               new-value ~S, but has already been acquired (with value ~S)."
249              mutex waitp new-value old))
250     (setf (mutex-value mutex) new-value)
251     t)
252   #!+sb-thread
253   (when (eql new-value (mutex-value mutex))
254     (warn "recursive lock attempt ~S~%" mutex)
255     (format *debug-io* "Thread: ~A~%" *current-thread*)
256     (sb!debug:backtrace most-positive-fixnum *debug-io*)
257     (force-output *debug-io*))
258   ;; FIXME: Lutexes do not currently support deadlines, as at least
259   ;; on Darwin pthread_foo_timedbar functions are not supported:
260   ;; this means that we probably need to use the Carbon multiprocessing
261   ;; functions on Darwin.
262   #!+sb-lutex
263   (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
264                  (if waitp
265                      (%lutex-lock lutex)
266                      (%lutex-trylock lutex))))
267     (setf (mutex-value mutex) new-value))
268   #!-sb-lutex
269   (let (old)
270     (when (and (setf old (compare-and-exchange-mutex-value mutex nil new-value))
271                waitp)
272       (loop while old
273             do (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
274                  (when (= 1 (with-pinned-objects (mutex old)
275                               (futex-wait (mutex-value-address mutex)
276                                           (get-lisp-obj-address old)
277                                           (or to-sec -1)
278                                           (or to-usec 0))))
279                    (signal-deadline)))
280             (setf old (compare-and-exchange-mutex-value mutex nil new-value))))
281     (not old)))
282
283 (defun release-mutex (mutex)
284   #!+sb-doc
285   "Release MUTEX by setting it to NIL. Wake up threads waiting for
286 this mutex."
287   (declare (type mutex mutex))
288   (/show0 "Entering RELEASE-MUTEX")
289   (setf (mutex-value mutex) nil)
290   #!+sb-thread
291   (progn
292     #!+sb-lutex
293     (with-lutex-address (lutex (mutex-lutex mutex))
294       (%lutex-unlock lutex))
295     #!-sb-lutex
296     (futex-wake (mutex-value-address mutex) 1)))
297
298 ;;;; waitqueues/condition variables
299
300 (defstruct (waitqueue (:constructor %make-waitqueue))
301   #!+sb-doc
302   "Waitqueue type."
303   (name nil :type (or null simple-string))
304   #!+(and sb-lutex sb-thread)
305   (lutex (make-lutex))
306   #!-sb-lutex
307   (data nil))
308
309 (defun make-waitqueue (&key name)
310   #!+sb-doc
311   "Create a waitqueue."
312   (%make-waitqueue :name name))
313
314 #!+sb-doc
315 (setf (fdocumentation 'waitqueue-name 'function)
316       "The name of the waitqueue. Setfable.")
317
318 #!+(and sb-thread (not sb-lutex))
319 (define-structure-slot-addressor waitqueue-data-address
320     :structure waitqueue
321     :slot data)
322
323 (defun condition-wait (queue mutex)
324   #!+sb-doc
325   "Atomically release MUTEX and enqueue ourselves on QUEUE.  Another
326 thread may subsequently notify us using CONDITION-NOTIFY, at which
327 time we reacquire MUTEX and return to the caller."
328   #!-sb-thread (declare (ignore queue))
329   (assert mutex)
330   #!-sb-thread (error "Not supported in unithread builds.")
331   #!+sb-thread
332   (let ((value (mutex-value mutex)))
333     (/show0 "CONDITION-WAITing")
334     #!+sb-lutex
335     (progn
336       (setf (mutex-value mutex) nil)
337       (with-lutex-address (queue-lutex-address (waitqueue-lutex queue))
338         (with-lutex-address (mutex-lutex-address (mutex-lutex mutex))
339           (%lutex-wait queue-lutex-address mutex-lutex-address)))
340       (setf (mutex-value mutex) value))
341     #!-sb-lutex
342     (unwind-protect
343          (let ((me *current-thread*))
344            ;; XXX we should do something to ensure that the result of this setf
345            ;; is visible to all CPUs
346            (setf (waitqueue-data queue) me)
347            (release-mutex mutex)
348            ;; Now we go to sleep using futex-wait.  If anyone else
349            ;; manages to grab MUTEX and call CONDITION-NOTIFY during
350            ;; this comment, it will change queue->data, and so
351            ;; futex-wait returns immediately instead of sleeping.
352            ;; Ergo, no lost wakeup. We may get spurious wakeups,
353            ;; but that's ok.
354            (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
355              (when (= 1 (with-pinned-objects (queue me)
356                           (futex-wait (waitqueue-data-address queue)
357                                       (get-lisp-obj-address me)
358                                       (or to-sec -1) ;; our way if saying "no timeout"
359                                       (or to-usec 0))))
360                (signal-deadline))))
361       ;; If we are interrupted while waiting, we should do these things
362       ;; before returning.  Ideally, in the case of an unhandled signal,
363       ;; we should do them before entering the debugger, but this is
364       ;; better than nothing.
365       (get-mutex mutex value))))
366
367 (defun condition-notify (queue &optional (n 1))
368   #!+sb-doc
369   "Notify N threads waiting on QUEUE."
370   #!-sb-thread (declare (ignore queue n))
371   #!-sb-thread (error "Not supported in unithread builds.")
372   #!+sb-thread
373   (declare (type (and fixnum (integer 1)) n))
374   (/show0 "Entering CONDITION-NOTIFY")
375   #!+sb-thread
376   (progn
377     #!+sb-lutex
378     (with-lutex-address (lutex (waitqueue-lutex queue))
379       (%lutex-wake lutex n))
380     ;; no problem if >1 thread notifies during the comment in
381     ;; condition-wait: as long as the value in queue-data isn't the
382     ;; waiting thread's id, it matters not what it is
383     ;; XXX we should do something to ensure that the result of this setf
384     ;; is visible to all CPUs
385     #!-sb-lutex
386     (let ((me *current-thread*))
387       (progn
388         (setf (waitqueue-data queue) me)
389         (with-pinned-objects (queue)
390           (futex-wake (waitqueue-data-address queue) n))))))
391
392 (defun condition-broadcast (queue)
393   #!+sb-doc
394   "Notify all threads waiting on QUEUE."
395   (condition-notify queue
396                     ;; On a 64-bit platform truncating M-P-F to an int results
397                     ;; in -1, which wakes up only one thread.
398                     (ldb (byte 29 0)
399                          most-positive-fixnum)))
400
401 ;;;; semaphores
402
403 (defstruct (semaphore (:constructor %make-semaphore))
404   #!+sb-doc
405   "Semaphore type."
406   (name nil :type (or null simple-string))
407   (count 0 :type (integer 0))
408   (mutex (make-mutex))
409   (queue (make-waitqueue)))
410
411 (defun make-semaphore (&key name (count 0))
412   #!+sb-doc
413   "Create a semaphore with the supplied COUNT."
414   (%make-semaphore :name name :count count))
415
416 (setf (fdocumentation 'semaphore-name 'function)
417       "The name of the semaphore. Setfable.")
418
419 (defun wait-on-semaphore (sem)
420   #!+sb-doc
421   "Decrement the count of SEM if the count would not be negative. Else
422 block until the semaphore can be decremented."
423   ;; a more direct implementation based directly on futexes should be
424   ;; possible
425   (with-mutex ((semaphore-mutex sem))
426     (loop until (> (semaphore-count sem) 0)
427           do (condition-wait (semaphore-queue sem) (semaphore-mutex sem))
428           finally (decf (semaphore-count sem)))))
429
430 (defun signal-semaphore (sem &optional (n 1))
431   #!+sb-doc
432   "Increment the count of SEM by N. If there are threads waiting on
433 this semaphore, then N of them is woken up."
434   (declare (type (and fixnum (integer 1)) n))
435   (with-mutex ((semaphore-mutex sem))
436     (when (= n (incf (semaphore-count sem) n))
437       (condition-notify (semaphore-queue sem) n))))
438
439 ;;;; job control, independent listeners
440
441 (defstruct session
442   (lock (make-mutex :name "session lock"))
443   (threads nil)
444   (interactive-threads nil)
445   (interactive-threads-queue (make-waitqueue)))
446
447 (defvar *session* nil)
448
449 ;;; the debugger itself tries to acquire the session lock, don't let
450 ;;; funny situations (like getting a sigint while holding the session
451 ;;; lock) occur
452 (defmacro with-session-lock ((session) &body body)
453   #!-sb-thread (declare (ignore session))
454   #!-sb-thread
455   `(locally ,@body)
456   #!+sb-thread
457   `(without-interrupts
458      (with-mutex ((session-lock ,session))
459        ,@body)))
460
461 (defun new-session ()
462   (make-session :threads (list *current-thread*)
463                 :interactive-threads (list *current-thread*)))
464
465 (defun init-job-control ()
466   (/show0 "Entering INIT-JOB-CONTROL")
467   (setf *session* (new-session))
468   (/show0 "Exiting INIT-JOB-CONTROL"))
469
470 (defun %delete-thread-from-session (thread session)
471   (with-session-lock (session)
472     (setf (session-threads session)
473           (delete thread (session-threads session))
474           (session-interactive-threads session)
475           (delete thread (session-interactive-threads session)))))
476
477 (defun call-with-new-session (fn)
478   (%delete-thread-from-session *current-thread* *session*)
479   (let ((*session* (new-session)))
480     (funcall fn)))
481
482 (defmacro with-new-session (args &body forms)
483   (declare (ignore args))               ;for extensibility
484   (sb!int:with-unique-names (fb-name)
485     `(labels ((,fb-name () ,@forms))
486       (call-with-new-session (function ,fb-name)))))
487
488 ;;; Remove thread from its session, if it has one.
489 #!+sb-thread
490 (defun handle-thread-exit (thread)
491   (/show0 "HANDLING THREAD EXIT")
492   ;; We're going down, can't handle interrupts sanely anymore.
493   ;; GC remains enabled.
494   (block-deferrable-signals)
495   ;; Lisp-side cleanup
496   (with-all-threads-lock
497     (setf (thread-%alive-p thread) nil)
498     (setf (thread-os-thread thread) nil)
499     (setq *all-threads* (delete thread *all-threads*))
500     (when *session*
501       (%delete-thread-from-session thread *session*)))
502   #!+sb-lutex
503   (without-gcing
504     (/show0 "FREEING MUTEX LUTEX")
505     (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread)))
506       (%lutex-destroy lutex))))
507
508 (defun terminate-session ()
509   #!+sb-doc
510   "Kill all threads in session except for this one.  Does nothing if current
511 thread is not the foreground thread."
512   ;; FIXME: threads created in other threads may escape termination
513   (let ((to-kill
514          (with-session-lock (*session*)
515            (and (eq *current-thread*
516                     (car (session-interactive-threads *session*)))
517                 (session-threads *session*)))))
518     ;; do the kill after dropping the mutex; unwind forms in dying
519     ;; threads may want to do session things
520     (dolist (thread to-kill)
521       (unless (eq thread *current-thread*)
522         ;; terminate the thread but don't be surprised if it has
523         ;; exited in the meantime
524         (handler-case (terminate-thread thread)
525           (interrupt-thread-error ()))))))
526
527 ;;; called from top of invoke-debugger
528 (defun debugger-wait-until-foreground-thread (stream)
529   "Returns T if thread had been running in background, NIL if it was
530 interactive."
531   (declare (ignore stream))
532   #!-sb-thread nil
533   #!+sb-thread
534   (prog1
535       (with-session-lock (*session*)
536         (not (member *current-thread*
537                      (session-interactive-threads *session*))))
538     (get-foreground)))
539
540 (defun get-foreground ()
541   #!-sb-thread t
542   #!+sb-thread
543   (let ((was-foreground t))
544     (loop
545      (/show0 "Looping in GET-FOREGROUND")
546      (with-session-lock (*session*)
547        (let ((int-t (session-interactive-threads *session*)))
548          (when (eq (car int-t) *current-thread*)
549            (unless was-foreground
550              (format *query-io* "Resuming thread ~A~%" *current-thread*))
551            (return-from get-foreground t))
552          (setf was-foreground nil)
553          (unless (member *current-thread* int-t)
554            (setf (cdr (last int-t))
555                  (list *current-thread*)))
556          (condition-wait
557           (session-interactive-threads-queue *session*)
558           (session-lock *session*)))))))
559
560 (defun release-foreground (&optional next)
561   #!+sb-doc
562   "Background this thread.  If NEXT is supplied, arrange for it to
563 have the foreground next."
564   #!-sb-thread (declare (ignore next))
565   #!-sb-thread nil
566   #!+sb-thread
567   (with-session-lock (*session*)
568     (when (rest (session-interactive-threads *session*))
569       (setf (session-interactive-threads *session*)
570             (delete *current-thread* (session-interactive-threads *session*))))
571     (when next
572       (setf (session-interactive-threads *session*)
573             (list* next
574                    (delete next (session-interactive-threads *session*)))))
575     (condition-broadcast (session-interactive-threads-queue *session*))))
576
577 (defun foreground-thread ()
578   (car (session-interactive-threads *session*)))
579
580 (defun make-listener-thread (tty-name)
581   (assert (probe-file tty-name))
582   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
583          (out (sb!unix:unix-dup in))
584          (err (sb!unix:unix-dup in)))
585     (labels ((thread-repl ()
586                (sb!unix::unix-setsid)
587                (let* ((sb!impl::*stdin*
588                        (make-fd-stream in :input t :buffering :line
589                                        :dual-channel-p t))
590                       (sb!impl::*stdout*
591                        (make-fd-stream out :output t :buffering :line
592                                               :dual-channel-p t))
593                       (sb!impl::*stderr*
594                        (make-fd-stream err :output t :buffering :line
595                                               :dual-channel-p t))
596                       (sb!impl::*tty*
597                        (make-fd-stream err :input t :output t
598                                               :buffering :line
599                                               :dual-channel-p t))
600                       (sb!impl::*descriptor-handlers* nil))
601                  (with-new-session ()
602                    (unwind-protect
603                         (sb!impl::toplevel-repl nil)
604                      (sb!int:flush-standard-output-streams))))))
605       (make-thread #'thread-repl))))
606
607 ;;;; the beef
608
609 (defun make-thread (function &key name)
610   #!+sb-doc
611   "Create a new thread of NAME that runs FUNCTION. When the function
612 returns the thread exits. The return values of FUNCTION are kept
613 around and can be retrieved by JOIN-THREAD."
614   #!-sb-thread (declare (ignore function name))
615   #!-sb-thread (error "Not supported in unithread builds.")
616   #!+sb-thread
617   (let* ((thread (%make-thread :name name))
618          (setup-sem (make-semaphore :name "Thread setup semaphore"))
619          (real-function (coerce function 'function))
620          (initial-function
621           (lambda ()
622             ;; In time we'll move some of the binding presently done in C
623             ;; here too.
624             ;;
625             ;; KLUDGE: Here we have a magic list of variables that are
626             ;; not thread-safe for one reason or another.  As people
627             ;; report problems with the thread safety of certain
628             ;; variables, (e.g. "*print-case* in multiple threads
629             ;; broken", sbcl-devel 2006-07-14), we add a few more
630             ;; bindings here.  The Right Thing is probably some variant
631             ;; of Allegro's *cl-default-special-bindings*, as that is at
632             ;; least accessible to users to secure their own libraries.
633             ;;   --njf, 2006-07-15
634             (let ((*current-thread* thread)
635                   (*restart-clusters* nil)
636                   (*handler-clusters* nil)
637                   (*condition-restarts* nil)
638                   (sb!impl::*step-out* nil)
639                   ;; internal printer variables
640                   (sb!impl::*previous-case* nil)
641                   (sb!impl::*previous-readtable-case* nil)
642                   (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small!
643                   (sb!impl::*zap-array-data-temp* (vector))    ;
644                   (sb!impl::*internal-symbol-output-fun* nil)
645                   (sb!impl::*descriptor-handlers* nil)) ; serve-event
646               (setf (thread-os-thread thread) (current-thread-sap-id))
647               (with-mutex ((thread-result-lock thread))
648                 (with-all-threads-lock
649                   (push thread *all-threads*))
650                 (with-session-lock (*session*)
651                   (push thread (session-threads *session*)))
652                 (setf (thread-%alive-p thread) t)
653                 (signal-semaphore setup-sem)
654                 ;; can't use handling-end-of-the-world, because that flushes
655                 ;; output streams, and we don't necessarily have any (or we
656                 ;; could be sharing them)
657                 (catch 'sb!impl::toplevel-catcher
658                   (catch 'sb!impl::%end-of-the-world
659                     (with-simple-restart
660                         (terminate-thread
661                          (format nil
662                                  "~~@<Terminate this thread (~A)~~@:>"
663                                  *current-thread*))
664                       (unwind-protect
665                            (progn
666                              ;; now that most things have a chance to
667                              ;; work properly without messing up other
668                              ;; threads, it's time to enable signals
669                              (sb!unix::reset-signal-mask)
670                              (setf (thread-result thread)
671                                    (cons t
672                                          (multiple-value-list
673                                           (funcall real-function)))))
674                         (handle-thread-exit thread)))))))
675             (values))))
676     ;; Keep INITIAL-FUNCTION pinned until the child thread is
677     ;; initialized properly.
678     (with-pinned-objects (initial-function)
679       (let ((os-thread
680              (%create-thread
681               (get-lisp-obj-address initial-function))))
682         (when (zerop os-thread)
683           (error "Can't create a new thread"))
684         (wait-on-semaphore setup-sem)
685         thread))))
686
687 (define-condition join-thread-error (error)
688   ((thread :reader join-thread-error-thread :initarg :thread))
689   #!+sb-doc
690   (:documentation "Joining thread failed.")
691   (:report (lambda (c s)
692              (format s "Joining thread failed: thread ~A ~
693                         has not returned normally."
694                      (join-thread-error-thread c)))))
695
696 #!+sb-doc
697 (setf (fdocumentation 'join-thread-error-thread 'function)
698       "The thread that we failed to join.")
699
700 (defun join-thread (thread &key (default nil defaultp))
701   #!+sb-doc
702   "Suspend current thread until THREAD exits. Returns the result
703 values of the thread function. If the thread does not exit normally,
704 return DEFAULT if given or else signal JOIN-THREAD-ERROR."
705   (with-mutex ((thread-result-lock thread))
706     (cond ((car (thread-result thread))
707            (values-list (cdr (thread-result thread))))
708           (defaultp
709            default)
710           (t
711            (error 'join-thread-error :thread thread)))))
712
713 (defun destroy-thread (thread)
714   #!+sb-doc
715   "Deprecated. Same as TERMINATE-THREAD."
716   (terminate-thread thread))
717
718 (define-condition interrupt-thread-error (error)
719   ((thread :reader interrupt-thread-error-thread :initarg :thread))
720   #!+sb-doc
721   (:documentation "Interrupting thread failed.")
722   (:report (lambda (c s)
723              (format s "Interrupt thread failed: thread ~A has exited."
724                      (interrupt-thread-error-thread c)))))
725
726 #!+sb-doc
727 (setf (fdocumentation 'interrupt-thread-error-thread 'function)
728       "The thread that was not interrupted.")
729
730 (defmacro with-interruptions-lock ((thread) &body body)
731   `(without-interrupts
732      (with-mutex ((thread-interruptions-lock ,thread))
733        ,@body)))
734
735 ;; Called from the signal handler.
736 (defun run-interruption ()
737   (in-interruption ()
738     (loop
739        (let ((interruption (with-interruptions-lock (*current-thread*)
740                              (pop (thread-interruptions *current-thread*)))))
741          (if interruption
742              (with-interrupts
743                (funcall interruption))
744              (return))))))
745
746 ;; The order of interrupt execution is peculiar. If thread A
747 ;; interrupts thread B with I1, I2 and B for some reason receives I1
748 ;; when FUN2 is already on the list, then it is FUN2 that gets to run
749 ;; first. But when FUN2 is run SIG_INTERRUPT_THREAD is enabled again
750 ;; and I2 hits pretty soon in FUN2 and run FUN1. This is of course
751 ;; just one scenario, and the order of thread interrupt execution is
752 ;; undefined.
753 (defun interrupt-thread (thread function)
754   #!+sb-doc
755   "Interrupt the live THREAD and make it run FUNCTION. A moderate
756 degree of care is expected for use of INTERRUPT-THREAD, due to its
757 nature: if you interrupt a thread that was holding important locks
758 then do something that turns out to need those locks, you probably
759 won't like the effect."
760   #!-sb-thread (declare (ignore thread))
761   ;; not quite perfect, because it does not take WITHOUT-INTERRUPTS
762   ;; into account
763   #!-sb-thread
764   (funcall function)
765   #!+sb-thread
766   (if (eq thread *current-thread*)
767       (funcall function)
768       (let ((os-thread (thread-os-thread thread)))
769         (cond ((not os-thread)
770                (error 'interrupt-thread-error :thread thread))
771               (t
772                (with-interruptions-lock (thread)
773                  (push function (thread-interruptions thread)))
774                (when (minusp (signal-interrupt-thread os-thread))
775                  (error 'interrupt-thread-error :thread thread)))))))
776
777 (defun terminate-thread (thread)
778   #!+sb-doc
779   "Terminate the thread identified by THREAD, by causing it to run
780 SB-EXT:QUIT - the usual cleanup forms will be evaluated"
781   (interrupt-thread thread 'sb!ext:quit))
782
783 ;;; internal use only.  If you think you need to use this, either you
784 ;;; are an SBCL developer, are doing something that you should discuss
785 ;;; with an SBCL developer first, or are doing something that you
786 ;;; should probably discuss with a professional psychiatrist first
787 #!+sb-thread
788 (defun thread-sap-for-id (id)
789   (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t)))))
790     (loop
791      (when (sap= thread-sap (int-sap 0)) (return nil))
792      (let ((os-thread (sap-ref-word thread-sap
793                                     (* sb!vm:n-word-bytes
794                                        sb!vm::thread-os-thread-slot))))
795        (when (= os-thread id) (return thread-sap))
796        (setf thread-sap
797              (sap-ref-sap thread-sap (* sb!vm:n-word-bytes
798                                         sb!vm::thread-next-slot)))))))
799
800 #!+sb-thread
801 (defun symbol-value-in-thread (symbol thread-sap)
802   (let* ((index (sb!vm::symbol-tls-index symbol))
803          (tl-val (sap-ref-word thread-sap
804                                (* sb!vm:n-word-bytes index))))
805     (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
806         (sb!vm::symbol-global-value symbol)
807         (make-lisp-obj tl-val))))
808
809 (defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
810   (sb!vm::locked-symbol-global-value-add symbol-name delta))
811
812 ;;; Stepping
813
814 (defun thread-stepping ()
815   (make-lisp-obj
816    (sap-ref-word (current-thread-sap)
817                  (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))))
818
819 (defun (setf thread-stepping) (value)
820   (setf (sap-ref-word (current-thread-sap)
821                       (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))
822         (get-lisp-obj-address value)))