Exceptions in initial fiber cause hang

[Reepca]

Consider the following:

(run-fibers (lambda () (throw 'foo)))

in both current master and 1.0.0 this will cause a hang - run-fibers doesn't return, and it doesn't do anything either (in current master it will actually be an uninterruptible hang - ^C'ing won't do anything because of the catch-loop in run-scheduler (unless you manage to press it again before catch is re-entered)). The reason for this is that the ret atomic box doesn't get written to when the init thunk throws an exception. Thus, finished? always returns #f. It's also currently possible for an exception from init to cause the main scheduler to never be woken up, as that spawn-fiber invocation is skipped.

Since we're already ensuring that the return value of the initial thunk gets passed along to the caller, we should probably ensure that any exceptions do as well. We could do this by wrapping the result such that an exception with arguments args becomes (list 'err args) and a regular exit with return values vals becomes (list 'ok vals). We then match on the first symbol when deciding at the end of run-fibers whether to return or re-throw.

The code below fixes the hang-on-exception behavior and also ensures that the main scheduler gets woken up even if an exception is thrown. It also re-throws the exception in the caller's context.

(define* (run-fibers #:optional (init #f)
                     #:key (hz 100) (scheduler #f)
                     (parallelism (current-processor-count))
                     (cpus (getaffinity 0))
                     (install-suspendable-ports? #t)
                     (drain? #f))
  (when install-suspendable-ports? (install-suspendable-ports!))
  (cond
   (scheduler
    (let ((finished? (lambda () #f)))
      (when init (spawn-fiber init scheduler))
      (%run-fibers scheduler hz finished? cpus)))
   (else
    (let* ((scheduler (make-scheduler #:parallelism parallelism))
           (ret (make-atomic-box #f))
           (finished? (lambda ()
                        (and (atomic-box-ref ret)
                             (or (not drain?)
                                 (not (scheduler-work-pending? scheduler))))))
           (affinities (compute-affinities cpus parallelism)))
      (unless init
        (error "run-fibers requires initial fiber thunk when creating sched"))
      (spawn-fiber (lambda ()
                     (dynamic-wind
		       (const #t)
		       (lambda ()
			 (catch #t
			   (lambda ()
			     (call-with-values init
			       (lambda vals (atomic-box-set! ret
							     (list 'ok vals)))))
			   (lambda args
			     (atomic-box-set! ret (list 'err args))
			     (apply throw args))))
		       ;; Could be that this fiber was migrated away.
		       ;; Make sure to wake up the main scheduler.
		       (lambda ()
			 (spawn-fiber (lambda () #t) scheduler))))
                   scheduler)
      (match affinities
        ((affinity . affinities)
         (dynamic-wind
           (lambda ()
             (start-auxiliary-threads scheduler hz finished? affinities))
           (lambda ()
             (%run-fibers scheduler hz finished? affinity))
           (lambda ()
             (stop-auxiliary-threads scheduler)))))
      (destroy-scheduler scheduler)
      (match (atomic-box-ref ret)
        (('ok vals)
         (apply values vals))
        (('err args)
         (apply throw args)))))))