3rdparties/software/bordeaux-threads-v0.8.7/src/impl-ecl.lisp (2741 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)) 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:lock) 34 35 (deftype recursive-lock () 36 '(and mp:lock (satisfies mp:recursive-lock-p))) 37 38 (defun lock-p (object) 39 (typep object 'mp:lock)) 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 lock"))) 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 (defmacro with-lock-held ((place) &body body) 55 `(mp:with-lock (,place) ,@body)) 56 57 (defun make-recursive-lock (&optional name) 58 (mp:make-lock :name (or name "Anonymous recursive lock") :recursive t)) 59 60 (defun acquire-recursive-lock (lock &optional (wait-p t)) 61 (mp:get-lock lock wait-p)) 62 63 (defun release-recursive-lock (lock) 64 (mp:giveup-lock lock)) 65 66 (defmacro with-recursive-lock-held ((place) &body body) 67 `(mp:with-lock (,place) ,@body)) 68 69 ;;; Resource contention: condition variables 70 71 (defun make-condition-variable (&key name) 72 (declare (ignore name)) 73 (mp:make-condition-variable)) 74 75 (defun condition-wait (condition-variable lock &key timeout) 76 (if timeout 77 (handler-case (with-timeout (timeout) 78 (mp:condition-variable-wait condition-variable lock)) 79 (timeout () nil)) 80 (mp:condition-variable-wait condition-variable lock))) 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)