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