thread: fix atomic-timeout-callback implementation

Closes racket/drracket#238

pkgs/racket-test-core/tests/racket/try-atomic.rkt

@@ -0,0 +1,21 @@
+#lang racket/base
+(require ffi/unsafe/try-atomic)
+
+(define ch (make-channel))
+(define done? #f)
+
+(define (check v expect)
+  (unless (equal? v expect)
+    (error 'check "failed: ~s vs. ~s" v expect)))
+
+(check
+ (call-as-nonatomic-retry-point
+  (lambda ()
+    (try-atomic
+     (lambda ()
+       (sync/timeout 0.25 ch)
+      (set! done? #t))
+     'no)))
+ 'no)
+
+(check done? #t)

racket/src/thread/Makefile

@@ -19,7 +19,8 @@ GLOBALS = --no-global \
           ++global-ok the-sandman \
           ++global-ok sync-on-channel \
           ++global-ok post-shutdown-action \
-          ++global-ok get-subprocesses-time
+          ++global-ok get-subprocesses-time \
+          ++global-ok force-atomic-timeout-callback
 
 GENERATE_ARGS = -t main.rkt --submod main \
                 --check-depends $(BUILDDIR)compiled/thread-dep.rktd \

racket/src/thread/schedule.rkt

@@ -82,7 +82,7 @@
           (check-for-break)
           (when atomic-timeout-callback
             (when (positive? (current-atomic))
-              (atomic-timeout-callback))))
+              (atomic-timeout-callback #f))))
         (lambda args
           (start-implicit-atomic-mode)
           (accum-cpu-time! t)
@@ -235,6 +235,14 @@
     atomic-timeout-callback
     (set! atomic-timeout-callback cb)))
 
+
+(void (set-force-atomic-timeout-callback!
+       (lambda ()
+         (and atomic-timeout-callback
+              (begin
+                (atomic-timeout-callback #t)
+                #t)))))
+
 ;; ----------------------------------------
 
 (define check-place-activity void)

racket/src/thread/thread.rkt

@@ -82,6 +82,8 @@
            check-for-break
            current-break-suspend
 
+           set-force-atomic-timeout-callback!
+
            break-max))
 
 ;; Exports needed by "place.rkt":
@@ -387,6 +389,10 @@
   (define sleeping (sandman-add-sleeping-thread! t ext-events))
   (set-thread-sleeping! t sleeping))
 
+(define force-atomic-timeout-callback void)
+(define (set-force-atomic-timeout-callback! proc)
+  (set! force-atomic-timeout-callback proc))
+
 ;; in atomic mode
 ;; Removes a thread from its thread group, so it won't be scheduled;
 ;; returns a thunk to be called in out of atomic mode to swap out the
@@ -405,8 +411,11 @@
   ;; by a custodian callback
   (lambda ()
     (when (eq? t (current-thread))
-      (when (positive? (current-atomic))
+      (let loop ()
-        (internal-error "attempt to deschedule the current thread in atomic mode"))
+        (when (positive? (current-atomic))
+          (if (force-atomic-timeout-callback)
+              (loop)
+              (internal-error "attempt to deschedule the current thread in atomic mode"))))
       (engine-block)
       (check-for-break))))