Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/sionescu-bordeaux-threads-20250412101706/apiv2/api-threads.lisp

KindCoveredAll%
expression0218 0.0
branch010 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*-
2
 ;;;; The above modeline is required for Genera. Do not change.
3
 
4
 (in-package :bordeaux-threads-2)
5
 
6
 (defclass thread ()
7
   ((name :initarg :name :reader thread-name)
8
    (native-thread :initarg :native-thread
9
                   :reader thread-native-thread)
10
    (%lock :initform (make-lock))
11
    ;; Used for implementing condition variables in
12
    ;; impl-condition-variables-semaphores.lisp.
13
    #+ccl
14
    (%semaphore :initform (%make-semaphore nil 0)
15
                :reader %thread-semaphore)
16
    (%return-values :initform nil :reader thread-return-values)
17
    (%exit-condition :initform nil :reader thread-exit-condition)))
18
 
19
 (defmethod print-object ((thread thread) stream)
20
   (print-unreadable-object (thread stream :type t :identity t)
21
     (format stream "~S" (thread-name thread))))
22
 
23
 (define-global-var* .known-threads-lock.
24
   (make-lock :name "known-threads-lock"))
25
 
26
 (define-global-var* .known-threads.
27
   (trivial-garbage:make-weak-hash-table #-genera :weakness #-genera :key))
28
 
29
 (define-global-var* .thread-counter. -1)
30
 
31
 (defun make-unknown-thread-name ()
32
   (format nil "Unknown thread ~S"
33
           (with-lock-held (.known-threads-lock.)
34
             (incf .thread-counter.))))
35
 
36
 (defun ensure-thread-wrapper (native-thread)
37
   (with-lock-held (.known-threads-lock.)
38
     (multiple-value-bind (thread presentp)
39
         (gethash native-thread .known-threads.)
40
       (if presentp
41
           thread
42
           (setf (gethash native-thread .known-threads.)
43
                 (make-instance 'thread
44
                                :name (%thread-name native-thread)
45
                                :native-thread native-thread))))))
46
 
47
 (defun %get-thread-wrapper (native-thread)
48
   (multiple-value-bind (thread presentp)
49
       (with-lock-held (.known-threads-lock.)
50
         (gethash native-thread .known-threads.))
51
     (if presentp
52
         thread
53
         (bt-error "Thread wrapper is supposed to exist for ~S"
54
                   native-thread))))
55
 
56
 (defun (setf thread-wrapper) (thread native-thread)
57
   (with-lock-held (.known-threads-lock.)
58
     (setf (gethash native-thread .known-threads.) thread)))
59
 
60
 (defun remove-thread-wrapper (native-thread)
61
   (with-lock-held (.known-threads-lock.)
62
     (remhash native-thread .known-threads.)))
63
 
64
 ;; Forms are evaluated in the new thread or in the calling thread?
65
 (defvar *default-special-bindings* nil
66
   "This variable holds an alist associating special variable symbols
67
   to forms to evaluate. Special variables named in this list will
68
   be locally bound in the new thread before it begins executing user code.
69
 
70
   This variable may be rebound around calls to MAKE-THREAD to
71
   add/alter default bindings. The effect of mutating this list is
72
   undefined, but earlier forms take precedence over later forms for
73
   the same symbol, so defaults may be overridden by consing to the
74
   head of the list.")
75
 
76
 (macrolet
77
     ((defbindings (name docstring &body initforms)
78
          (check-type docstring string)
79
        `(alexandria:define-constant ,name
80
             (list
81
              ,@(loop for (special form) in initforms
82
                      collect `(cons ',special ',form)))
83
           :test #'equal
84
           :documentation ,docstring)))
85
   (defbindings +standard-io-bindings+
86
       "Standard bindings of printer/reader control variables as per
87
 CL:WITH-STANDARD-IO-SYNTAX. Forms are evaluated in the calling thread."
88
     (*package*                   (find-package :common-lisp-user))
89
     (*print-array*               t)
90
     (*print-base*                10)
91
     (*print-case*                :upcase)
92
     (*print-circle*              nil)
93
     (*print-escape*              t)
94
     (*print-gensym*              t)
95
     (*print-length*              nil)
96
     (*print-level*               nil)
97
     (*print-lines*               nil)
98
     (*print-miser-width*         nil)
99
     ;; Genera doesn't yet implement COPY-PPRINT-DISPATCH
100
     ;; (Calling it signals an error)
101
     #-genera
102
     (*print-pprint-dispatch*     (copy-pprint-dispatch nil))
103
     (*print-pretty*              nil)
104
     (*print-radix*               nil)
105
     (*print-readably*            t)
106
     (*print-right-margin*        nil)
107
     (*random-state*              (make-random-state t))
108
     (*read-base*                 10)
109
     (*read-default-float-format* 'double-float)
110
     (*read-eval*                 nil)
111
     (*read-suppress*             nil)
112
     (*readtable*                 (copy-readtable nil))))
113
 
114
 (defvar *current-thread*)
115
 
116
 (defun compute-special-bindings (bindings)
117
   (remove-duplicates (append bindings +standard-io-bindings+)
118
                      :from-end t :key #'car))
119
 
120
 (defun establish-dynamic-env (thread function special-bindings trap-conditions)
121
   "Return a closure that binds the symbols in SPECIAL-BINDINGS and calls
122
 FUNCTION."
123
   (let* ((bindings (compute-special-bindings special-bindings))
124
          (specials (mapcar #'car bindings))
125
          (values (mapcar (lambda (f) (eval (cdr f))) bindings)))
126
     (named-lambda %establish-dynamic-env-wrapper ()
127
       (progv specials values
128
         (with-slots (%lock %return-values %exit-condition #+genera native-thread)
129
             thread
130
           (flet ((record-condition (c)
131
                    (with-lock-held (%lock)
132
                      (setf %exit-condition c)))
133
                  (run-function ()
134
                    (let ((*current-thread* nil))
135
                      ;; Wait until the thread creator has finished creating
136
                      ;; the wrapper.
137
                      (with-lock-held (%lock)
138
                        (setf *current-thread* (%get-thread-wrapper (%current-thread))))
139
                      (let ((retval
140
                              (multiple-value-list (funcall function))))
141
                        (with-lock-held (%lock)
142
                          (setf %return-values retval))
143
                        retval))))
144
             (unwind-protect
145
                  (if trap-conditions
146
                      (handler-case
147
                          (values-list (run-function))
148
                        (condition (c)
149
                          (record-condition c)))
150
                      (handler-bind
151
                          ((condition #'record-condition))
152
                        (values-list (run-function))))
153
               ;; Genera doesn't support weak key hash tables. If we don't remove
154
               ;; the native-thread object's entry from the hash table here, we'll
155
               ;; never be able to GC the native-thread after it terminates
156
               #+genera (remove-thread-wrapper native-thread))))))))
157
 
158
 
159
 ;;;
160
 ;;; Thread Creation
161
 ;;;
162
 
163
 (defun start-multiprocessing ()
164
   "If the host implementation uses user-level threads, start the
165
 scheduler and multiprocessing, otherwise do nothing.
166
 It is safe to call repeatedly."
167
   (when (fboundp '%start-multiprocessing)
168
     (funcall '%start-multiprocessing))
169
   (values))
170
 
171
 (defun make-thread (function
172
                     &key
173
                       name
174
                       (initial-bindings *default-special-bindings*)
175
                       trap-conditions)
176
   "Creates and returns a thread named NAME, which will call the
177
   function FUNCTION with no arguments: when FUNCTION returns, the
178
   thread terminates.
179
 
180
   The interaction between threads and dynamic variables is in some
181
   cases complex, and depends on whether the variable has only a global
182
   binding (as established by e.g. DEFVAR/DEFPARAMETER/top-level SETQ)
183
   or has been bound locally (e.g. with LET or LET*) in the calling
184
   thread.
185
 
186
   - Global bindings are shared between threads: the initial value of a
187
     global variable in the new thread will be the same as in the
188
     parent, and an assignment to such a variable in any thread will be
189
     visible to all threads in which the global binding is visible.
190
 
191
   - Local bindings, such as the ones introduced by INITIAL-BINDINGS,
192
     are local to the thread they are introduced in, except that
193
 
194
   - Local bindings in the the caller of MAKE-THREAD may or may not be
195
     shared with the new thread that it creates: this is
196
     implementation-defined. Portable code should not depend on
197
     particular behaviour in this case, nor should it assign to such
198
     variables without first rebinding them in the new thread."
199
   (check-type function (and (not null) (or symbol function)))
200
   (check-type name (or null string))
201
   (let* ((name (or name (make-unknown-thread-name)))
202
          (thread (make-instance 'thread :name name)))
203
     (with-slots (native-thread %lock) thread
204
       (with-lock-held (%lock)
205
         (let ((%thread
206
                 (%make-thread (establish-dynamic-env
207
                                thread
208
                                function
209
                                initial-bindings
210
                                trap-conditions)
211
                               name)))
212
           (setf native-thread %thread)
213
           (setf (thread-wrapper %thread) thread))))
214
     thread))
215
 
216
 (defun current-thread ()
217
   "Returns the thread object for the calling thread.
218
   This is the same kind of object as would be returned
219
   by MAKE-THREAD."
220
   (cond
221
     ((boundp '*current-thread*)
222
      (assert (threadp *current-thread*))
223
      *current-thread*)
224
     (t (ensure-thread-wrapper (%current-thread)))))
225
 
226
 (defun threadp (object)
227
   "Returns T if object is a thread, otherwise NIL."
228
   (typep object 'thread))
229
 
230
 (defmethod join-thread ((thread thread))
231
   "Wait until THREAD terminates. If THREAD has already terminated,
232
   return immediately. The return values of the thread function are
233
   returned."
234
   (with-slots (native-thread %lock %return-values %exit-condition)
235
       thread
236
     (when (eql native-thread (%current-thread))
237
       (bt-error "Cannot join with the current thread"))
238
     (%join-thread native-thread)
239
     (multiple-value-bind (exit-condition retval)
240
         (with-lock-held (%lock)
241
           (values %exit-condition %return-values))
242
       (if exit-condition
243
           (error 'abnormal-exit :condition exit-condition)
244
           (values-list retval)))))
245
 
246
 (defun thread-yield ()
247
   "Allows other threads to run. It may be necessary or desirable to
248
   call this periodically in some implementations; others may schedule
249
   threads automatically."
250
   (%thread-yield)
251
   (values))
252
 
253
 ;;;
254
 ;;; Introspection/debugging
255
 ;;;
256
 
257
 (defun all-threads ()
258
   "Returns a sequence of all of the threads."
259
   (mapcar #'ensure-thread-wrapper (%all-threads)))
260
 
261
 (defmethod interrupt-thread ((thread thread) function &rest args)
262
   "Interrupt THREAD and cause it to evaluate FUNCTION
263
   before continuing with the interrupted path of execution. This may
264
   not be a good idea if THREAD is holding locks or doing anything
265
   important."
266
   (flet ((apply-function ()
267
            (if args
268
                (named-lambda %interrupt-thread-wrapper ()
269
                  (apply function args))
270
                function)))
271
     (declare (dynamic-extent #'apply-function))
272
     (%interrupt-thread (thread-native-thread thread) (apply-function))
273
     thread))
274
 
275
 (defmethod signal-in-thread ((thread thread) datum &rest args)
276
   "Interrupt THREAD and call SIGNAL passing DATUM and ARGS."
277
   (apply #'interrupt-thread thread #'signal (cons datum args)))
278
 
279
 (defmethod warn-in-thread ((thread thread) datum &rest args)
280
   "Interrupt THREAD and call WARN passing DATUM and ARGS."
281
   (apply #'interrupt-thread thread #'warn (cons datum args)))
282
 
283
 (defmethod error-in-thread ((thread thread) datum &rest args)
284
   "Interrupt THREAD and call ERROR passing DATUM and ARGS."
285
   (apply #'interrupt-thread thread #'error (cons datum args)))
286
 
287
 (defmethod destroy-thread ((thread thread))
288
   "Terminates the thread THREAD, which is an object
289
   as returned by MAKE-THREAD. This should be used with caution: it is
290
   implementation-defined whether the thread runs cleanup forms or
291
   releases its locks first.
292
 
293
   Destroying the calling thread is an error."
294
   (with-slots (native-thread %lock %exit-condition)
295
       thread
296
     (when (eql native-thread (%current-thread))
297
       (bt-error "Cannot destroy the current thread"))
298
     (unless (thread-alive-p thread)
299
       (bt-error "Cannot destroy thread because it already exited: ~S."
300
                 thread))
301
     (%destroy-thread native-thread)
302
     (with-lock-held (%lock)
303
       (setf %exit-condition :terminated)))
304
   thread)
305
 
306
 (defmethod thread-alive-p ((thread thread))
307
   "Returns true if THREAD is alive, that is, if it has not finished or
308
   DESTROY-THREAD has not been called on it."
309
   (%thread-alive-p (thread-native-thread thread)))