branch: externals/futur
commit ec7190c9b0b08922d3b17c39a634e064b544e501
Author: Stefan Monnier <[email protected]>
Commit: Stefan Monnier <[email protected]>
(futur--queue): New struct type; Also add a few unrelated tests
* futur.el (futur--queue): New struct type.
(futur--pending): Use a `futur-queue`.
(futur--pending-r): Delete variable.
(futur--queue-enqueue, futur--queue-empty-p, futur--queue-dequeue)
(futur--queue-requeue): New functions.
(futur--background, futur--funcall): Use them.
* futur-tests.el (futur-ordering, futur-race): New tests.
---
futur-tests.el | 34 ++++++++++++++++++++++++++++++++++
futur.el | 52 ++++++++++++++++++++++++++++++++++++++++------------
2 files changed, 74 insertions(+), 12 deletions(-)
diff --git a/futur-tests.el b/futur-tests.el
index cb96910036..63f7241c82 100644
--- a/futur-tests.el
+++ b/futur-tests.el
@@ -51,6 +51,23 @@
(list (+ x1 x2) (error "Wow!")))))
(should-error (futur-blocking-wait-to-get-result p) :type 'scan-error)))
+(ert-deftest futur-ordering ()
+ "Test order of execution of callbacks."
+ (let* ((x '())
+ (fut1 (futur-timeout 0))
+ (fut21 (futur-bind fut1 (lambda (_) (push 'fut21 x) x)))
+ (fut22 (futur-bind fut1 (lambda (_) (push 'fut22 x) x)))
+ (fut3 (futur-list fut22 fut21)))
+ (should (equal (futur-blocking-wait-to-get-result fut3)
+ '((fut22 fut21) (fut21)))))
+ (let* ((x '())
+ (fut1 (futur-timeout 0))
+ (fut22 (futur-bind fut1 (lambda (_) (push 'fut22 x) x)))
+ (fut21 (futur-bind fut1 (lambda (_) (push 'fut21 x) x)))
+ (fut3 (futur-list fut22 fut21)))
+ (should (equal (futur-blocking-wait-to-get-result fut3)
+ '((fut22) (fut21 fut22))))))
+
(ert-deftest futur-timeout ()
(let* ((x '())
(_timer1 (run-with-timer 0.1 nil (lambda () (push 'timer1 x))))
@@ -73,6 +90,23 @@
(res (futur-blocking-wait-to-get-result futur)))
(should (equal res '((a timer1) (b timer1))))))
+(ert-deftest futur-race ()
+ (let* ((x '())
+ (timescale 0.1)
+ (_timer1 (run-with-timer (* 2 timescale) nil (lambda () (push 'timer1
x))))
+ (futur (futur-race
+ (futur-let* ((_ <- (futur-timeout (* 2 timescale))))
+ (push 'a x) x)
+ (futur-let* ((_ <- (futur-timeout (* 1 timescale))))
+ (push 'b x) x)
+ (futur-let* ((_ <- (futur-timeout (* 3 timescale))))
+ (push 'c x) x)))
+ (res (futur-blocking-wait-to-get-result
+ (futur-list (futur-let* ((_ <- (futur-timeout (* 4 timescale))))
+ x)
+ futur))))
+ (should (equal res '((timer1 b) (b))))))
+
(ert-deftest futur-abort ()
(let* ((x '())
(start (float-time))
diff --git a/futur.el b/futur.el
index b725aa06c2..399ab5a475 100644
--- a/futur.el
+++ b/futur.el
@@ -146,9 +146,43 @@
(require 'cl-lib)
-(defvar futur--pending () "List of pending operations.")
-(defvar futur--pending-r ()
- "List of additional pending operations in reverse-order.")
+(cl-defstruct (futur--queue
+ (:conc-name futur--queue-)
+ (:constructor nil)
+ (:constructor futur--queue ()
+ "Return a new empty `futur--queue'."))
+ head revtail)
+
+(defun futur--queue-enqueue (queue val)
+ "Add VAL to the end of the QUEUE."
+ (push val (futur--queue-revtail queue)))
+
+(defun futur--queue-empty-p (queue)
+ "Return non-nil if and only if the QUEUE is empty."
+ (and (null (futur--queue-head queue))
+ (let ((tail (futur--queue-revtail queue)))
+ (if tail
+ (progn
+ (setf (futur--queue-head queue) (nreverse tail))
+ (setf (futur--queue-revtail queue) nil)
+ nil)
+ t))))
+
+(defun futur--queue-dequeue (queue)
+ "Remove the first element from the QUEUE and return it.
+It's an error to use it without checking first with `futur--queue-empty-p'
+that it is not empty."
+ (let ((h (futur--queue-head queue)))
+ (cl-assert h)
+ (setf (futur--queue-head queue) (cdr h))
+ (car h)))
+
+(defun futur--queue-requeue (queue val)
+ "Push VAL back to the head of the QUEUE."
+ (push val (futur--queue-head queue)))
+
+(defvar futur--pending (futur--queue)
+ "Pending operations.")
(defconst futur--pending-mutex (make-mutex "futur-pending"))
(defconst futur--pending-condition
@@ -166,15 +200,9 @@
(while t
(let ((pending
(with-mutex futur--pending-mutex
- (while (and (null futur--pending)
- (or (null futur--pending-r)
- (progn
- (setq futur--pending
- (nreverse futur--pending-r))
- (setq futur--pending-r nil)
- nil)))
+ (while (futur--queue-empty-p futur--pending)
(condition-wait futur--pending-condition))
- (pop futur--pending))))
+ (futur--queue-dequeue futur--pending))))
(with-demoted-errors "future--background: %S"
(apply pending))))))
@@ -198,7 +226,7 @@ time or order of execution."
(if (not (fboundp 'make-thread)) ;Emacs<26
(apply #'run-with-timer 0 nil args)
(with-mutex futur--pending-mutex
- (push args futur--pending-r)
+ (futur--queue-enqueue futur--pending args)
;; FIXME: Maybe we should have combination
;; `mutex-unlock+condition-notify', i.e. a variant of
;; `condition-notify' which doesn't regrab the lock?
