3rdparties/software/bordeaux-threads-v0.8.7/src/impl-scl.lisp (2681 bytes)
1 ;;;; -*- indent-tabs-mode: nil -*- 2 3 #| 4 Copyright 2008 Scieneer Pty Ltd 5 6 Distributed under the MIT license (see LICENSE file) 7 |# 8 9 (in-package #:bordeaux-threads) 10 11 (deftype thread () 12 'thread:thread) 13 14 (defun %make-thread (function name) 15 (thread:thread-create function :name name)) 16 17 (defun current-thread () 18 thread:*thread*) 19 20 (defun threadp (object) 21 (typep object 'thread:thread)) 22 23 (defun thread-name (thread) 24 (thread:thread-name thread)) 25 26 ;;; Resource contention: locks and recursive locks 27 28 (deftype lock () 'thread:lock) 29 30 (deftype recursive-lock () 'thread:recursive-lock) 31 32 (defun lock-p (object) 33 (typep object 'thread:lock)) 34 35 (defun recursive-lock-p (object) 36 (typep object 'thread:recursive-lock)) 37 38 (defun make-lock (&optional name) 39 (thread:make-lock (or name "Anonymous lock"))) 40 41 (defun acquire-lock (lock &optional (wait-p t)) 42 (thread::acquire-lock lock nil wait-p)) 43 44 (defun release-lock (lock) 45 (thread::release-lock lock)) 46 47 (defmacro with-lock-held ((place) &body body) 48 `(thread:with-lock-held (,place) ,@body)) 49 50 (defun make-recursive-lock (&optional name) 51 (thread:make-lock (or name "Anonymous recursive lock") 52 :type :recursive)) 53 54 ;;; XXX acquire-recursive-lock and release-recursive-lock are actually 55 ;;; complicated because we can't use control stack tricks. We need to 56 ;;; actually count something to check that the acquire/releases are 57 ;;; balanced 58 59 (defmacro with-recursive-lock-held ((place) &body body) 60 `(thread:with-lock-held (,place) 61 ,@body)) 62 63 ;;; Resource contention: condition variables 64 65 (defun make-condition-variable (&key name) 66 (thread:make-cond-var (or name "Anonymous condition variable"))) 67 68 (defun condition-wait (condition-variable lock &key timeout) 69 (if timeout 70 (thread:cond-var-timedwait condition-variable lock timeout) 71 (thread:cond-var-wait condition-variable lock)) 72 t) 73 74 (defun condition-notify (condition-variable) 75 (thread:cond-var-broadcast condition-variable)) 76 77 (defun thread-yield () 78 (mp:process-yield)) 79 80 ;;; Introspection/debugging 81 82 (defun all-threads () 83 (mp:all-processes)) 84 85 (defun interrupt-thread (thread function &rest args) 86 (flet ((apply-function () 87 (if args 88 (lambda () (apply function args)) 89 function))) 90 (declare (dynamic-extent #'apply-function)) 91 (thread:thread-interrupt thread (apply-function)))) 92 93 (defun destroy-thread (thread) 94 (thread:destroy-thread thread)) 95 96 (defun thread-alive-p (thread) 97 (mp:process-alive-p thread)) 98 99 (defun join-thread (thread) 100 (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) 101 (lambda () (not (mp:process-alive-p thread))))) 102 103 (mark-supported)