3rdparties/software/bordeaux-threads-v0.8.7/src/impl-clisp.lisp (2662 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 (deftype thread () 12 'mt:thread) 13 14 ;;; Thread Creation 15 (defun %make-thread (function name) 16 (mt:make-thread function 17 :name name 18 :initial-bindings mt:*default-special-bindings*)) 19 20 (defun current-thread () 21 (mt:current-thread)) 22 23 (defun threadp (object) 24 (mt:threadp object)) 25 26 (defun thread-name (thread) 27 (mt:thread-name thread)) 28 29 ;;; Resource contention: locks and recursive locks 30 31 (deftype lock () 'mt:mutex) 32 33 (deftype recursive-lock () 34 '(and mt:mutex (satisfies mt:mutex-recursive-p))) 35 36 (defun lock-p (object) 37 (typep object 'mt:mutex)) 38 39 (defun recursive-lock-p (object) 40 (and (typep object 'mt:mutex) 41 (mt:mutex-recursive-p object))) 42 43 (defun make-lock (&optional name) 44 (mt:make-mutex :name (or name "Anonymous lock"))) 45 46 (defun acquire-lock (lock &optional (wait-p t)) 47 (mt:mutex-lock lock :timeout (if wait-p nil 0))) 48 49 (defun release-lock (lock) 50 (mt:mutex-unlock lock)) 51 52 (defmacro with-lock-held ((place) &body body) 53 `(mt:with-mutex-lock (,place) ,@body)) 54 55 (defun make-recursive-lock (&optional name) 56 (mt:make-mutex :name (or name "Anonymous recursive lock") 57 :recursive-p t)) 58 59 (defmacro with-recursive-lock-held ((place) &body body) 60 `(mt:with-mutex-lock (,place) ,@body)) 61 62 ;;; Resource contention: condition variables 63 64 (defun make-condition-variable (&key name) 65 (mt:make-exemption :name (or name "Anonymous condition variable"))) 66 67 (defun condition-wait (condition-variable lock &key timeout) 68 (mt:exemption-wait condition-variable lock :timeout timeout) 69 t) 70 71 (defun condition-notify (condition-variable) 72 (mt:exemption-signal condition-variable)) 73 74 (defun thread-yield () 75 (mt:thread-yield)) 76 77 ;;; Timeouts 78 79 (defmacro with-timeout ((timeout) &body body) 80 (once-only (timeout) 81 `(mt:with-timeout (,timeout (error 'timeout :length ,timeout)) 82 ,@body))) 83 84 ;;; Introspection/debugging 85 86 ;;; VTZ: mt:list-threads returns all threads that are not garbage collected. 87 (defun all-threads () 88 (delete-if-not #'mt:thread-active-p (mt:list-threads))) 89 90 (defun interrupt-thread (thread function &rest args) 91 (mt:thread-interrupt thread :function function :arguments args)) 92 93 (defun destroy-thread (thread) 94 ;;; VTZ: actually we can kill ourselelf. 95 ;;; suicide is part of our contemporary life :) 96 (signal-error-if-current-thread thread) 97 (mt:thread-interrupt thread :function t)) 98 99 (defun thread-alive-p (thread) 100 (mt:thread-active-p thread)) 101 102 (defun join-thread (thread) 103 (mt:thread-join thread)) 104 105 (mark-supported)