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