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