waiting for arbitrary events SB-EXT:WAIT-FOR

  While using this to wait for other threads isn't good style,
  sometimes it is _much_ easier to just state the thing you're
  waiting for than build the synchronization to make it nice.

  And sometimes the event lives in the external world, in which case
  you really need to poll anyways:

    (wait-for (probe-file pathname))

diff --git a/NEWS b/NEWS
index 8de2e09..e1b4f28 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,7 @@ changes relative to sbcl-1.0.52:
   * enhancement: on 64-bit targets, in src/compiler/generic/early-vm.lisp,
     the parameter n-fixnum-tag-bits may now vary from 1 (fixnum =
     (signed-byte 63)) to 3 (fixnum = (signed-byte 61)) at build-time.
+  * enhancement: SB-EXT:WAIT-FOR allows waiting for arbitrary events.
   * minor(?) incompatible(?) change: The default fixnum width on 64-bit
     targets is now 63 bits (up from 61).
   * enhancement: DESCRIBE now reports a lambda-list and source location

diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo
index 9e9f5db..1b4e422 100644 (file)
--- a/doc/manual/beyond-ansi.texinfo
+++ b/doc/manual/beyond-ansi.texinfo
@@ -426,6 +426,7 @@ arguments to @code{make-hash-table}.
 @include fun-sb-ext-delete-directory.texinfo
 @include fun-sb-ext-get-time-of-day.texinfo
 @include fun-sb-ext-seed-random-state.texinfo
+@include macro-sb-ext-wait-for.texinfo
 
 @node Stale Extensions
 @comment  node-name,  next,  previous,  up

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 3adfbee..8e77df1 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -608,6 +608,9 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                ;; Not an atomic operation, but should be used with them
                "SPIN-LOOP-HINT"
 
+               ;; Waiting for arbitrary events.
+               "WAIT-FOR"
+
                ;; Time related things
                "CALL-WITH-TIMING"
                "GET-TIME-OF-DAY"

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 890fd43..ec053c8 100644 (file)
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -349,3 +349,82 @@ See also the declarations SB-EXT:GLOBAL and SB-EXT:ALWAYS-BOUND."
   (sb!c:with-source-location (source-location)
     (setf (info :source-location :variable name) source-location))
   name)
+
+;;;; WAIT-FOR -- waiting on arbitrary conditions
+
+(defun %wait-for (test timeout)
+  (declare (function test))
+  (labels ((try ()
+             (declare (optimize (safety 0)))
+             (awhen (funcall test)
+               (return-from %wait-for it)))
+           (tick (sec usec)
+             (declare (fixnum sec usec))
+             ;; TICK is microseconds
+             (+ usec (* 1000000 sec)))
+           (get-tick ()
+             (multiple-value-call #'tick
+               (decode-internal-time (get-internal-real-time)))))
+    ;; Compute timeout: must come first so that deadlines already passed
+    ;; are noticed before the first try.
+    (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
+        (decode-timeout timeout)
+      (declare (ignore to-sec to-usec))
+      (let* ((timeout-tick (when stop-sec (tick stop-sec stop-usec)))
+             (start (get-tick))
+             ;; Rough estimate of how long a single attempt takes.
+             (try-ticks (progn
+                            (try) (try) (try)
+                            (max 1 (truncate (- (get-tick) start) 3)))))
+        ;; Scale sleeping between attempts:
+        ;;
+        ;; Start by sleeping for as many ticks as an average attempt
+        ;; takes, then doubling for each attempt.
+        ;;
+        ;; Max out at 0.1 seconds, or the 2 x time of a single try,
+        ;; whichever is longer -- with a hard cap of 10 seconds.
+        ;;
+        ;; FIXME: Maybe the API should have a :MAX-SLEEP argument?
+        (loop with max-ticks = (max 100000 (min (* 2 try-ticks)
+                                                (expt 10 7)))
+              for scale of-type fixnum = 1
+              then (let ((x (logand most-positive-fixnum (* 2 scale))))
+                     (if (> scale x)
+                         most-positive-fixnum
+                         x))
+              do (try)
+                 (let* ((now (get-tick))
+                        (sleep-ticks (min (* try-ticks scale) max-ticks))
+                        (sleep
+                          (if timeout-tick
+                              ;; If sleep would take us past the
+                              ;; timeout, shorten it so it's just
+                              ;; right.
+                              (if (>= (+ now sleep-ticks) timeout-tick)
+                                  (- timeout-tick now)
+                                  sleep-ticks)
+                              sleep-ticks)))
+                   (declare (fixnum sleep))
+                   (cond ((plusp sleep)
+                          ;; microseconds to seconds and nanoseconds
+                          (multiple-value-bind (sec nsec)
+                              (truncate (* 1000 sleep) (expt 10 9))
+                            (with-interrupts
+                              (sb!unix:nanosleep sec nsec))))
+                         (deadlinep
+                          (signal-deadline))
+                         (t
+                          (return-from %wait-for nil)))))))))
+
+(defmacro wait-for (test-form &key timeout)
+  "Wait until TEST-FORM evaluates to true, then return its primary value.
+If TIMEOUT is provided, waits at most approximately TIMEOUT seconds before
+returning NIL.
+
+If WITH-DEADLINE has been used to provide a global deadline, signals a
+DEADLINE-TIMEOUT if TEST-FORM doesn't evaluate to true before the
+deadline.
+
+Experimental: subject to change without prior notice."
+  `(dx-flet ((wait-for-test () (progn ,test-form)))
+     (%wait-for #'wait-for-test ,timeout)))

diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp
index ce0df2d..2623216 100644 (file)
--- a/tests/threads.pure.lisp
+++ b/tests/threads.pure.lisp
@@ -506,3 +506,22 @@
       (join-thread value))
     (assert (and (null value)
                  error))))
+
+(with-test (:name (:wait-for :basics))
+  (assert (not (sb-ext:wait-for nil :timeout 0.1)))
+  (assert (eql 42 (sb-ext:wait-for 42)))
+  (let ((n 0))
+    (assert (eql 100 (sb-ext:wait-for (when (= 100 (incf n))
+                                        n))))))
+
+(with-test (:name (:wait-for :deadline))
+  (assert (eq :ok
+              (sb-sys:with-deadline (:seconds 10)
+                (assert (not (sb-ext:wait-for nil :timeout 0.1)))
+                :ok)))
+  (assert (eq :deadline
+              (handler-case
+                  (sb-sys:with-deadline (:seconds 0.1)
+                    (sb-ext:wait-for nil :timeout 10)
+                    (error "oops"))
+                (sb-sys:deadline-timeout () :deadline)))))