3rdparties/software/bordeaux-threads-v0.8.7/src/impl-clozure.lisp (3061 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 OpenMCL Threads interface can be found at 12 ;;; http://openmcl.clozure.com/Doc/Programming-with-Threads.html 13 14 (deftype thread () 15 'ccl:process) 16 17 ;;; Thread Creation 18 19 (defun %make-thread (function name) 20 (ccl:process-run-function name function)) 21 22 (defun current-thread () 23 ccl:*current-process*) 24 25 (defun threadp (object) 26 (typep object 'ccl:process)) 27 28 (defun thread-name (thread) 29 (ccl:process-name thread)) 30 31 ;;; Resource contention: locks and recursive locks 32 33 (deftype lock () 'ccl:lock) 34 35 (deftype recursive-lock () 'ccl:lock) 36 37 (defun lock-p (object) 38 (typep object 'ccl:lock)) 39 40 (defun recursive-lock-p (object) 41 (typep object 'ccl:lock)) 42 43 (defun make-lock (&optional name) 44 (ccl:make-lock (or name "Anonymous lock"))) 45 46 (defun acquire-lock (lock &optional (wait-p t)) 47 (if wait-p 48 (ccl:grab-lock lock) 49 (ccl:try-lock lock))) 50 51 (defun release-lock (lock) 52 (ccl:release-lock lock)) 53 54 (defmacro with-lock-held ((place) &body body) 55 `(ccl:with-lock-grabbed (,place) 56 ,@body)) 57 58 (defun make-recursive-lock (&optional name) 59 (ccl:make-lock (or name "Anonymous recursive lock"))) 60 61 (defun acquire-recursive-lock (lock) 62 (ccl:grab-lock lock)) 63 64 (defun release-recursive-lock (lock) 65 (ccl:release-lock lock)) 66 67 (defmacro with-recursive-lock-held ((place) &body body) 68 `(ccl:with-lock-grabbed (,place) 69 ,@body)) 70 71 ;;; Resource contention: condition variables 72 73 (defun make-condition-variable (&key name) 74 (declare (ignore name)) 75 (ccl:make-semaphore)) 76 77 (defun condition-wait (condition-variable lock &key timeout) 78 (release-lock lock) 79 (unwind-protect 80 (if timeout 81 (ccl:timed-wait-on-semaphore condition-variable timeout) 82 (ccl:wait-on-semaphore condition-variable)) 83 (acquire-lock lock t)) 84 t) 85 86 (defun condition-notify (condition-variable) 87 (ccl:signal-semaphore condition-variable)) 88 89 (defun thread-yield () 90 (ccl:process-allow-schedule)) 91 92 ;;; Semaphores 93 94 (deftype semaphore () 95 'ccl:semaphore) 96 97 (defun make-semaphore (&key name (count 0)) 98 (declare (ignore name)) 99 (let ((semaphore (ccl:make-semaphore))) 100 (dotimes (c count) (ccl:signal-semaphore semaphore)) 101 semaphore)) 102 103 (defun signal-semaphore (semaphore &key (count 1)) 104 (dotimes (c count) (ccl:signal-semaphore semaphore))) 105 106 (defun wait-on-semaphore (semaphore &key timeout) 107 (if timeout 108 (ccl:timed-wait-on-semaphore semaphore timeout) 109 (ccl:wait-on-semaphore semaphore))) 110 111 ;;; Introspection/debugging 112 113 (defun all-threads () 114 (ccl:all-processes)) 115 116 (defun interrupt-thread (thread function &rest args) 117 (declare (dynamic-extent args)) 118 (apply #'ccl:process-interrupt thread function args)) 119 120 (defun destroy-thread (thread) 121 (signal-error-if-current-thread thread) 122 (ccl:process-kill thread)) 123 124 (defun thread-alive-p (thread) 125 (not (ccl:process-exhausted-p thread))) 126 127 (defun join-thread (thread) 128 (ccl:join-process thread)) 129 130 (mark-supported)