src/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 (defun make-lock (&optional name)
  52   (make-mutex
  53    :name (or name "Anonymous lock")
  54    :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
  55
  56 (defun acquire-lock (lock &optional (wait-p t))
  57   (check-type lock mutex)
  58   (when (jcall +is-held-by-current-thread+ (mutex-lock lock))
  59     (error "Non-recursive lock being reacquired by owner."))
  60   (cond
  61     (wait-p
  62      (jcall +lock+ (mutex-lock lock))
  63      t)
  64     (t (jcall +try-lock+ (mutex-lock lock)))))
  65
  66 (defun release-lock (lock)
  67   (check-type lock mutex)
  68   (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
  69     (error "Attempt to release lock not held by calling thread."))
  70   (jcall +unlock+ (mutex-lock lock))
  71   (values))
  72
  73 (defun make-recursive-lock (&optional name)
  74   (make-mutex-recursive
  75    :name (or name "Anonymous lock")
  76    :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
  77
  78 (defun acquire-recursive-lock (lock &optional (wait-p t))
  79   (check-type lock mutex-recursive)
  80   (cond
  81     (wait-p
  82      (jcall +lock+ (mutex-recursive-lock lock))
  83      t)
  84     (t (jcall +try-lock+ (mutex-recursive-lock lock)))))
  85
  86 (defun release-recursive-lock (lock)
  87   (check-type lock mutex-recursive)
  88   (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
  89     (error "Attempt to release lock not held by calling thread."))
  90   (jcall +unlock+ (mutex-lock lock))
  91   (values))
  92
  93 ;;; Resource contention: condition variables
  94
  95 (defun thread-yield ()
  96   (sleep 0.01))
  97
  98 (defstruct condition-variable
  99   (name "Anonymous condition variable"))
 100
 101 (defun condition-wait (condition lock)
 102   (threads:synchronized-on condition
 103     (release-lock lock)
 104     (threads:object-wait condition))
 105   (acquire-lock lock))
 106
 107 (defun condition-notify (condition)
 108   (threads:synchronized-on condition
 109      (threads:object-notify condition)))
 110
 111 ;;; Introspection/debugging
 112
 113 (defun all-threads ()
 114   (let ((threads ()))
 115     (threads:mapcar-threads (lambda (thread)
 116                               (push thread threads)))
 117     (reverse threads)))
 118
 119 (defun interrupt-thread (thread function &rest args)
 120   (apply #'threads:interrupt-thread thread function args))
 121
 122 (defun destroy-thread (thread)
 123   (signal-error-if-current-thread thread)
 124   (threads:destroy-thread thread))
 125
 126 (defun thread-alive-p (thread)
 127   (threads:thread-alive-p thread))
 128
 129 (defun join-thread (thread)
 130   (threads:thread-join thread))
 131
 132 (mark-supported)