apiv2/api-threads.lisp

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