diff --git a/bordeaux-threads.asd b/bordeaux-threads.asd index bed96f9f82774f8a7042a6d26955091911f30728..aaf6f2696a91c2b515883e5ad5d5ecd2c03501ff 100644 --- a/bordeaux-threads.asd +++ b/bordeaux-threads.asd @@ -18,6 +18,7 @@ Distributed under the MIT license (see LICENSE file) (and cmu mp) corman (and ecl threads) + mkcl lispworks (and digitool ccl-5.1) (and sbcl sb-thread) @@ -44,6 +45,7 @@ Distributed under the MIT license (see LICENSE file) #+(and thread-support cmu) "impl-cmucl" #+(and thread-support corman) "impl-corman" #+(and thread-support ecl) "impl-ecl" + #+(and thread-support mkcl) "impl-mkcl" #+(and thread-support lispworks) "impl-lispworks" #+(and thread-support digitool) "impl-mcl" #+(and thread-support sbcl) "impl-sbcl" diff --git a/src/impl-mkcl.lisp b/src/impl-mkcl.lisp new file mode 100644 index 0000000000000000000000000000000000000000..22264e9871944897fe163717491b74e0772f3b57 --- /dev/null +++ b/src/impl-mkcl.lisp @@ -0,0 +1,93 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*- + +#| +Copyright 2006, 2007 Greg Pfeil +Copyright 2010 Jean-Claude Beaudoin. + +Distributed under the MIT license (see LICENSE file) +|# + +(in-package #:bordeaux-threads) + +(deftype thread () + 'mt:thread) + +;;; Thread Creation + +(defun %make-thread (function name) + (mt:thread-run-function name function)) + +(defun current-thread () + mt::*thread*) + +(defun threadp (object) + (typep object 'mt:thread)) + +(defun thread-name (thread) + (mt:thread-name thread)) + +;;; Resource contention: locks and recursive locks + +(defun make-lock (&optional name) + (mt:make-lock :name (or name "Anonymous lock"))) + +(defun acquire-lock (lock &optional (wait-p t)) + (mt:get-lock lock wait-p)) + +(defun release-lock (lock) + (mt:giveup-lock lock)) + +(defmacro with-lock-held ((place) &body body) + `(mt:with-lock (,place) ,@body)) + +(defun make-recursive-lock (&optional name) + (mt:make-lock :name (or name "Anonymous recursive lock") :recursive t)) + +(defun acquire-recursive-lock (lock &optional (wait-p t)) + (mt:get-lock lock wait-p)) + +(defun release-recursive-lock (lock) + (mt:giveup-lock lock)) + +(defmacro with-recursive-lock-held ((place) &body body) + `(mt:with-lock (,place) ,@body)) + +;;; Resource contention: condition variables + +(defun make-condition-variable (&key name) + (declare (ignore name)) + (mt:make-condition-variable)) + +(defun condition-wait (condition-variable lock) + (mt:condition-wait condition-variable lock)) + +(defun condition-notify (condition-variable) + (mt:condition-signal condition-variable)) + +(defun thread-yield () + (mt:thread-yield)) + +;;; Introspection/debugging + +(defun all-threads () + (mt:all-threads)) + +(defun interrupt-thread (thread function &rest args) + (flet ((apply-function () + (if args + (lambda () (apply function args)) + function))) + (declare (dynamic-extent #'apply-function)) + (mt:interrupt-thread thread (apply-function)))) + +(defun destroy-thread (thread) + (signal-error-if-current-thread thread) + (mt:thread-kill thread)) + +(defun thread-alive-p (thread) + (mt:thread-active-p thread)) + +(defun join-thread (thread) + (mt:thread-join thread)) + +(mark-supported)