apiv1/impl-abcl.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 #|
   4 Copyright 2006, 2007 Greg Pfeil
   5
   6 Reimplemented with java.util.concurrent.locks.ReentrantLock by Mark Evenson 2011.
   7
   8 Distributed under the MIT license (see LICENSE file)
   9 |#
  10
  11 (in-package #:bordeaux-threads)
  12
  13 ;;; the implementation of the Armed Bear thread interface can be found in
  14 ;;; src/org/armedbear/lisp/LispThread.java
  15
  16 (deftype thread ()
  17   'threads:thread)
  18
  19 ;;; Thread Creation
  20
  21 (defun %make-thread (function name)
  22   (threads:make-thread function :name name))
  23
  24 (defun current-thread ()
  25   (threads:current-thread))
  26
  27 (defun thread-name (thread)
  28   (threads:thread-name thread))
  29
  30 (defun threadp (object)
  31   (typep object 'thread))
  32
  33 ;;; Resource contention: locks and recursive locks
  34
  35 (defstruct mutex name lock)
  36 (defstruct (mutex-recursive (:include mutex)))
  37
  38 ;; Making methods constants in this manner avoids the runtime expense of
  39 ;; introspection involved in JCALL with string arguments.
  40 (defconstant +lock+
  41   (jmethod "java.util.concurrent.locks.ReentrantLock" "lock"))
  42 (defconstant +try-lock+
  43   (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock"))
  44 (defconstant +is-held-by-current-thread+
  45   (jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread"))
  46 (defconstant +unlock+
  47   (jmethod "java.util.concurrent.locks.ReentrantLock" "unlock"))
  48 (defconstant +get-hold-count+
  49   (jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount"))
  50
  51 (deftype lock () 'mutex)
  52
  53 (deftype recursive-lock () 'mutex-recursive)
  54
  55 (defun lock-p (object)
  56   (typep object 'mutex))
  57
  58 (defun recursive-lock-p (object)
  59   (typep object 'mutex-recursive))
  60
  61 (defun make-lock (&optional name)
  62   (make-mutex
  63    :name (or name "Anonymous lock")
  64    :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
  65
  66 (defun acquire-lock (lock &optional (wait-p t))
  67   (check-type lock mutex)
  68   (when (jcall +is-held-by-current-thread+ (mutex-lock lock))
  69     (error "Non-recursive lock being reacquired by owner."))
  70   (cond
  71     (wait-p
  72      (jcall +lock+ (mutex-lock lock))
  73      t)
  74     (t (jcall +try-lock+ (mutex-lock lock)))))
  75
  76 (defun release-lock (lock)
  77   (check-type lock mutex)
  78   (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
  79     (error "Attempt to release lock not held by calling thread."))
  80   (jcall +unlock+ (mutex-lock lock))
  81   (values))
  82
  83 (defun make-recursive-lock (&optional name)
  84   (make-mutex-recursive
  85    :name (or name "Anonymous lock")
  86    :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
  87
  88 (defun acquire-recursive-lock (lock &optional (wait-p t))
  89   (check-type lock mutex-recursive)
  90   (cond
  91     (wait-p
  92      (jcall +lock+ (mutex-recursive-lock lock))
  93      t)
  94     (t (jcall +try-lock+ (mutex-recursive-lock lock)))))
  95
  96 (defun release-recursive-lock (lock)
  97   (check-type lock mutex-recursive)
  98   (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
  99     (error "Attempt to release lock not held by calling thread."))
 100   (jcall +unlock+ (mutex-lock lock))
 101   (values))
 102
 103 ;;; Resource contention: condition variables
 104
 105 (defun thread-yield ()
 106   (java:jstatic "yield" "java.lang.Thread"))
 107
 108 (defstruct condition-variable
 109   (name "Anonymous condition variable"))
 110
 111 (defun condition-wait (condition lock &key timeout)
 112   (threads:synchronized-on condition
 113     (release-lock lock)
 114     (if timeout
 115         ;; Since giving a zero time value to threads:object-wait means
 116         ;; an indefinite wait, use some arbitrary small number.
 117         (threads:object-wait condition
 118                              (if (zerop timeout)
 119                                  least-positive-single-float
 120                                  timeout))
 121         (threads:object-wait condition)))
 122   (acquire-lock lock)
 123   t)
 124
 125 (defun condition-notify (condition)
 126   (threads:synchronized-on condition
 127      (threads:object-notify condition)))
 128
 129 ;;; Introspection/debugging
 130
 131 (defun all-threads ()
 132   (let ((threads ()))
 133     (threads:mapcar-threads (lambda (thread)
 134                               (push thread threads)))
 135     (reverse threads)))
 136
 137 (defun interrupt-thread (thread function &rest args)
 138   (apply #'threads:interrupt-thread thread function args))
 139
 140 (defun destroy-thread (thread)
 141   (signal-error-if-current-thread thread)
 142   (threads:destroy-thread thread))
 143
 144 (defun thread-alive-p (thread)
 145   (threads:thread-alive-p thread))
 146
 147 (defun join-thread (thread)
 148   (threads:thread-join thread))
 149
 150 (mark-supported)