3rdparties/software/bordeaux-threads-v0.8.7/src/impl-sbcl.lisp (3462 bytes)
1 ;;;; -*- indent-tabs-mode: nil -*- 2 3 #| 4 Copyright 2006, 2007 Greg Pfeil 5 6 Distributed under the MIT license (see LICENSE file) 7 |# 8 9 (in-package #:bordeaux-threads) 10 11 ;;; documentation on the SBCL Threads interface can be found at 12 ;;; http://www.sbcl.org/manual/Threading.html 13 14 (deftype thread () 15 'sb-thread:thread) 16 17 ;;; Thread Creation 18 19 (defun %make-thread (function name) 20 (sb-thread:make-thread function :name name)) 21 22 (defun current-thread () 23 sb-thread:*current-thread*) 24 25 (defun threadp (object) 26 (typep object 'sb-thread:thread)) 27 28 (defun thread-name (thread) 29 (sb-thread:thread-name thread)) 30 31 ;;; Resource contention: locks and recursive locks 32 33 (deftype lock () 'sb-thread:mutex) 34 35 (deftype recursive-lock () 'sb-thread:mutex) 36 37 (defun lock-p (object) 38 (typep object 'sb-thread:mutex)) 39 40 (defun recursive-lock-p (object) 41 (typep object 'sb-thread:mutex)) 42 43 (defun make-lock (&optional name) 44 (sb-thread:make-mutex :name (or name "Anonymous lock"))) 45 46 (defun acquire-lock (lock &optional (wait-p t)) 47 #+#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or)) 48 (sb-thread:grab-mutex lock :waitp wait-p) 49 #-#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or)) 50 (sb-thread:get-mutex lock nil wait-p)) 51 52 (defun release-lock (lock) 53 (sb-thread:release-mutex lock)) 54 55 (defmacro with-lock-held ((place) &body body) 56 `(sb-thread:with-mutex (,place) ,@body)) 57 58 (defun make-recursive-lock (&optional name) 59 (sb-thread:make-mutex :name (or name "Anonymous recursive lock"))) 60 61 ;;; XXX acquire-recursive-lock and release-recursive-lock are actually 62 ;;; complicated because we can't use control stack tricks. We need to 63 ;;; actually count something to check that the acquire/releases are 64 ;;; balanced 65 66 (defmacro with-recursive-lock-held ((place) &body body) 67 `(sb-thread:with-recursive-lock (,place) 68 ,@body)) 69 70 ;;; Resource contention: condition variables 71 72 (defun make-condition-variable (&key name) 73 (sb-thread:make-waitqueue :name (or name "Anonymous condition variable"))) 74 75 (defun condition-wait (condition-variable lock &key timeout) 76 (sb-thread:condition-wait condition-variable lock :timeout timeout)) 77 78 (defun condition-notify (condition-variable) 79 (sb-thread:condition-notify condition-variable)) 80 81 (defun thread-yield () 82 (sb-thread:release-foreground)) 83 84 ;;; Timeouts 85 86 (deftype timeout () 87 'sb-ext:timeout) 88 89 (defmacro with-timeout ((timeout) &body body) 90 `(sb-ext:with-timeout ,timeout 91 ,@body)) 92 93 ;;; Semaphores 94 95 (deftype semaphore () 96 'sb-thread:semaphore) 97 98 (defun make-semaphore (&key name (count 0)) 99 (sb-thread:make-semaphore :name name :count count)) 100 101 (defun signal-semaphore (semaphore &key (count 1)) 102 (sb-thread:signal-semaphore semaphore count)) 103 104 (defun wait-on-semaphore (semaphore &key timeout) 105 (sb-thread:wait-on-semaphore semaphore :timeout timeout)) 106 107 ;;; Introspection/debugging 108 109 (defun all-threads () 110 (sb-thread:list-all-threads)) 111 112 (defun interrupt-thread (thread function &rest args) 113 (flet ((apply-function () 114 (if args 115 (lambda () (apply function args)) 116 function))) 117 (declare (dynamic-extent #'apply-function)) 118 (sb-thread:interrupt-thread thread (apply-function)))) 119 120 (defun destroy-thread (thread) 121 (signal-error-if-current-thread thread) 122 (sb-thread:terminate-thread thread)) 123 124 (defun thread-alive-p (thread) 125 (sb-thread:thread-alive-p thread)) 126 127 (defun join-thread (thread) 128 (sb-thread:join-thread thread)) 129 130 (mark-supported)