apiv1/impl-genera.lisp

   1 ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: BORDEAUX-THREADS; Base: 10; -*-
   2
   3 #|
   4 Distributed under the MIT license (see LICENSE file)
   5 |#
   6
   7 (in-package #:bordeaux-threads)
   8
   9 (deftype thread ()
  10   'process:process)
  11
  12 (defvar *thread-recursive-lock-key* 0)
  13
  14 ;;; Thread Creation
  15
  16 (defun %make-thread (function name)
  17   (flet ((top-level ()
  18            (let* ((*thread-recursive-lock-key* 0)
  19                   (return-values
  20                     (multiple-value-list (funcall function))))
  21              (setf (si:process-spare-slot-4 scl:*current-process*) return-values)
  22              (values-list return-values))))
  23     (declare (dynamic-extent #'top-level))
  24     (process:process-run-function name #'top-level)))
  25
  26 (defun current-thread ()
  27   scl:*current-process*)
  28
  29 (defun threadp (object)
  30   (process:process-p object))
  31
  32 (defun thread-name (thread)
  33   (process:process-name thread))
  34
  35 ;;; Resource contention: locks and recursive locks
  36
  37 (defstruct (lock (:constructor make-lock-internal))
  38   lock
  39   lock-argument)
  40
  41 (defun make-lock (&optional name)
  42   (let ((lock (process:make-lock (or name "Anonymous lock"))))
  43     (make-lock-internal :lock lock
  44                         :lock-argument nil)))
  45
  46 (defun acquire-lock (lock &optional (wait-p t))
  47   (check-type lock lock)
  48   (let ((lock-argument (process:make-lock-argument (lock-lock lock))))
  49     (cond (wait-p
  50            (process:with-no-other-processes
  51              (process:lock (lock-lock lock) lock-argument)
  52              (setf (lock-lock-argument lock) lock-argument)
  53              t))
  54           (t
  55            (process:with-no-other-processes
  56              (when (process:lock-lockable-p (lock-lock lock))
  57                (process:lock (lock-lock lock) lock-argument)
  58                (setf (lock-lock-argument lock) lock-argument)
  59                t))))))
  60
  61 (defun release-lock (lock)
  62   (check-type lock lock)
  63   (process:with-no-other-processes
  64     (process:unlock (lock-lock lock) (scl:shiftf (lock-lock-argument lock) nil))))
  65
  66 (defstruct (recursive-lock (:constructor make-recursive-lock-internal))
  67   lock
  68   lock-arguments)
  69
  70 (defun make-recursive-lock (&optional name)
  71   (make-recursive-lock-internal :lock (process:make-lock (or name "Anonymous recursive lock")
  72                                                          :recursive t)
  73                                 :lock-arguments (make-hash-table :test #'equal)))
  74
  75 (defun acquire-recursive-lock (lock)
  76   (check-type lock recursive-lock)
  77   (acquire-recursive-lock-internal lock))
  78
  79 (defun acquire-recursive-lock-internal (lock &optional timeout)
  80   (let ((key (cons (incf *thread-recursive-lock-key*) scl:*current-process*))
  81         (lock-argument (process:make-lock-argument (recursive-lock-lock lock))))
  82     (cond (timeout
  83            (process:with-no-other-processes
  84              (when (process:lock-lockable-p (recursive-lock-lock lock))
  85                (process:lock (recursive-lock-lock lock) lock-argument)
  86                (setf (gethash key (recursive-lock-lock-arguments lock)) lock-argument)
  87                t)))
  88           (t
  89            (process:with-no-other-processes
  90              (process:lock (recursive-lock-lock lock) lock-argument)
  91              (setf (gethash key (recursive-lock-lock-arguments lock)) lock-argument)
  92              t)))))
  93
  94 (defun release-recursive-lock (lock)
  95   (check-type lock recursive-lock)
  96   (let* ((key (cons *thread-recursive-lock-key* scl:*current-process*))
  97          (lock-argument (gethash key (recursive-lock-lock-arguments lock))))
  98     (process:with-no-other-processes
  99       (prog1
 100           (process:unlock (recursive-lock-lock lock) lock-argument)
 101         (decf *thread-recursive-lock-key*)
 102         (remhash key (recursive-lock-lock-arguments lock))))))
 103
 104 (defmacro with-recursive-lock-held ((place &key timeout) &body body)
 105   `(with-recursive-lock-held-internal ,place ,timeout #'(lambda () ,@body)))
 106
 107 (defun with-recursive-lock-held-internal (lock timeout function)
 108   (check-type lock recursive-lock)
 109   (assert (typep timeout '(or null (satisfies zerop))) (timeout)
 110           'bordeaux-mp-condition :message ":TIMEOUT value must be either NIL or 0")
 111   (when (acquire-recursive-lock-internal lock timeout)
 112     (unwind-protect
 113         (funcall function)
 114       (release-recursive-lock lock))))
 115
 116 ;;; Resource contention: condition variables
 117
 118 (eval-when (:compile-toplevel :load-toplevel :execute)
 119 (defstruct (condition-variable (:constructor %make-condition-variable))
 120   name
 121   (waiters nil))
 122 )
 123
 124 (defun make-condition-variable (&key name)
 125   (%make-condition-variable :name name))
 126
 127 (defun condition-wait (condition-variable lock &key timeout)
 128   (check-type condition-variable condition-variable)
 129   (check-type lock lock)
 130   (process:with-no-other-processes
 131     (let ((waiter (cons scl:*current-process* nil)))
 132       (process:atomic-updatef (condition-variable-waiters condition-variable)
 133                               #'(lambda (waiters)
 134                                   (append waiters (scl:ncons waiter))))
 135       (let ((expired? t))
 136         (unwind-protect
 137             (progn
 138               (release-lock lock)
 139               (process:block-with-timeout timeout
 140                                           (format nil "Waiting~@[ on ~A~]"
 141                                                   (condition-variable-name condition-variable))
 142                                           #'(lambda (waiter expired?-loc)
 143                                               (when (not (null (cdr waiter)))
 144                                                 (setf (sys:location-contents expired?-loc) nil)
 145                                                 t))
 146                                           waiter (sys:value-cell-location 'expired?))
 147               expired?)
 148           (unless expired?
 149             (acquire-lock lock)))))))
 150
 151 (defun condition-notify (condition-variable)
 152   (check-type condition-variable condition-variable)
 153   (let ((waiter (process:atomic-pop (condition-variable-waiters condition-variable))))
 154     (when waiter
 155       (setf (cdr waiter) t)
 156       (process:wakeup (car waiter))))
 157   (values))
 158
 159 (defun thread-yield ()
 160   (scl:process-allow-schedule))
 161
 162 ;;; Timeouts
 163
 164 (defmacro with-timeout ((timeout) &body body)
 165   "Execute `BODY' and signal a condition of type TIMEOUT if the execution of
 166 BODY does not complete within `TIMEOUT' seconds."
 167   `(with-timeout-internal ,timeout #'(lambda () ,@body)))
 168
 169 (defun with-timeout-internal (timeout function)
 170   ;; PROCESS:WITH-TIMEOUT either returns NIL on timeout or signals an error which,
 171   ;; unforutnately, does not have a distinguished type (i.e., it's a SYS:FATAL-ERROR).
 172   ;; So, rather than try to catch the error and signal our condition, we instead
 173   ;; ensure the return value from the PROCESS:WITH-TIMEOUT is never NIL if there is
 174   ;; no timeout. (Sigh)
 175   (let ((result (process:with-timeout (timeout)
 176                   (cons 'success (multiple-value-list (funcall function))))))
 177     (if result
 178         (values-list (cdr result))
 179         (error 'timeout :length timeout))))
 180
 181 ;;; Introspection/debugging
 182
 183 (defun all-threads ()
 184   process:*all-processes*)
 185
 186 (defun interrupt-thread (thread function &rest args)
 187   (declare (dynamic-extent args))
 188   (apply #'process:process-interrupt thread function args))
 189
 190 (defun destroy-thread (thread)
 191   (signal-error-if-current-thread thread)
 192   (process:process-kill thread :force))
 193
 194 (defun thread-alive-p (thread)
 195   (process:process-active-p thread))
 196
 197 (defun join-thread (thread)
 198   (process:process-wait (format nil "Join ~S" thread)
 199                         #'(lambda (thread)
 200                             (not (process:process-active-p thread)))
 201                         thread)
 202   (values-list (si:process-spare-slot-4 thread)))
 203
 204 (mark-supported)