apiv2/impl-clozure.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 (in-package :bordeaux-threads-2)
   4
   5 ;;;
   6 ;;; Threads
   7 ;;;
   8
   9 (deftype native-thread ()
  10   'ccl:process)
  11
  12 (defun %make-thread (function name)
  13   (ccl:process-run-function name function))
  14
  15 (defun %current-thread ()
  16   ccl:*current-process*)
  17
  18 (defun %thread-name (thread)
  19   (ccl:process-name thread))
  20
  21 (defun %join-thread (thread)
  22   (ccl:join-process thread))
  23
  24 (defun %thread-yield ()
  25   (ccl:process-allow-schedule))
  26
  27 ;;;
  28 ;;; Introspection/debugging
  29 ;;;
  30
  31 (defun %all-threads ()
  32   (ccl:all-processes))
  33
  34 (defun %interrupt-thread (thread function)
  35   (ccl:process-interrupt thread function))
  36
  37 (defun %destroy-thread (thread)
  38   (ccl:process-kill thread))
  39
  40 (defun %thread-alive-p (thread)
  41   (not (ccl:process-exhausted-p thread)))
  42 \f
  43
  44 ;;;
  45 ;;; Non-recursive locks
  46 ;;;
  47
  48 (deftype native-lock () 'ccl:lock)
  49
  50 (defun %make-lock (name)
  51   (ccl:make-lock name))
  52
  53 (mark-not-implemented 'acquire-lock :timeout)
  54 (defun %acquire-lock (lock waitp timeout)
  55   (when timeout
  56     (signal-not-implemented 'acquire-lock :timeout))
  57   ;; This is not guaranteed to work all the times, but that's OK.
  58   (when (eql (ccl::%%lock-owner lock) (%current-thread))
  59     (bt-error "Attempted recursive acquisition of lock: ~A" lock))
  60   (if waitp
  61       (ccl:grab-lock lock)
  62       (ccl:try-lock lock)))
  63
  64 (defun %release-lock (lock)
  65   (ccl:release-lock lock))
  66
  67 (mark-not-implemented 'with-lock-held :timeout)
  68 (defmacro %with-lock ((place timeout) &body body)
  69   (declare (ignorable place timeout))
  70   (if timeout
  71       `(signal-not-implemented 'with-lock-held :timeout)
  72       `(ccl:with-lock-grabbed (,place)
  73          ,@body)))
  74
  75 ;;;
  76 ;;; Recursive locks
  77 ;;;
  78
  79 (deftype native-recursive-lock () 'ccl:lock)
  80
  81 (defun %make-recursive-lock (name)
  82   (ccl:make-lock name))
  83
  84 (mark-not-implemented 'acquire-recursive-lock :timeout)
  85 (defun %acquire-recursive-lock (lock waitp timeout)
  86   (when timeout
  87     (signal-not-implemented 'acquire-recursive-lock :timeout))
  88   (if waitp
  89       (ccl:grab-lock lock)
  90       (ccl:try-lock lock)))
  91
  92 (defun %release-recursive-lock (lock)
  93   (ccl:release-lock lock))
  94
  95 (mark-not-implemented 'with-recursive-lock-held :timeout)
  96 (defmacro %with-recursive-lock ((place timeout) &body body)
  97   (declare (ignorable place timeout))
  98   (if timeout
  99       `(signal-not-implemented 'with-recursive-lock-held :timeout)
 100       `(ccl:with-lock-grabbed (,place)
 101          ,@body)))
 102 \f
 103
 104 ;;;
 105 ;;; Semaphores
 106 ;;;
 107
 108 (deftype semaphore () 'ccl:semaphore)
 109
 110 (defun %make-semaphore (name count)
 111   (declare (ignore name))
 112   (ccl:make-semaphore :count count))
 113
 114 (defun %signal-semaphore (semaphore count)
 115   (dotimes (c count) (ccl:signal-semaphore semaphore)))
 116
 117 (defun %wait-on-semaphore (semaphore timeout)
 118   (if timeout
 119       (ccl:timed-wait-on-semaphore semaphore timeout)
 120       (ccl:wait-on-semaphore semaphore)))
 121 \f
 122
 123 ;;;
 124 ;;; Condition variables
 125 ;;;
 126
 127 ;;; Clozure doesn't have native condition variables.
 128 ;;; We'll use the implementation in
 129 ;;; impl-condition-variables-semaphores.lisp