apiv2/impl-ecl.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 (in-package :bordeaux-threads-2)
   4
   5 (eval-when (:compile-toplevel :execute)
   6   (when (>= ext:+ecl-version-number+ 230909)
   7     (pushnew :has-timeouts *features*)))
   8
   9 ;;;
  10 ;;; Threads
  11 ;;;
  12
  13 (deftype native-thread ()
  14   'mp:process)
  15
  16 (defun %make-thread (function name)
  17   (mp:process-run-function name function))
  18
  19 (defun %current-thread ()
  20   mp:*current-process*)
  21
  22 (defun %thread-name (thread)
  23   ;; Some system threads have symbols for a name.
  24   (string (mp:process-name thread)))
  25
  26 (defun %join-thread (thread)
  27   (mp:process-join thread))
  28
  29 (defun %thread-yield ()
  30   (mp:process-yield))
  31
  32 ;;;
  33 ;;; Introspection/debugging
  34 ;;;
  35
  36 (defun %all-threads ()
  37   (mp:all-processes))
  38
  39 (defun %interrupt-thread (thread function)
  40   (mp:interrupt-process thread function))
  41
  42 (defun %destroy-thread (thread)
  43   (mp:process-kill thread))
  44
  45 (defun %thread-alive-p (thread)
  46   (mp:process-active-p thread))
  47 \f
  48
  49 ;;;
  50 ;;; Non-recursive locks
  51 ;;;
  52
  53 (deftype native-lock () 'mp:lock)
  54
  55 (defun %make-lock (name)
  56   (mp:make-lock :name name))
  57
  58 #-has-timeouts
  59 (progn
  60   (mark-not-implemented 'acquire-lock :timeout)
  61   (defun %acquire-lock (lock waitp timeout)
  62     (when timeout
  63       (signal-not-implemented 'acquire-lock :timeout))
  64     (mp:get-lock lock waitp)))
  65
  66 #+has-timeouts
  67 (defun %acquire-lock (lock waitp timeout)
  68   (mp:get-lock lock (cond ((not waitp) nil)
  69                           (timeout timeout)
  70                           (t t))))
  71
  72 (defun %release-lock (lock)
  73   (mp:giveup-lock lock))
  74
  75 #-has-timeouts
  76 (progn
  77   (mark-not-implemented 'with-lock-held :timeout)
  78   (defmacro %with-lock ((place timeout) &body body)
  79     (if timeout
  80         `(signal-not-implemented 'with-lock-held :timeout)
  81         `(mp:with-lock (,place) ,@body))))
  82
  83 #+has-timeouts
  84 (defmacro %with-lock ((place timeout) &body body)
  85   `(mp:with-lock (,place :wait-form (or ,timeout t))
  86      ,@body))
  87
  88 ;;;
  89 ;;; Recursive locks
  90 ;;;
  91
  92 (deftype native-recursive-lock ()
  93   '(and mp:lock (satisfies mp:recursive-lock-p)))
  94
  95 (defun %make-recursive-lock (name)
  96   (mp:make-lock :name name :recursive t))
  97
  98 #-has-timeouts
  99 (progn
 100   (mark-not-implemented 'acquire-recursive-lock :timeout)
 101   (defun %acquire-recursive-lock (lock waitp timeout)
 102     (when timeout
 103       (signal-not-implemented 'acquire-recursive-lock :timeout))
 104     (mp:get-lock lock waitp)))
 105
 106 #+has-timeouts
 107 (defun %acquire-recursive-lock (lock waitp timeout)
 108   (mp:get-lock lock (cond ((not waitp) nil)
 109                           (timeout timeout)
 110                           (t t))))
 111
 112 (defun %release-recursive-lock (lock)
 113   (mp:giveup-lock lock))
 114
 115 #-has-timeouts
 116 (progn
 117   (mark-not-implemented 'with-recursive-lock-held :timeout)
 118   (defmacro %with-recursive-lock ((place timeout) &body body)
 119     (if timeout
 120         `(signal-not-implemented 'with-recursive-lock-held :timeout)
 121         `(mp:with-lock (,place) ,@body))))
 122
 123 #+has-timeouts
 124 (defmacro %with-recursive-lock ((place timeout) &body body)
 125   `(mp:with-lock (,place :wait-form (or ,timeout t))
 126      ,@body))
 127 \f
 128
 129 ;;;
 130 ;;; Semaphores
 131 ;;;
 132
 133 (deftype semaphore () 'mp:semaphore)
 134
 135 (defun %make-semaphore (name count)
 136   (mp:make-semaphore :name name :count count))
 137
 138 (defun %signal-semaphore (semaphore count)
 139   (mp:signal-semaphore semaphore count))
 140
 141 (defun %wait-on-semaphore (semaphore timeout)
 142   (cond
 143     ((null timeout)
 144      (mp:wait-on-semaphore semaphore)
 145      t)
 146     ((plusp timeout)
 147      #-has-timeouts
 148      (handler-case
 149          (with-timeout (timeout)
 150            (mp:wait-on-semaphore semaphore)
 151            t)
 152        (timeout () nil))
 153      #+has-timeouts
 154      (mp:semaphore-wait semaphore 1 timeout))
 155     (t
 156      (if (mp:try-get-semaphore semaphore) t nil))))
 157 \f
 158
 159 ;;;
 160 ;;; Condition variables
 161 ;;;
 162
 163 (deftype condition-variable ()
 164   'mp:condition-variable)
 165
 166 (defun %make-condition-variable ( name)
 167   (declare (ignore name))
 168   (mp:make-condition-variable))
 169
 170 (defun %condition-wait (cv lock timeout)
 171   (if timeout
 172       #-has-timeouts
 173       (handler-case
 174           (with-timeout (timeout)
 175             (mp:condition-variable-wait cv lock))
 176         (timeout ()
 177           (%acquire-lock lock t nil)
 178           nil))
 179       #+has-timeouts
 180       (mp:condition-variable-timedwait cv lock timeout)
 181       (mp:condition-variable-wait cv lock)))
 182
 183 (defun %condition-notify (cv)
 184   (mp:condition-variable-signal cv))
 185
 186 (defun %condition-broadcast (cv)
 187   (mp:condition-variable-broadcast cv))
 188
 189 (eval-when (:compile-toplevel :execute)
 190   (setf *features* (remove :has-timeouts *features*)))