3rdparties/software/bordeaux-threads-v0.8.7/src/impl-clasp.lisp (2703 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 ECL Multiprocessing interface can be found at 12 ;;; http://ecls.sourceforge.net/cgi-bin/view/Main/MultiProcessing 13 14 (deftype thread () 15 'mp:process) 16 17 ;;; Thread Creation 18 19 (defun %make-thread (function name) 20 (mp:process-run-function name function bordeaux-threads:*default-special-bindings*)) 21 22 (defun current-thread () 23 mp:*current-process*) 24 25 (defun threadp (object) 26 (typep object 'mp:process)) 27 28 (defun thread-name (thread) 29 (mp:process-name thread)) 30 31 ;;; Resource contention: locks and recursive locks 32 33 (deftype lock () 'mp:mutex) 34 35 (deftype recursive-lock () 36 '(and mp:mutex (satisfies mp:recursive-lock-p))) 37 38 (defun lock-p (object) 39 (typep object 'mp:mutex)) 40 41 (defun recursive-lock-p (object) 42 (and (typep object 'mp:lock) 43 (mp:recursive-lock-p object))) 44 45 (defun make-lock (&optional name) 46 (mp:make-lock :name (or name :anonymous))) 47 48 (defun acquire-lock (lock &optional (wait-p t)) 49 (mp:get-lock lock wait-p)) 50 51 (defun release-lock (lock) 52 (mp:giveup-lock lock)) 53 54 55 (defmacro with-lock-held ((place) &body body) 56 `(mp:with-lock (,place) ,@body)) 57 58 (defun make-recursive-lock (&optional name) 59 (mp:make-recursive-mutex (or name :anonymous-recursive-lock))) 60 61 (defun acquire-recursive-lock (lock &optional (wait-p t)) 62 (mp:get-lock lock wait-p)) 63 64 (defun release-recursive-lock (lock) 65 (mp:giveup-lock lock)) 66 67 (defmacro with-recursive-lock-held ((place) &body body) 68 `(mp:with-lock (,place) ,@body)) 69 70 ;;; Resource contention: condition variables 71 72 (defun make-condition-variable (&key name) 73 (declare (ignore name)) 74 (mp:make-condition-variable)) 75 76 (defun condition-wait (condition-variable lock &key timeout) 77 (if timeout 78 (mp:condition-variable-timedwait condition-variable lock timeout) 79 (mp:condition-variable-wait condition-variable lock)) 80 t) 81 82 (defun condition-notify (condition-variable) 83 (mp:condition-variable-signal condition-variable)) 84 85 (defun thread-yield () 86 (mp:process-yield)) 87 88 ;;; Introspection/debugging 89 90 (defun all-threads () 91 (mp:all-processes)) 92 93 (defun interrupt-thread (thread function &rest args) 94 (flet ((apply-function () 95 (if args 96 (lambda () (apply function args)) 97 function))) 98 (declare (dynamic-extent #'apply-function)) 99 (mp:interrupt-process thread (apply-function)))) 100 101 (defun destroy-thread (thread) 102 (signal-error-if-current-thread thread) 103 (mp:process-kill thread)) 104 105 (defun thread-alive-p (thread) 106 (mp:process-active-p thread)) 107 108 (defun join-thread (thread) 109 (mp:process-join thread)) 110 111 (mark-supported)