apiv2/impl-cmucl.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 (in-package :bordeaux-threads-2)
   4
   5 ;;;
   6 ;;; Threads
   7 ;;;
   8
   9 (deftype native-thread ()
  10   'mp::process)
  11
  12 (defun %start-multiprocessing ()
  13   (mp::startup-idle-and-top-level-loops))
  14
  15 (defun %make-thread (function name)
  16   ;; CMUCL doesn't like NIL names.
  17   (mp:make-process function :name (or name "")))
  18
  19 (defun %current-thread ()
  20   mp:*current-process*)
  21
  22 (defun %thread-name (thread)
  23   (mp:process-name thread))
  24
  25 (defun %join-thread (thread)
  26   (mp:process-join thread))
  27
  28 (defun %thread-yield ()
  29   (mp:process-yield))
  30
  31 ;;;
  32 ;;; Introspection/debugging
  33 ;;;
  34
  35 (defun %all-threads ()
  36   (mp:all-processes))
  37
  38 (defun %interrupt-thread (thread function)
  39   (mp:process-interrupt thread function))
  40
  41 (defun %destroy-thread (thread)
  42   (mp:destroy-process thread))
  43
  44 (defun %thread-alive-p (thread)
  45   (mp:process-active-p thread))
  46 \f
  47
  48 ;;;
  49 ;;; Non-recursive locks
  50 ;;;
  51
  52 (deftype native-lock () 'mp::error-check-lock)
  53
  54 (defun %make-lock (name)
  55   (mp:make-lock name :kind :error-check))
  56
  57 (defun %acquire-lock (lock waitp timeout)
  58   (if (and waitp (null timeout))
  59       (mp::lock-wait lock "Lock wait")
  60       (mp::lock-wait-with-timeout lock "Lock wait"
  61                                   (if waitp timeout 0))))
  62
  63 (defun %release-lock (lock)
  64   (setf (mp::lock-process lock) nil))
  65
  66 (defmacro %with-lock ((place timeout) &body body)
  67   `(mp:with-lock-held (,place "Lock wait"  :timeout ,timeout) ,@body))
  68
  69 ;;;
  70 ;;; Recursive locks
  71 ;;;
  72
  73 ;;; Note that the locks _are_ recursive, but not "balanced", and only
  74 ;;; checked if they are being held by the same process by with-lock-held.
  75 ;;; The default with-lock-held in sort of works, in that
  76 ;;; it will wait for recursive locks by the same process as well.
  77
  78 (deftype native-recursive-lock () 'mp::recursive-lock)
  79
  80 (defun %make-recursive-lock (name)
  81   (mp:make-lock name :kind :recursive))
  82
  83 (defun %acquire-recursive-lock (lock waitp timeout)
  84   (%acquire-lock lock waitp timeout))
  85
  86 (defun %release-recursive-lock (lock)
  87   (%release-lock lock))
  88
  89 (defmacro %with-recursive-lock ((place timeout) &body body)
  90   `(mp:with-lock-held (,place "Lock Wait" :timeout ,timeout) ,@body))
  91 \f
  92
  93 ;;;
  94 ;;; Condition variables
  95 ;;;
  96
  97 ;;; There's some stuff in x86-vm.lisp that might be worth investigating
  98 ;;; whether to build on. There's also process-wait and friends.
  99
 100 (defstruct (condition-variable
 101             (:constructor %make-condition-variable (name)))
 102   "Bordeaux-threads implementation of condition variables."
 103   name
 104   (lock (%make-lock nil))
 105   active)
 106
 107 (defmethod print-object ((cv condition-variable) stream)
 108   (print-unreadable-object (cv stream :type t :identity t)
 109     (format stream "~S" (condition-variable-name cv))))
 110
 111 (mark-not-implemented 'condition-wait :timeout)
 112 (defun %condition-wait (cv lock timeout)
 113   (check-type cv condition-variable)
 114   (when timeout
 115     (signal-not-implemented 'condition-wait :timeout))
 116   (%with-lock ((condition-variable-lock cv) nil)
 117     (setf (condition-variable-active cv) nil))
 118   (%release-lock lock)
 119   (mp:process-wait "Condition Wait"
 120                    #'(lambda () (condition-variable-active cv)))
 121   (%acquire-lock lock t nil)
 122   t)
 123
 124 (defun %condition-notify (cv)
 125   (check-type cv condition-variable)
 126   (%with-lock ((condition-variable-lock cv) nil)
 127     (setf (condition-variable-active cv) t))
 128   (thread-yield))
 129
 130 (mark-not-implemented 'condition-broadcast)
 131 (defun %condition-broadcast (cv)
 132   (declare (ignore cv))
 133   (signal-not-implemented 'condition-broadcast))
 134 \f
 135
 136 ;;;
 137 ;;; Timeouts
 138 ;;;
 139
 140 (defmacro with-timeout ((timeout) &body body)
 141   (once-only (timeout)
 142     `(mp:with-timeout (,timeout (error 'timeout :length ,timeout))
 143        ,@body)))