3rdparties/software/bordeaux-threads-v0.8.7/src/impl-abcl.lisp (4319 bytes)
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)