apiv2/impl-clisp.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 (in-package :bordeaux-threads-2)
   4
   5 ;;;
   6 ;;; Threads
   7 ;;;
   8
   9 (deftype native-thread ()
  10   'mt:thread)
  11
  12 (defun %make-thread (function name)
  13   (mt:make-thread function :name name))
  14
  15 (defun %current-thread ()
  16   (mt:current-thread))
  17
  18 (defun %thread-name (thread)
  19   (mt:thread-name thread))
  20
  21 (defun %join-thread (thread)
  22   (mt:thread-join thread))
  23
  24 (defun %thread-yield ()
  25   (mt:thread-yield))
  26
  27 ;;;
  28 ;;; Introspection/debugging
  29 ;;;
  30
  31 ;;; VTZ: mt:list-threads returns all threads that are not garbage collected.
  32 (defun %all-threads ()
  33   (delete-if-not #'mt:thread-active-p (mt:list-threads)))
  34
  35 (defun %interrupt-thread (thread function)
  36   (mt:thread-interrupt thread :function function))
  37
  38 (defun %destroy-thread (thread)
  39   (mt:thread-interrupt thread :function t))
  40
  41 (defun %thread-alive-p (thread)
  42   (mt:thread-active-p thread))
  43 \f
  44
  45 ;;;
  46 ;;; Non-recursive locks
  47 ;;;
  48
  49 (deftype native-lock ()
  50   'mt:mutex)
  51
  52 (defun %make-lock (name)
  53   (mt:make-mutex :name name))
  54
  55 (mark-not-implemented 'acquire-lock :timeout)
  56 (defun %acquire-lock (lock waitp timeout)
  57   (when timeout
  58     (signal-not-implemented 'acquire-lock :timeout))
  59   (mt:mutex-lock lock :timeout (if waitp nil 0)))
  60
  61 (defun %release-lock (lock)
  62   (mt:mutex-unlock lock))
  63
  64 (mark-not-implemented 'with-lock-held :timeout)
  65 (defmacro %with-lock ((place timeout) &body body)
  66   (if timeout
  67       `(signal-not-implemented 'with-lock-held :timeout)
  68       `(mt:with-mutex-lock (,place) ,@body)))
  69
  70 ;;;
  71 ;;; Recursive locks
  72 ;;;
  73
  74 (deftype native-recursive-lock ()
  75   '(and mt:mutex (satisfies mt:mutex-recursive-p)))
  76
  77 (defun %make-recursive-lock (name)
  78   (mt:make-mutex :name name :recursive-p t))
  79
  80 (mark-not-implemented 'acquire-recursive-lock :timeout)
  81 (defun %acquire-recursive-lock (lock waitp timeout)
  82   (when timeout
  83     (signal-not-implemented 'acquire-recursive-lock :timeout))
  84   (%acquire-lock lock waitp nil))
  85
  86 (defun %release-recursive-lock (lock)
  87   (%release-lock lock))
  88
  89 (mark-not-implemented 'with-recursive-lock-held :timeout)
  90 (defmacro %with-recursive-lock ((place timeout) &body body)
  91   (if timeout
  92       `(signal-not-implemented 'with-recursive-lock-held :timeout)
  93       `(mt:with-mutex-lock (,place) ,@body)))
  94 \f
  95
  96 ;;;
  97 ;;; Condition variables
  98 ;;;
  99
 100 (deftype condition-variable ()
 101   'mt:exemption)
 102
 103 (defun %make-condition-variable (name)
 104   (mt:make-exemption :name name))
 105
 106 (defun %condition-wait (cv lock timeout)
 107   (mt:exemption-wait cv lock :timeout timeout))
 108
 109 (defun %condition-notify (cv)
 110   (mt:exemption-signal cv))
 111
 112 (defun %condition-broadcast (cv)
 113   (mt:exemption-broadcast cv))
 114 \f
 115
 116 ;;;
 117 ;;; Timeouts
 118 ;;;
 119
 120 (defmacro with-timeout ((timeout) &body body)
 121   (once-only (timeout)
 122     `(mt:with-timeout (,timeout (error 'timeout :length ,timeout))
 123        ,@body)))