0.8alpha.0.9:
[sbcl.git] / src / code / target-thread.lisp
1 (in-package "SB!THREAD")
2
3 (sb!alien::define-alien-routine ("create_thread" %create-thread)
4      sb!alien:unsigned-long
5   (lisp-fun-address sb!alien:unsigned-long))
6
7 (defun make-thread (function)
8   (let ((real-function (coerce function 'function)))
9     (%create-thread
10      (sb!kernel:get-lisp-obj-address
11       (lambda ()
12         ;; in time we'll move some of the binding presently done in C
13         ;; here too
14         (let ((sb!kernel::*restart-clusters* nil)
15               (sb!impl::*descriptor-handlers* nil); serve-event
16               (sb!impl::*available-buffers* nil)) ;for fd-stream
17           ;; can't use handling-end-of-the-world, because that flushes
18           ;; output streams, and we don't necessarily have any (or we
19           ;; could be sharing them)
20           (sb!sys:enable-interrupt :sigint :ignore)
21           (sb!unix:unix-exit
22            (catch 'sb!impl::%end-of-the-world 
23              (with-simple-restart 
24                  (destroy-thread
25                   (format nil "~~@<Destroy this thread (~A)~~@:>"
26                           (current-thread-id)))
27                (funcall real-function))
28              0))))))))
29
30 (defun destroy-thread (thread-id)
31   (sb!unix:unix-kill thread-id :sigterm)
32   ;; may have been stopped for some reason, so now wake it up to
33   ;; deliver the TERM
34   (sb!unix:unix-kill thread-id :sigcont))
35
36 ;; Conventional wisdom says that it's a bad idea to use these unless
37 ;; you really need to.  Use a lock or a waitqueue instead
38 (defun suspend-thread (thread-id)
39   (sb!unix:unix-kill thread-id :sigstop))
40 (defun resume-thread (thread-id)
41   (sb!unix:unix-kill thread-id :sigcont))
42
43 (defun current-thread-id ()
44   (sb!sys:sap-int
45    (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot)))
46
47 ;;;; iterate over the in-memory threads
48
49 (defun mapcar-threads (function)
50   "Call FUNCTION once for each known thread, giving it the thread structure as argument"
51   (let ((function (coerce function 'function)))
52     (loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
53           then  (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot))
54           until (sb!sys:sap= thread (sb!sys:int-sap 0))
55           collect (funcall function thread))))
56
57 ;;;; queues, locks 
58
59 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
60 (defun get-spinlock (lock offset new-value)
61   (declare (optimize (speed 3) (safety 0)))
62   (loop until
63         (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
64
65 (defmacro with-spinlock ((queue) &body body)
66   (with-unique-names (pid)
67     `(unwind-protect
68       (let ((,pid (current-thread-id)))
69         (get-spinlock ,queue 2 ,pid)
70         ,@body)
71       (setf (waitqueue-lock ,queue) 0))))
72
73 ;;;; the higher-level locking operations are based on waitqueues
74
75 (defstruct waitqueue
76   (name nil :type (or null simple-base-string))
77   (lock 0)
78   (data nil))
79
80 (defstruct (mutex (:include waitqueue))
81   (value nil))
82
83 (sb!alien:define-alien-routine "block_sigcont"  void)
84 (sb!alien:define-alien-routine "unblock_sigcont_and_sleep"  void)
85
86 (defun wait-on-queue (queue &optional lock)
87   (let ((pid (current-thread-id)))
88     ;; FIXME what should happen if we get interrupted when we've blocked
89     ;; the sigcont?  For that matter, can we get interrupted?
90     (block-sigcont)
91     (when lock (release-mutex lock))
92     (get-spinlock queue 2 pid)
93     (pushnew pid (waitqueue-data queue))
94     (setf (waitqueue-lock queue) 0)
95     (unblock-sigcont-and-sleep)))
96
97 (defun dequeue (queue)
98   (let ((pid (current-thread-id)))
99     (get-spinlock queue 2 pid)
100     (setf (waitqueue-data queue)
101           (delete pid (waitqueue-data queue)))
102     (setf (waitqueue-lock queue) 0)))
103
104 (defun signal-queue-head (queue)
105   (let ((pid (current-thread-id)))
106     (get-spinlock queue 2 pid)
107     (let ((h (car (waitqueue-data queue))))
108       (setf (waitqueue-lock queue) 0)
109       (when h
110         (sb!unix:unix-kill h :sigcont)))))
111
112 ;;;; mutex
113
114 (defun get-mutex (lock &optional new-value (wait-p t))
115   (declare (type mutex lock))
116   (let ((pid (current-thread-id)))
117     (unless new-value (setf new-value pid))
118     (assert (not (eql new-value (mutex-value lock))))
119     (loop
120      (unless
121          ;; args are object slot-num old-value new-value
122          (sb!vm::%instance-set-conditional lock 4 nil new-value)
123        (dequeue lock)
124        (return t))
125      (unless wait-p (return nil))
126      (wait-on-queue lock nil))))
127
128 (defun release-mutex (lock &optional (new-value nil))
129   (declare (type mutex lock))
130   (let ((old-value (mutex-value lock))
131         (t1 nil))
132     (loop
133      (unless
134          ;; args are object slot-num old-value new-value
135          (eql old-value
136               (setf t1
137                     (sb!vm::%instance-set-conditional lock 4 old-value new-value)))       
138        (signal-queue-head lock)
139        (return t))
140      (setf old-value t1))))
141
142 (defmacro with-mutex ((mutex &key value (wait-p t))  &body body)
143   (with-unique-names (got)
144     `(let ((,got (get-mutex ,mutex ,value ,wait-p)))
145       (when ,got
146         (unwind-protect
147              (progn ,@body)
148           (release-mutex ,mutex))))))
149
150
151 ;;;; condition variables
152
153 (defun condition-wait (queue lock)
154   "Atomically release LOCK and enqueue ourselves on QUEUE.  Another
155 thread may subsequently notify us using CONDITION-NOTIFY, at which
156 time we reacquire LOCK and return to the caller."
157   (unwind-protect
158        (wait-on-queue queue lock)
159     ;; If we are interrupted while waiting, we should do these things
160     ;; before returning.  Ideally, in the case of an unhandled signal,
161     ;; we should do them before entering the debugger, but this is
162     ;; better than nothing.
163     (dequeue queue)
164     (get-mutex lock)))
165
166 (defun condition-notify (queue)
167   "Notify one of the processes waiting on QUEUE"
168   (signal-queue-head queue))
169
170
171 ;;;; multiple independent listeners
172
173 (defvar *session-lock* nil)
174
175 (defun make-listener-thread (tty-name)  
176   (assert (probe-file tty-name))
177   ;; FIXME probably still need to do some tty stuff to get signals
178   ;; delivered correctly.
179   ;; FIXME 
180   (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
181          (out (sb!unix:unix-dup in))
182          (err (sb!unix:unix-dup in)))
183     (labels ((thread-repl () 
184                (sb!unix::unix-setsid)
185                (let* ((*session-lock*
186                        (make-mutex :name (format nil "lock for ~A" tty-name)))
187                       (sb!impl::*stdin* 
188                        (sb!sys:make-fd-stream in :input t :buffering :line))
189                       (sb!impl::*stdout* 
190                        (sb!sys:make-fd-stream out :output t :buffering :line))
191                       (sb!impl::*stderr* 
192                        (sb!sys:make-fd-stream err :output t :buffering :line))
193                       (sb!impl::*tty* 
194                        (sb!sys:make-fd-stream err :input t :output t :buffering :line))
195                       (sb!impl::*descriptor-handlers* nil))
196                  (get-mutex *session-lock*)
197                  (sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler)
198                  (unwind-protect
199                       (sb!impl::toplevel-repl nil)
200                    (sb!int:flush-standard-output-streams)))))
201       (make-thread #'thread-repl))))
202   
203 ;;;; job control
204
205 (defvar *background-threads-wait-for-debugger* t)
206 ;;; may be T, NIL, or a function called with a stream and thread id 
207 ;;; as its two arguments, returning NIl or T
208
209 ;;; called from top of invoke-debugger
210 (defun debugger-wait-until-foreground-thread (stream)
211   "Returns T if thread had been running in background, NIL if it was
212 already the foreground thread, or transfers control to the first applicable
213 restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead"
214   (let* ((wait-p *background-threads-wait-for-debugger*)
215          (*background-threads-wait-for-debugger* nil)
216          (lock *session-lock*))
217     (when (not (eql (mutex-value lock)   (CURRENT-THREAD-ID)))
218       (when (functionp wait-p) 
219         (setf wait-p 
220               (funcall wait-p stream (CURRENT-THREAD-ID))))
221       (cond (wait-p (get-foreground))
222             (t  (invoke-restart (car (compute-restarts))))))))
223
224 ;;; install this with (setf SB!INT:*REPL-PROMPT-FUN* #'thread-prompt-fun)
225 ;;; One day it will be default
226 (defun thread-repl-prompt-fun (out-stream)
227   (let ((lock *session-lock*))
228     (get-foreground)
229     (let ((stopped-threads (waitqueue-data lock)))
230       (when stopped-threads
231         (format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads))
232       (sb!impl::repl-prompt-fun out-stream))))
233
234 (defun resume-stopped-thread (id)
235   (let ((pid (current-thread-id))
236         (lock *session-lock*)) 
237     (with-spinlock (lock)
238       (setf (waitqueue-data lock)
239             (cons id (delete id  (waitqueue-data lock)))))
240     (release-foreground)))
241
242 (defstruct rwlock
243   (name nil :type (or null simple-base-string))
244   (value 0 :type fixnum)
245   (max-readers nil :type (or fixnum null))
246   (max-writers 1 :type fixnum))
247 #+nil
248 (macrolet
249     ((make-rwlocking-function (lock-fn unlock-fn increment limit test)
250        (let ((do-update '(when (eql old-value
251                                 (sb!vm::%instance-set-conditional
252                                  lock 2 old-value new-value))
253                           (return (values t old-value))))
254              (vars `((timeout (and timeout (+ (get-internal-real-time) timeout)))
255                      old-value
256                      new-value
257                      (limit ,limit))))
258          (labels ((do-setfs (v) `(setf old-value (rwlock-value lock)
259                                   new-value (,v old-value ,increment))))
260            `(progn
261              (defun ,lock-fn (lock timeout)
262                (declare (type rwlock lock))
263                (let ,vars
264                  (loop
265                   ,(do-setfs '+)
266                   (when ,test
267                     ,do-update)
268                   (when (sleep-a-bit timeout) (return nil)) ;expired
269                   )))
270              ;; unlock doesn't need timeout or test-in-range
271              (defun ,unlock-fn (lock)
272                (declare (type rwlock lock))
273                (declare (ignorable limit))
274                (let ,(cdr vars)
275                  (loop
276                   ,(do-setfs '-)
277                   ,do-update))))))))
278     
279   (make-rwlocking-function %lock-for-reading %unlock-for-reading 1
280                            (rwlock-max-readers lock)
281                            (and (>= old-value 0)
282                                 (or (null limit) (<= new-value limit))))
283   (make-rwlocking-function %lock-for-writing %unlock-for-writing -1
284                            (- (rwlock-max-writers lock))
285                            (and (<= old-value 0)
286                                 (>= new-value limit))))
287 #+nil  
288 (defun get-rwlock (lock direction &optional timeout)
289   (ecase direction
290     (:read (%lock-for-reading lock timeout))
291     (:write (%lock-for-writing lock timeout))))
292 #+nil
293 (defun free-rwlock (lock direction)
294   (ecase direction
295     (:read (%unlock-for-reading lock))
296     (:write (%unlock-for-writing lock))))
297
298 ;;;; beyond this point all is commented.
299
300 ;;; Lock-Wait-With-Timeout  --  Internal
301 ;;;
302 ;;; Wait with a timeout for the lock to be free and acquire it for the
303 ;;; *current-process*.
304 ;;;
305 #+nil
306 (defun lock-wait-with-timeout (lock whostate timeout)
307   (declare (type lock lock))
308   (process-wait-with-timeout
309    whostate timeout
310    #'(lambda ()
311        (declare (optimize (speed 3)))
312        #-i486
313        (unless (lock-process lock)
314          (setf (lock-process lock) *current-process*))
315        #+i486
316        (null (kernel:%instance-set-conditional
317               lock 2 nil *current-process*)))))
318
319 ;;; With-Lock-Held  --  Public
320 ;;;
321 #+nil
322 (defmacro with-lock-held ((lock &optional (whostate "Lock Wait")
323                                 &key (wait t) timeout)
324                           &body body)
325   "Execute the body with the lock held. If the lock is held by another
326   process then the current process waits until the lock is released or
327   an optional timeout is reached. The optional wait timeout is a time in
328   seconds acceptable to process-wait-with-timeout.  The results of the
329   body are return upon success and NIL is return if the timeout is
330   reached. When the wait key is NIL and the lock is held by another
331   process then NIL is return immediately without processing the body."
332   (let ((have-lock (gensym)))
333     `(let ((,have-lock (eq (lock-process ,lock) *current-process*)))
334       (unwind-protect
335            ,(cond ((and timeout wait)
336                    `(progn
337                       (when (and (error-check-lock-p ,lock) ,have-lock)
338                         (error "Dead lock"))
339                       (when (or ,have-lock
340                                  #+i486 (null (kernel:%instance-set-conditional
341                                                ,lock 2 nil *current-process*))
342                                  #-i486 (seize-lock ,lock)
343                                  (if ,timeout
344                                      (lock-wait-with-timeout
345                                       ,lock ,whostate ,timeout)
346                                      (lock-wait ,lock ,whostate)))
347                         ,@body)))
348                   (wait
349                    `(progn
350                       (when (and (error-check-lock-p ,lock) ,have-lock)
351                         (error "Dead lock"))
352                       (unless (or ,have-lock
353                                  #+i486 (null (kernel:%instance-set-conditional
354                                                ,lock 2 nil *current-process*))
355                                  #-i486 (seize-lock ,lock))
356                         (lock-wait ,lock ,whostate))
357                       ,@body))
358                   (t
359                    `(when (or (and (recursive-lock-p ,lock) ,have-lock)
360                               #+i486 (null (kernel:%instance-set-conditional
361                                             ,lock 2 nil *current-process*))
362                               #-i486 (seize-lock ,lock))
363                       ,@body)))
364         (unless ,have-lock
365           #+i486 (kernel:%instance-set-conditional
366                   ,lock 2 *current-process* nil)
367           #-i486 (when (eq (lock-process ,lock) *current-process*)
368                    (setf (lock-process ,lock) nil)))))))
369
370
371