apiv2/impl-sbcl.lisp

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