contrib/sb-concurrency/gate.lisp

   1 ;;;; -*-  Lisp -*-
   2 ;;;;
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package :sb-concurrency)
  13
  14 ;;;; FIXME: On Linux a direct futex-based implementation would be more
  15 ;;;; efficient.
  16
  17 (defstruct (gate (:constructor %make-gate)
  18                  (:copier nil)
  19                  (:predicate gatep))
  20   "GATE type. Gates are syncronization constructs suitable for making
  21 multiple threads wait for single event before proceeding.
  22
  23 Use WAIT-ON-GATE to wait for a gate to open, OPEN-GATE to open one,
  24 and CLOSE-GATE to close an open gate. GATE-OPEN-P can be used to test
  25 the state of a gate without blocking."
  26   (mutex (missing-arg) :type mutex)
  27   (queue (missing-arg) :type waitqueue)
  28   (state :closed :type (member :open :closed))
  29   (name  nil :type (or null simple-string)))
  30
  31 (setf (documentation 'gatep 'function)
  32       "Returns true if the argument is a GATE."
  33       (documentation 'gate-name 'function)
  34       "Name of a GATE. SETFable.")
  35
  36 (defmethod print-object ((gate gate) stream)
  37   (print-unreadable-object (gate stream :type t :identity t)
  38     (format stream "~@[~S ~]~((~A)~)"
  39             (gate-name gate)
  40             (gate-state gate))))
  41
  42 (defun make-gate (&key name open)
  43   "Makes a new gate. Gate will be initially open if OPEN is true, and closed if OPEN
  44 is NIL (the default.) NAME, if provided, is the name of the gate, used when printing
  45 the gate."
  46   (flet ((generate-name (thing)
  47            (when name
  48              (format nil "gate ~S's ~A" name thing))))
  49     (%make-gate
  50      :name name
  51      :mutex (make-mutex :name (generate-name "lock"))
  52      :queue (make-waitqueue :name (generate-name "condition variable"))
  53      :state (if open :open :closed))))
  54
  55 (defun open-gate (gate)
  56   "Opens GATE. Returns T if the gate was previously closed, and NIL
  57 if the gate was already open."
  58   (declare (gate gate))
  59   (let (closed)
  60     (with-mutex ((gate-mutex gate))
  61       (sb-sys:without-interrupts
  62         (setf closed (eq :closed (gate-state gate))
  63               (gate-state gate) :open)
  64         (condition-broadcast (gate-queue gate))))
  65     closed))
  66
  67 (defun close-gate (gate)
  68   "Closes GATE. Returns T if the gate was previously open, and NIL
  69 if the gate was already closed."
  70   (declare (gate gate))
  71   (let (open)
  72     (with-mutex ((gate-mutex gate))
  73       (setf open (eq :open (gate-state gate))
  74             (gate-state gate) :closed))
  75     open))
  76
  77 (defun wait-on-gate (gate &key timeout)
  78   "Waits for GATE to open, or TIMEOUT seconds to pass. Returns T
  79 if the gate was opened in time, and NIL otherwise."
  80   (declare (gate gate))
  81   (with-mutex ((gate-mutex gate))
  82     (loop until (eq :open (gate-state gate))
  83           do (or (condition-wait (gate-queue gate) (gate-mutex gate)
  84                               :timeout timeout)
  85                  (return-from wait-on-gate nil))))
  86   t)
  87
  88 (defun gate-open-p (gate)
  89   "Returns true if GATE is open."
  90   (declare (gate gate))
  91   (eq :open (gate-state gate)))