3rdparties/software/bordeaux-threads-v0.8.7/src/impl-mcl.lisp (1508 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 'ccl::process) 13 14 ;;; Thread Creation 15 16 (defun %make-thread (function name) 17 (ccl:process-run-function name function)) 18 19 (defun current-thread () 20 ccl:*current-process*) 21 22 (defun threadp (object) 23 (ccl::processp object)) 24 25 (defun thread-name (thread) 26 (ccl:process-name thread)) 27 28 ;;; Resource contention: locks and recursive locks 29 30 (deftype lock () 'ccl:lock) 31 32 (defun lock-p (object) 33 (typep object 'ccl:lock)) 34 35 (defun make-lock (&optional name) 36 (ccl:make-lock (or name "Anonymous lock"))) 37 38 (defun acquire-lock (lock &optional (wait-p t)) 39 (if wait-p 40 (ccl:process-lock lock ccl:*current-process*) 41 ;; this is broken, but it's better than a no-op 42 (ccl:without-interrupts 43 (when (null (ccl::lock.value lock)) 44 (ccl:process-lock lock ccl:*current-process*))))) 45 46 (defun release-lock (lock) 47 (ccl:process-unlock lock)) 48 49 (defmacro with-lock-held ((place) &body body) 50 `(ccl:with-lock-grabbed (,place) ,@body)) 51 52 (defun thread-yield () 53 (ccl:process-allow-schedule)) 54 55 ;;; Introspection/debugging 56 57 (defun all-threads () 58 ccl:*all-processes*) 59 60 (defun interrupt-thread (thread function &rest args) 61 (declare (dynamic-extent args)) 62 (apply #'ccl:process-interrupt thread function args)) 63 64 (defun destroy-thread (thread) 65 (signal-error-if-current-thread thread) 66 (ccl:process-kill thread)) 67 68 (mark-supported)