Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

file 95 lines (89 sloc) 3.943 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
(defpackage "STATUS"
  (:use "CL" "SB-EXT" "SB-THREAD")
  (:export "SLOW-STATUS" "DEFINE-STATUS-TYPE"))

(in-package "STATUS")

(defstruct (slow-status
            (:constructor nil))
  (status nil :type t)
  (lock (make-mutex) :type mutex
                           :read-only t)
  (cvar (make-waitqueue) :type waitqueue
                           :read-only t))

(defmacro define-status-type (type-name
                              (&key (fast-type t)
                                    (status-type t)
                                    (default-status '(error "Status missing"))
                                    (constructor
                                     (intern
                                      (format nil "MAKE-~A"
                                              (symbol-name type-name))))
                                    (final-states '()))
                              fast-accessor
                              status-function
                              wait-function
                              upgrade-function)
  `(progn
     (defstruct (,type-name
                 (:constructor ,constructor)
                 (:include slow-status
                  (status ,default-status :type ,status-type))))

     (defun ,status-function (value)
       (declare (type ,fast-type value))
       (let ((%status (,fast-accessor value)))
         (if (typep %status ',type-name)
             (slow-status-status %status)
             %status)))

     (defun ,wait-function (value &rest stopping-conditions)
       (declare (type ,fast-type value))
       (declare (dynamic-extent stopping-conditions))
       (let (slow
             slow-status)
         (loop
           (let ((%status (,fast-accessor value)))
             (when (typep %status ',type-name)
               (setf slow-status %status)
               (return))
             (when (member %status stopping-conditions)
               (return-from ,wait-function %status))
             (if slow
                 (setf (slow-status-status slow) %status)
                 (setf slow (,constructor :status %status)))
             (when (eql (cas (,fast-accessor value) %status slow)
                        %status)
               (setf slow-status slow)
               (return))))
         (let* ((slow-status slow-status)
                (lock (slow-status-lock slow-status))
                (cvar (slow-status-cvar slow-status)))
           (declare (type slow-status slow-status))
           (return-from ,wait-function
             (with-mutex (lock)
               (loop
                 (let ((status (slow-status-status slow-status)))
                   (when (member status stopping-conditions)
                     (return status)))
                 (condition-wait cvar lock)))))))

     (defun ,upgrade-function (value to &rest from)
       (declare (type ,fast-type value))
       (declare (dynamic-extent from))
       (let (slow-status)
          (loop
            (let ((%status (,fast-accessor value)))
              (when (typep %status ',type-name)
                (setf slow-status %status)
                (return))
              (when (or (not (member %status from))
                        (eql (compare-and-swap (,fast-accessor value)
                                               %status to)
                             %status))
                (return-from ,upgrade-function %status))))
         (with-mutex ((slow-status-lock slow-status))
           (let ((status (slow-status-status slow-status)))
             (when (member status from)
               (setf (slow-status-status slow-status) to)
               (when (or ,@(mapcar (lambda (x)
                                     `(eql to ',x))
                                   final-states))
                 (setf (,fast-accessor value) to))
               (condition-broadcast (slow-status-cvar slow-status)))
             status))))))
Something went wrong with that request. Please try again.