apiv2/impl-ecl.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 (in-package :bordeaux-threads-2)
   4
   5 ;;;
   6 ;;; Threads
   7 ;;;
   8
   9 (deftype native-thread ()
  10   'mp:process)
  11
  12 (defun %make-thread (function name)
  13   (mp:process-run-function name function))
  14
  15 (defun %current-thread ()
  16   mp:*current-process*)
  17
  18 (defun %thread-name (thread)
  19   ;; Some system threads have symbols for a name.
  20   (string (mp:process-name thread)))
  21
  22 (defun %join-thread (thread)
  23   (mp:process-join thread))
  24
  25 (defun %thread-yield ()
  26   (mp:process-yield))
  27
  28 ;;;
  29 ;;; Introspection/debugging
  30 ;;;
  31
  32 (defun %all-threads ()
  33   (mp:all-processes))
  34
  35 (defun %interrupt-thread (thread function)
  36   (mp:interrupt-process thread function))
  37
  38 (defun %destroy-thread (thread)
  39   (mp:process-kill thread))
  40
  41 (defun %thread-alive-p (thread)
  42   (mp:process-active-p thread))
  43 \f
  44
  45 ;;;
  46 ;;; Non-recursive locks
  47 ;;;
  48
  49 (deftype native-lock () 'mp:lock)
  50
  51 (defun %make-lock (name)
  52   (mp:make-lock :name name))
  53
  54 (mark-not-implemented 'acquire-lock :timeout)
  55 (defun %acquire-lock (lock waitp timeout)
  56   (when timeout
  57     (signal-not-implemented 'acquire-lock :timeout))
  58   (mp:get-lock lock waitp))
  59
  60 (defun %release-lock (lock)
  61   (mp:giveup-lock lock))
  62
  63 (mark-not-implemented 'with-lock-held :timeout)
  64 (defmacro %with-lock ((place timeout) &body body)
  65   (if timeout
  66       `(signal-not-implemented 'with-lock-held :timeout)
  67       `(mp:with-lock (,place) ,@body)))
  68
  69 ;;;
  70 ;;; Recursive locks
  71 ;;;
  72
  73 (deftype native-recursive-lock ()
  74   '(and mp:lock (satisfies mp:recursive-lock-p)))
  75
  76 (defun %make-recursive-lock (name)
  77   (mp:make-lock :name name :recursive t))
  78
  79 (mark-not-implemented 'acquire-recursive-lock :timeout)
  80 (defun %acquire-recursive-lock (lock waitp timeout)
  81   (when timeout
  82     (signal-not-implemented 'acquire-recursive-lock :timeout))
  83   (mp:get-lock lock waitp))
  84
  85 (defun %release-recursive-lock (lock)
  86   (mp:giveup-lock lock))
  87
  88 (mark-not-implemented 'with-recursive-lock-held :timeout)
  89 (defmacro %with-recursive-lock ((place timeout) &body body)
  90   (if timeout
  91       `(signal-not-implemented 'with-recursive-lock-held :timeout)
  92       `(mp:with-lock (,place) ,@body)))
  93 \f
  94
  95 ;;;
  96 ;;; Semaphores
  97 ;;;
  98
  99 (deftype semaphore () 'mp:semaphore)
 100
 101 (defun %make-semaphore (name count)
 102   (mp:make-semaphore :name name :count count))
 103
 104 (defun %signal-semaphore (semaphore count)
 105   (mp:signal-semaphore semaphore count))
 106
 107 (defun %wait-on-semaphore (semaphore timeout)
 108   (cond
 109     ((null timeout)
 110      (mp:wait-on-semaphore semaphore)
 111      t)
 112     ((plusp timeout)
 113      (handler-case
 114          (with-timeout (timeout)
 115            (mp:wait-on-semaphore semaphore)
 116            t)
 117        (timeout () nil)))
 118     (t
 119      (if (mp:try-get-semaphore semaphore) t nil))))
 120 \f
 121
 122 ;;;
 123 ;;; Condition variables
 124 ;;;
 125
 126 (deftype condition-variable ()
 127   'mp:condition-variable)
 128
 129 (defun %make-condition-variable ( name)
 130   (declare (ignore name))
 131   (mp:make-condition-variable))
 132
 133 (defun %condition-wait (cv lock timeout)
 134   (if timeout
 135       (handler-case
 136           (with-timeout (timeout)
 137             (mp:condition-variable-wait cv lock))
 138         (timeout ()
 139           (%acquire-lock lock t nil)
 140           nil))
 141       (mp:condition-variable-wait cv lock)))
 142
 143 (defun %condition-notify (cv)
 144   (mp:condition-variable-signal cv))
 145
 146 (defun %condition-broadcast (cv)
 147   (mp:condition-variable-broadcast cv))