apiv2/api-locks.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*-
   2 ;;;; The above modeline is required for Genera. Do not change.
   3
   4 (in-package :bordeaux-threads-2)
   5
   6 (defun native-lock-p (object)
   7   (typep object 'native-lock))
   8
   9 (defclass lock ()
  10   ((name :initarg :name :reader lock-name)
  11    (native-lock :initarg :native-lock :reader lock-native-lock))
  12   (:documentation "Wrapper for a native non-recursive lock."))
  13
  14 (defmethod print-object ((lock lock) stream)
  15   (print-unreadable-object (lock stream :type t :identity t)
  16     (format stream "~S" (lock-name lock))))
  17
  18 (defun lockp (object)
  19   "Returns T if OBJECT is a non-recursive lock; returns NIL otherwise."
  20   (typep object 'lock))
  21
  22 (defun make-lock (&key name)
  23   "Creates a lock (a mutex) whose name is NAME."
  24   (check-type name (or null string))
  25   (make-instance 'lock
  26                  :name name
  27                  :native-lock (%make-lock name)))
  28
  29 (defun acquire-lock (lock &key (wait t) timeout)
  30   "Acquire the lock LOCK for the calling thread.
  31
  32   WAIT governs what happens if the lock is not available: if WAIT
  33   is true, the calling thread will wait until the lock is available
  34   and then acquire it; if WAIT is NIL, ACQUIRE-LOCK will return
  35   immediately.
  36
  37   If WAIT is true, TIMEOUT may specify a maximum amount of seconds to
  38   wait for the lock to become available.
  39
  40   ACQUIRE-LOCK returns T if the lock was acquired and NIL
  41   otherwise.
  42
  43   This specification does not define what happens if a thread
  44   attempts to acquire a lock that it already holds. For applications
  45   that require locks to be safe when acquired recursively, see instead
  46   MAKE-RECURSIVE-LOCK and friends."
  47   (check-type timeout (or null (real 0)))
  48   (%acquire-lock (lock-native-lock lock) (bool wait) timeout))
  49
  50 (defun release-lock (lock)
  51   "Release LOCK. It is an error to call this unless
  52   the lock has previously been acquired (and not released) by the same
  53   thread. If other threads are waiting for the lock, the
  54   ACQUIRE-LOCK call in one of them will now be able to continue.
  55
  56   Returns the lock."
  57   (%release-lock (lock-native-lock lock))
  58   lock)
  59
  60 (defmacro with-lock-held ((place &key timeout)
  61                           &body body &environment env)
  62   "Evaluates BODY with the lock named by PLACE, the value of which
  63   is a lock created by MAKE-LOCK. Before the forms in BODY are
  64   evaluated, the lock is acquired as if by using ACQUIRE-LOCK. After the
  65   forms in BODY have been evaluated, or if a non-local control transfer
  66   is caused (e.g. by THROW or SIGNAL), the lock is released as if by
  67   RELEASE-LOCK.
  68
  69   Note that if the debugger is entered, it is unspecified whether the
  70   lock is released at debugger entry or at debugger exit when execution
  71   is restarted."
  72   (declare (ignorable place timeout))
  73   (if (fboundp '%with-lock)
  74       (macroexpand-1
  75        `(%with-lock ((lock-native-lock ,place) ,timeout)
  76           ,@body)
  77        env)
  78       `(when (acquire-lock ,place :wait t :timeout ,timeout)
  79          (unwind-protect
  80               (locally ,@body)
  81            (release-lock ,place)))))
  82
  83 (defun native-recursive-lock-p (object)
  84   (typep object 'native-recursive-lock))
  85
  86 (defclass recursive-lock ()
  87   ((name :initarg :name :reader lock-name)
  88    (native-lock :initarg :native-lock :reader lock-native-lock))
  89   (:documentation "Wrapper for a native recursive lock."))
  90
  91 (defmethod print-object ((lock recursive-lock) stream)
  92   (print-unreadable-object (lock stream :type t :identity t)
  93     (format stream "~S" (lock-name lock))))
  94
  95 (defun recursive-lock-p (object)
  96   "Returns T if OBJECT is a recursive lock; returns NIL otherwise."
  97   (typep object 'recursive-lock))
  98
  99 (defun make-recursive-lock (&key name)
 100   "Create and return a recursive lock whose name is NAME.
 101
 102   A recursive lock differs from an ordinary lock in that a thread that
 103   already holds the recursive lock can acquire it again without
 104   blocking. The thread must then release the lock twice before it
 105   becomes available for another thread (acquire and release operations
 106   must be balanced)."
 107   (check-type name (or null string))
 108   (make-instance 'recursive-lock
 109                  :name name
 110                  :native-lock (%make-recursive-lock name)))
 111
 112 (defun acquire-recursive-lock (lock &key (wait t) timeout)
 113   "Acquire the lock LOCK for the calling thread.
 114
 115   WAIT governs what happens if the lock is not available: if WAIT is
 116   true, the calling thread will wait until the lock is available and
 117   then acquire it; if WAIT is NIL, ACQUIRE-RECURSIVE-LOCK will return
 118   immediately.
 119
 120   If WAIT is true, TIMEOUT may specify a maximum amount of seconds to
 121   wait for the lock to become available.
 122
 123   ACQUIRE-LOCK returns true if the lock was acquired and NIL
 124   otherwise.
 125
 126   This operation will return immediately if the lock is already owned
 127   by the current thread. Acquire and release operations must be
 128   balanced."
 129   (check-type lock recursive-lock)
 130   (check-type timeout (or null (real 0)))
 131   (%acquire-recursive-lock (lock-native-lock lock) (bool wait) timeout))
 132
 133 (defun release-recursive-lock (lock)
 134   "Release LOCK. It is an error to call this unless
 135   the lock has previously been acquired (and not released) by the same
 136   thread.
 137
 138   Returns the lock."
 139   (%release-recursive-lock (lock-native-lock lock))
 140   lock)
 141
 142 (defmacro with-recursive-lock-held ((place &key timeout)
 143                                     &body body &environment env)
 144   "Evaluates BODY with the recursive lock named by PLACE, which is a
 145   reference to a recursive lock created by MAKE-RECURSIVE-LOCK.
 146   See WITH-LOCK-HELD."
 147   (declare (ignorable place timeout))
 148   (if (fboundp '%with-recursive-lock)
 149       (macroexpand-1
 150        `(%with-recursive-lock ((lock-native-lock ,place) ,timeout)
 151           ,@body)
 152        env)
 153       `(when (acquire-recursive-lock ,place :wait t :timeout ,timeout)
 154          (unwind-protect
 155               (locally ,@body)
 156            (release-recursive-lock ,place)))))