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