Add support for operations from foreign threads

* tests/foreign.scm: New file.
* Makefile.am: Add new file.
* fibers/operations.scm (perform-operation): Support blocking operations
  from foreign threads (without a scheduler).
* fibers/timers.scm (timer-sched, *timer-sched*, timer-operation): Add
  support for timeouts that use an auxiliary thread instead of relying
  on the current scheduler.

2 files changed, 51 insertions, 2 deletions

diff --git a/fibers/operations.scm b/fibers/operations.scm
index 7ee21d5..8e9c85c 100644
--- a/fibers/operations.scm
+++ b/fibers/operations.scm
@@ -141,12 +141,39 @@ the operation cannot complete directly, block until it can complete."
              (lp (1+ i))))))))
 
   (define (suspend)
+    ;; Two cases.  If there is a current fiber, then we suspend the
+    ;; current fiber and arrange to restart it when the operation
+    ;; succeeds.  Otherwise we block the current thread until the
+    ;; operation succeeds, to allow for communication between fibers
+    ;; and foreign threads.
     (if (current-fiber)
         (suspend-current-fiber
          (lambda (fiber)
            (define (resume thunk) (resume-fiber fiber thunk))
            (block (fiber-scheduler fiber) resume)))
-        (error "unimplemented")))
+        (let ((k #f)
+              (thread (current-thread))
+              (mutex (make-mutex))
+              (condvar (make-condition-variable)))
+          (define (resume thunk)
+            (cond
+             ((eq? (current-thread) thread)
+              (set! k thunk))
+             (else
+              (lock-mutex mutex)
+              (set! k thunk)
+              (signal-condition-variable condvar)
+              (unlock-mutex mutex))))
+          (lock-mutex mutex)
+          (block #f resume)
+          (let lp ()
+            (cond
+             (k
+              (unlock-mutex mutex)
+              (k))
+             (else
+              (wait-condition-variable condvar mutex)
+              (lp)))))))
 
   ;; First, try to sync on an op.  If no op syncs, block.
   (match op
diff --git a/fibers/timers.scm b/fibers/timers.scm
index 4affd54..15638b0 100644
--- a/fibers/timers.scm
+++ b/fibers/timers.scm
@@ -22,10 +22,26 @@
   #:use-module (fibers operations)
   #:use-module (ice-9 atomic)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 threads)
   #:export (wait-operation
             timer-operation)
   #:replace (sleep))
 
+(define *timer-sched* (make-atomic-box #f))
+
+(define (timer-sched)
+  (or (atomic-box-ref *timer-sched*)
+      (let ((sched (make-scheduler)))
+        (cond
+         ((atomic-box-compare-and-swap! *timer-sched* #f sched))
+         (else
+          ;; FIXME: Would be nice to clean up this thread at some point.
+          (call-with-new-thread
+           (lambda ()
+             (define (finished?) #f)
+             (with-scheduler sched (run-scheduler sched finished?))))
+          sched)))))
+
 (define (timer-operation expiry)
   "Make an operation that will succeed when the current time is
 greater than or equal to @var{expiry}, expressed in internal time
@@ -40,7 +56,13 @@ units.  The operation will succeed with no values."
                              ('W (resume values))
                              ('C (timer))
                              ('S #f)))
-                         (add-timer sched expiry timer))))
+                         (if sched
+                             (add-timer sched expiry timer)
+                             (create-fiber (timer-sched)
+                                           (lambda ()
+                                             (perform-operation (timer-operation expiry))
+                                             (timer))
+                                           (current-dynamic-state))))))
 
 (define (wait-operation seconds)
   "Make an operation that will succeed with no values when