apiv2/api-threads.lisp

   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 \f
 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)))