3rdparties/software/bordeaux-threads-v0.8.7/src/impl-mkcl.lisp (2532 bytes)
1 ;;;; -*- indent-tabs-mode: nil -*- 2 3 #| 4 Copyright 2006, 2007 Greg Pfeil 5 Copyright 2010 Jean-Claude Beaudoin. 6 7 Distributed under the MIT license (see LICENSE file) 8 |# 9 10 (in-package #:bordeaux-threads) 11 12 (deftype thread () 13 'mt:thread) 14 15 ;;; Thread Creation 16 17 (defun %make-thread (function name) 18 (mt:thread-run-function name function)) 19 20 (defun current-thread () 21 mt::*thread*) 22 23 (defun threadp (object) 24 (typep object 'mt:thread)) 25 26 (defun thread-name (thread) 27 (mt:thread-name thread)) 28 29 ;;; Resource contention: locks and recursive locks 30 31 (deftype lock () 'mt:lock) 32 33 (deftype recursive-lock () 34 '(and mt:lock (satisfies mt:recursive-lock-p))) 35 36 (defun lock-p (object) 37 (typep object 'mt:lock)) 38 39 (defun recursive-lock-p (object) 40 (and (typep object 'mt:lock) 41 (mt:recursive-lock-p object))) 42 43 (defun make-lock (&optional name) 44 (mt:make-lock :name (or name "Anonymous lock"))) 45 46 (defun acquire-lock (lock &optional (wait-p t)) 47 (mt:get-lock lock wait-p)) 48 49 (defun release-lock (lock) 50 (mt:giveup-lock lock)) 51 52 (defmacro with-lock-held ((place) &body body) 53 `(mt:with-lock (,place) ,@body)) 54 55 (defun make-recursive-lock (&optional name) 56 (mt:make-lock :name (or name "Anonymous recursive lock") :recursive t)) 57 58 (defun acquire-recursive-lock (lock &optional (wait-p t)) 59 (mt:get-lock lock wait-p)) 60 61 (defun release-recursive-lock (lock) 62 (mt:giveup-lock lock)) 63 64 (defmacro with-recursive-lock-held ((place) &body body) 65 `(mt:with-lock (,place) ,@body)) 66 67 ;;; Resource contention: condition variables 68 69 (defun make-condition-variable (&key name) 70 (declare (ignore name)) 71 (mt:make-condition-variable)) 72 73 (defun condition-wait (condition-variable lock &key timeout) 74 (signal-error-if-condition-wait-timeout timeout) 75 (mt:condition-wait condition-variable lock) 76 t) 77 78 (define-condition-wait-compiler-macro) 79 80 (defun condition-notify (condition-variable) 81 (mt:condition-signal condition-variable)) 82 83 (defun thread-yield () 84 (mt:thread-yield)) 85 86 ;;; Introspection/debugging 87 88 (defun all-threads () 89 (mt:all-threads)) 90 91 (defun interrupt-thread (thread function &rest args) 92 (flet ((apply-function () 93 (if args 94 (lambda () (apply function args)) 95 function))) 96 (declare (dynamic-extent #'apply-function)) 97 (mt:interrupt-thread thread (apply-function)))) 98 99 (defun destroy-thread (thread) 100 (signal-error-if-current-thread thread) 101 (mt:thread-kill thread)) 102 103 (defun thread-alive-p (thread) 104 (mt:thread-active-p thread)) 105 106 (defun join-thread (thread) 107 (mt:thread-join thread)) 108 109 (mark-supported)