apiv2/impl-abcl.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 (in-package :bordeaux-threads-2)
   4
   5 ;;;
   6 ;;; Threads
   7 ;;;
   8
   9 (deftype native-thread ()
  10   'threads:thread)
  11
  12 (defun %make-thread (function name)
  13   (threads:make-thread function :name name))
  14
  15 (defun %current-thread ()
  16   (threads:current-thread))
  17
  18 (defun %thread-name (thread)
  19   (threads:thread-name thread))
  20
  21 (defun %join-thread (thread)
  22   (threads:thread-join thread))
  23
  24 (defun %thread-yield ()
  25   (java:jstatic "yield" "java.lang.Thread"))
  26
  27 ;;;
  28 ;;; Introspection/debugging
  29 ;;;
  30
  31 (defun %all-threads ()
  32   (let ((threads ()))
  33     (threads:mapcar-threads (lambda (thread)
  34                               (push thread threads)))
  35     (nreverse threads)))
  36
  37 (defun %interrupt-thread (thread function)
  38   (threads:interrupt-thread thread function))
  39
  40 (defun %destroy-thread (thread)
  41   (threads:destroy-thread thread))
  42
  43 (defun %thread-alive-p (thread)
  44   (threads:thread-alive-p thread))
  45 \f
  46
  47 ;;;
  48 ;;; Non-recursive locks.
  49 ;;;
  50
  51 (defstruct mutex name lock)
  52
  53 (deftype native-lock () 'mutex)
  54
  55 (defun %make-lock (name)
  56   (make-mutex
  57    :name name
  58    :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
  59
  60 ;; Making methods constants in this manner avoids the runtime expense of
  61 ;; introspection involved in JCALL with string arguments.
  62 (defconstant +lock+
  63   (jmethod "java.util.concurrent.locks.ReentrantLock" "lock"))
  64 (defconstant +try-lock+
  65   (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock"))
  66 (defconstant +try-lock-timeout+
  67   (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock"
  68            (jclass "long") (jclass "java.util.concurrent.TimeUnit")))
  69 (defconstant +is-held-by-current-thread+
  70   (jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread"))
  71 (defconstant +unlock+
  72   (jmethod "java.util.concurrent.locks.ReentrantLock" "unlock"))
  73 (defconstant +get-hold-count+
  74   (jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount"))
  75 (defconstant +microseconds+
  76   (java:jfield "java.util.concurrent.TimeUnit" "MICROSECONDS"))
  77
  78 (defun timeout-to-microseconds (timeout)
  79   (truncate (* timeout 1000000)))
  80
  81 (defun %acquire-lock (lock waitp timeout)
  82   (check-type lock mutex)
  83   (when (jcall +is-held-by-current-thread+ (mutex-lock lock))
  84     (bt-error "Non-recursive lock being reacquired by owner."))
  85   (cond
  86     (waitp
  87      (if timeout
  88          (jcall +try-lock-timeout+
  89                 (mutex-lock lock)
  90                 (timeout-to-microseconds timeout)
  91                 +microseconds+)
  92          (progn (jcall +lock+ (mutex-lock lock)) t)))
  93     (t (jcall +try-lock+ (mutex-lock lock)))))
  94
  95 (defun %release-lock (lock)
  96   (check-type lock mutex)
  97   (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
  98     (bt-error "Attempt to release lock not held by calling thread."))
  99   (jcall +unlock+ (mutex-lock lock)))
 100
 101 ;;;
 102 ;;; Recursive locks
 103 ;;;
 104
 105 (defstruct (mutex-recursive (:include mutex)))
 106
 107 (deftype native-recursive-lock () 'mutex-recursive)
 108
 109 (defun %make-recursive-lock (name)
 110   (make-mutex-recursive
 111    :name name
 112    :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
 113
 114 (defun %acquire-recursive-lock (lock waitp timeout)
 115   (check-type lock mutex-recursive)
 116   (cond
 117     (waitp
 118      (if timeout
 119          (jcall +try-lock-timeout+
 120                 (mutex-recursive-lock lock)
 121                 (timeout-to-microseconds timeout)
 122                 +microseconds+)
 123          (progn (jcall +lock+ (mutex-recursive-lock lock)) t)))
 124     (t (jcall +try-lock+ (mutex-recursive-lock lock)))))
 125
 126 (defun %release-recursive-lock (lock)
 127   (check-type lock mutex-recursive)
 128   (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
 129     (error 'bordeaux-threads-error
 130            :message "Attempt to release lock not held by calling thread."))
 131   (jcall +unlock+ (mutex-lock lock)))
 132 \f
 133
 134 ;;;
 135 ;;; Semaphores
 136 ;;;
 137
 138 (defstruct (semaphore
 139             (:constructor %%make-semaphore (name cell)))
 140   "Wrapper for java.util.concurrent.Semaphore."
 141   name cell)
 142
 143 (defconstant +semaphore-count+
 144   (jmethod "java.util.concurrent.Semaphore" "availablePermits"))
 145
 146 (defun %semaphore-count (semaphore)
 147   (jcall +semaphore-count+ (semaphore-cell semaphore)))
 148
 149 (defmethod print-object ((sem semaphore) stream)
 150   (print-unreadable-object (sem stream :type t :identity t)
 151     (format stream "~S count: ~S" (semaphore-name sem)
 152             (%semaphore-count sem))))
 153
 154 (defun %make-semaphore (name count)
 155   (check-type count unsigned-byte)
 156   (%%make-semaphore
 157    name
 158    (jnew "java.util.concurrent.Semaphore" count t)))
 159
 160 (defconstant +semaphore-release+
 161   (jmethod "java.util.concurrent.Semaphore" "release"
 162            (jclass "int")))
 163
 164 (defun %signal-semaphore (semaphore count)
 165   (jcall +semaphore-release+ (semaphore-cell semaphore) count))
 166
 167 (defconstant +semaphore-acquire+
 168   (jmethod "java.util.concurrent.Semaphore" "acquire"))
 169
 170 (defconstant +semaphore-try-acquire+
 171   (jmethod "java.util.concurrent.Semaphore" "tryAcquire"
 172            (jclass "long") (jclass "java.util.concurrent.TimeUnit")))
 173
 174 (defun %wait-on-semaphore (semaphore timeout)
 175   ;; TODO: handle thread interruption.
 176   (cond
 177     ((null timeout)
 178      (jcall +semaphore-acquire+ (semaphore-cell semaphore))
 179      t)
 180     (t
 181      (jcall +semaphore-try-acquire+
 182             (semaphore-cell semaphore)
 183             (timeout-to-microseconds timeout)
 184             +microseconds+))))
 185 \f
 186
 187 ;;;
 188 ;;; Condition variables
 189 ;;;
 190
 191 (defstruct (condition-variable
 192             (:constructor %make-condition-variable (name)))
 193   name)
 194
 195 (defun %condition-wait (cv lock timeout)
 196   (threads:synchronized-on cv
 197     (%release-lock lock)
 198     (if timeout
 199         ;; Since giving a zero time value to threads:object-wait means
 200         ;; an indefinite wait, use some arbitrary small number.
 201         (threads:object-wait cv
 202                              (if (zerop timeout)
 203                                  least-positive-single-float
 204                                  timeout))
 205         (threads:object-wait cv)))
 206   (%acquire-lock lock t nil)
 207   t)
 208
 209 (defun %condition-notify (cv)
 210   (threads:synchronized-on cv
 211      (threads:object-notify cv)))
 212
 213 (defun %condition-broadcast (cv)
 214   (threads:synchronized-on cv
 215      (threads:object-notify-all cv)))