apiv2/impl-mezzano.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 (in-package :bordeaux-threads-2)
   4
   5 ;;;
   6 ;;; Threads
   7 ;;;
   8
   9 (deftype native-thread ()
  10   'mezzano.supervisor:thread)
  11
  12 (defun %make-thread (function name)
  13   (mezzano.supervisor:make-thread function :name name))
  14
  15 (defun %current-thread ()
  16   (mezzano.supervisor:current-thread))
  17
  18 (defun %thread-name (thread)
  19   (mezzano.supervisor:thread-name thread))
  20
  21 (defun %join-thread (thread)
  22   ;; THREAD-JOIN can return non-lists if the thread was destroyed.
  23   (let ((values (mezzano.supervisor:thread-join thread)))
  24     (if (listp values)
  25         (values-list values)
  26         nil)))
  27
  28 (defun %thread-yield ()
  29   (mezzano.supervisor:thread-yield))
  30
  31 ;;;
  32 ;;; Introspection/debugging
  33 ;;;
  34
  35 (defun %all-threads ()
  36   (mezzano.supervisor:all-threads))
  37
  38 (defun %interrupt-thread (thread function)
  39   (mezzano.supervisor:establish-thread-foothold thread function))
  40
  41 (defun %destroy-thread (thread)
  42   (mezzano.supervisor:terminate-thread thread))
  43
  44 (defun %thread-alive-p (thread)
  45   (not (eql (mezzano.supervisor:thread-state thread) :dead)))
  46 \f
  47
  48 ;;;
  49 ;;; Non-recursive locks
  50 ;;;
  51
  52 (deftype native-lock () 'mezzano.supervisor:mutex)
  53
  54 (defun %make-lock (name)
  55   (mezzano.supervisor:make-mutex name))
  56
  57 (mark-not-implemented 'acquire-lock :timeout)
  58 (defun %acquire-lock (lock waitp timeout)
  59   (when timeout
  60     (signal-not-implemented 'acquire-lock :timeout))
  61   (mezzano.supervisor:acquire-mutex lock waitp))
  62
  63 (defun %release-lock (lock)
  64   (mezzano.supervisor:release-mutex lock))
  65
  66 (mark-not-implemented 'with-lock-held :timeout)
  67 (defmacro %with-lock ((place timeout) &body body)
  68   (if timeout
  69       `(signal-not-implemented 'with-lock-held :timeout)
  70       `(mezzano.supervisor:with-mutex (,place) ,@body)))
  71
  72 ;;;
  73 ;;; Recursive locks
  74 ;;;
  75
  76 (defstruct (%recursive-lock
  77              (:constructor %make-recursive-lock-internal (mutex)))
  78   mutex
  79   (depth 0))
  80
  81 (deftype native-recursive-lock () '%recursive-lock)
  82
  83 (defun %make-recursive-lock (name)
  84   (%make-recursive-lock-internal (%make-lock name)))
  85
  86 (mark-not-implemented 'acquire-recursive-lock)
  87 (defun %acquire-recursive-lock (lock waitp timeout)
  88   (declare (ignore lock waitp timeout))
  89   (signal-not-implemented 'acquire-recursive-lock))
  90
  91 (release-not-implemented 'release-recursive-lock)
  92 (defun %release-recursive-lock (lock)
  93   (declare (ignore lock))
  94   (signal-not-implemented 'release-recursive-lock))
  95
  96 (defun call-with-recursive-lock-held (lock function)
  97   (cond ((mezzano.supervisor:mutex-held-p
  98           (%recursive-lock-mutex lock))
  99          (unwind-protect
 100               (progn (incf (%recursive-lock-depth lock))
 101                      (funcall function))
 102            (decf (%recursive-lock-depth lock))))
 103         (t
 104          (mezzano.supervisor:with-mutex ((%recursive-lock-mutex lock))
 105            (multiple-value-prog1
 106                (funcall function)
 107              (assert (zerop (%recursive-lock-depth lock))))))))
 108
 109 (mark-not-implemented 'with-recursive-lock-held :timeout)
 110 (defmacro %with-recursive-lock ((place timeout) &body body)
 111   (if timeout
 112       `(signal-not-implemented 'with-recursive-lock-held :timeout)
 113       `(call-with-recursive-lock-held ,place (lambda () ,@body))))
 114 \f
 115
 116 ;;;
 117 ;;; Semaphores
 118 ;;;
 119
 120 (deftype semaphore ()
 121   'mezzano.sync:semaphore)
 122
 123 (defun %make-semaphore (name count)
 124   (mezzano.sync:make-semaphore :name name :value count))
 125
 126 (defun %signal-semaphore (semaphore count)
 127   (dotimes (c count) (mezzano.sync:semaphore-up semaphore)))
 128
 129 (defun %wait-on-semaphore (semaphore timeout)
 130   (mezzano.supervisor:event-wait-for (semaphore :timeout timeout)
 131     (mezzano.sync:semaphore-down semaphore :wait-p nil)))
 132 \f
 133
 134 ;;;
 135 ;;; Condition variables
 136 ;;;
 137
 138 (deftype condition-variable ()
 139   'mezzano.supervisor:condition-variable)
 140
 141 (defun %make-condition-variable (name)
 142   (mezzano.supervisor:make-condition-variable name))
 143
 144 (defun %condition-wait (cv lock timeout)
 145   (mezzano.supervisor:condition-wait cv lock timeout))
 146
 147 (defun %condition-notify (cv)
 148   (mezzano.supervisor:condition-notify cv))
 149
 150 (mark-not-implemented 'condition-broadcast)
 151 (defun %condition-broadcast (cv)
 152   (declare (ignore cv))
 153   (signal-not-implemented 'condition-broadcast))