cs: reduce the cost of entering & exiting atomic mode

racket/src/cs/demo/thread.ss

@@ -132,6 +132,29 @@
    (check tdelay (sync tdelay))
    (printf "[That break was from a thread, and it's expected]\n")
    (check #t (>= (current-inexact-milliseconds) (+ now3 0.1)))
+
+   (define got-here? #f)
+   (define break-self (thread (lambda ()
+                                (unsafe-start-atomic)
+                                (break-thread (current-thread))
+                                (unsafe-end-atomic)
+                                (set! got-here? #t))))
+   (check break-self (sync break-self))
+   (printf "[That break was from a thread, and it's expected]\n")
+   (check #f got-here?)
+   
+   (define break-self-immediate (thread (lambda ()
+                                          (dynamic-wind
+                                              void
+                                              (lambda ()
+                                                (unsafe-start-breakable-atomic)
+                                                (break-thread (current-thread))
+                                                (set! got-here? #t))
+                                              (lambda ()
+                                                (unsafe-end-atomic))))))
+   (check break-self-immediate (sync break-self-immediate))
+   (printf "[That break was from a thread, and it's expected]\n")
+   (check #f got-here?)
    
    ;; Make sure breaks are disabled in a `dynamic-wind` post thunk
    (define dw-s (make-semaphore))

racket/src/cs/rumble/virtual-register.ss

@@ -1,7 +1,7 @@
 ;; We get a small number of virtual registers for fast,
 ;; pthread-specific bindings.
 
-;; The last two virtual registers are reserved for use by the thread system
+;; The last few virtual registers are reserved for use by the thread system
 (meta define num-reserved-virtual-registers 2)
 
 (meta define virtual-register-initial-values '())
@@ -11,8 +11,8 @@
     [(_ id init-val)
      (with-syntax ([pos (datum->syntax #'here (length virtual-register-initial-values))])
        (set! virtual-register-initial-values (cons #'init-val virtual-register-initial-values))
-       (when (>= (length virtual-register-initial-values) (- (virtual-register-count)
+       (when (> (length virtual-register-initial-values) (- (virtual-register-count)
-                                                             num-reserved-virtual-registers))
+                                                            num-reserved-virtual-registers))
          (syntax-error stx "too many virtual-register definitions:"))
        #`(define-syntax id
            (syntax-rules ()

racket/src/cs/thread.sls

@@ -42,17 +42,17 @@
   ;; Special handling of `current-atomic`: use the last virtual register;
   ;; we rely on the fact that the register's default value is 0.
   (define-syntax (define stx)
-    (syntax-case stx (current-atomic current-break-suspend make-pthread-parameter unsafe-make-place-local)
+    (syntax-case stx (current-atomic end-atomic-callback make-pthread-parameter unsafe-make-place-local)
       ;; Recognize definition of `current-atomic`:
       [(_ current-atomic (make-pthread-parameter 0))
        (with-syntax ([(_ id _) stx]
-                     [n (datum->syntax #'here (sub1 (virtual-register-count)))])
+                     [n (datum->syntax #'here (- (virtual-register-count) 1))])
          #'(define-syntax id
              (syntax-rules ()
                [(_) (virtual-register n)]
                [(_ v) (set-virtual-register! n v)])))]
-      ;; Recognize definition of `current-break-suspend`:
+      ;; Recognize definition of `end-atomic-callback`:
-      [(_ current-break-suspend (make-pthread-parameter 0))
+      [(_ end-atomic-callback (make-pthread-parameter 0))
        (with-syntax ([(_ id _) stx]
                      [n (datum->syntax #'here (- (virtual-register-count) 2))])
          #'(define-syntax id

racket/src/io/port/bytes-port.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require "../common/check.rkt"
+(require racket/fixnum
+         "../common/check.rkt"
          "../common/fixnum.rkt"
          "../common/object.rkt"
          "../host/thread.rkt"
@@ -74,9 +75,9 @@
    (method
     (lambda ()
       (let ([pos i])
-        (if (pos . < . len)
+        (if (pos . fx< . len)
             (begin
-              (set! i (add1 pos))
+              (set! i (fx+ pos 1))
               (progress!)
               (bytes-ref bstr pos))
             eof))))

racket/src/io/port/read-and-peek.rkt

@@ -192,14 +192,14 @@
          [(eof-object? b)
           (end-atomic)
           b]
-         [(evt? b)
+         [(fixnum? b)
-          (end-atomic)
-          (sync b)
-          (loop)]
-         [else
           (port-count-byte! in b)
           (end-atomic)
-          b])])))
+          b]
+         [else ; must be an evt
+          (end-atomic)
+          (sync b)
+          (loop)])])))
 
 ;; Use the general path; may return a procedure for a special
 (define (read-byte-via-bytes in #:special-ok? [special-ok? #t])

racket/src/thread/atomic.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require "host.rkt"
+(require racket/fixnum
+         "host.rkt"
          "place-local.rkt"
          "internal-error.rkt"
          "debug.rkt")
@@ -16,7 +17,7 @@
 
          in-atomic-mode?
 
-         set-end-atomic-callback!
+         add-end-atomic-callback!
 
          start-implicit-atomic-mode
          end-implicit-atomic-mode
@@ -41,25 +42,35 @@
      (end-atomic/no-interrupts))))
 
 (define (start-atomic)
-  (current-atomic (add1 (current-atomic))))
+  (current-atomic (fx+ (current-atomic) 1)))
 
 (define (end-atomic)
-  (define n (sub1 (current-atomic)))
+  (define n (fx- (current-atomic) 1))
   (cond
-    [(and end-atomic-callback
+    [(fx= n 0)
-          (zero? n))
+     (if (eq? 0 (end-atomic-callback))
-     (define cb end-atomic-callback)
+         (current-atomic n)
-     (set! end-atomic-callback #f)
+         (do-end-atomic-callback))]
-     (current-atomic n)
+    [(fx< n 0) (bad-end-atomic)]
-     (cb)]
-    [(negative? n) (internal-error "not in atomic mode to end")]
     [else
      ;; There's a small chance that `end-atomic-callback`
      ;; was set by the scheduler after the check and
      ;; before we exit atomic mode. Make sure that rare
-     ;; event is ok.
+     ;; possibility remains ok.
      (current-atomic n)]))
 
+(define (do-end-atomic-callback)
+  (define cbs (end-atomic-callback))
+  (end-atomic-callback 0)
+  (current-atomic 0)
+  (let loop ([cbs cbs])
+    (unless (eq? cbs 0)
+      ((car cbs))
+      (loop (cdr cbs)))))
+
+(define (bad-end-atomic)
+  (internal-error "not in atomic mode to end"))
+
 (define (start-atomic/no-interrupts)
   (start-atomic)
   (host:disable-interrupts))
@@ -73,11 +84,18 @@
 
 ;; ----------------------------------------
 
-(define-place-local end-atomic-callback #f)
+;; A "list" of callbacks to run when exiting atomic mode,
-
+;; but the list is terminated by 0 insteda of '().
-(define (set-end-atomic-callback! cb)
+;; This definition is converted to a virtual register on
-  (set! end-atomic-callback cb))
+;; Chez Scheme, which explains why 0 is the "none" value.
+(define end-atomic-callback (make-pthread-parameter 0))
 
+;; in atomic mode, but need to disable interrupts to ensure
+;; no race with the scheduler
+(define (add-end-atomic-callback! cb)
+  (host:disable-interrupts)
+  (end-atomic-callback (cons cb (end-atomic-callback)))
+  (host:enable-interrupts))
 
 ;; ----------------------------------------
 

racket/src/thread/schedule.rkt

@@ -114,7 +114,7 @@
              ;; Swap out when the atomic region ends and at a point
              ;; where host-system interrupts are not disabled (i.e.,
              ;; don't use `engine-block` instead of `engine-timeout`):
-             (set-end-atomic-callback! engine-timeout)
+             (add-end-atomic-callback! engine-timeout)
              (loop e)])))))))
 
 (define (maybe-done callbacks)
@@ -185,10 +185,8 @@
 ;; Run foreign "async-apply" callbacks, now that we're in some thread
 (define (run-callbacks callbacks)
   (start-atomic)
-  (current-break-suspend (add1 (current-break-suspend)))
   (for ([callback (in-list callbacks)])
     (callback))
-  (current-break-suspend (sub1 (current-break-suspend)))
   (end-atomic))
 
 ;; ----------------------------------------

racket/src/thread/thread.rkt

@@ -40,7 +40,7 @@
          break-enabled
          check-for-break
          break-enabled-key
-         current-break-suspend
+         current-breakable-atomic
          
          thread-push-kill-callback!
          thread-pop-kill-callback!
@@ -80,7 +80,6 @@
 
            current-break-enabled-cell
            check-for-break
-           current-break-suspend
 
            set-force-atomic-timeout-callback!
 
@@ -722,8 +721,10 @@
 ;; A continuation-mark key (not made visible to regular Racket code):
 (define break-enabled-default-cell (make-thread-cell #t))
 
-;; For disabling breaks, such as through `unsafe-start-atomic`:
+;; For enable breaks despite atomic mode, such as through
-(define current-break-suspend (make-pthread-parameter 0))
+;; `unsafe-start-breakable-atomic`; breaks are enabled as long as
+;; `current-atomic` does not exceed `current-breakable-atomic`:
+(define current-breakable-atomic (make-pthread-parameter 0))
 
 (define (current-break-enabled-cell)
   (continuation-mark-set-first #f
@@ -754,7 +755,7 @@
         [(and (thread-pending-break t)
               (break-enabled)
               (not (thread-ignore-break-cell? t (current-break-enabled-cell)))
-              (zero? (current-break-suspend)))
+              (>= (add1 (current-breakable-atomic)) (current-atomic)))
          (define exn:break* (case (thread-pending-break t)
                               [(hang-up) exn:break:hang-up/non-engine]
                               [(terminate) exn:break:terminate/non-engine]
@@ -804,7 +805,9 @@
              (thread-reschedule! t))))
        void])))
   (when (eq? t check-t)
-    (check-for-break)))
+    (check-for-break)
+    (when (in-atomic-mode?)
+      (add-end-atomic-callback! check-for-break))))
 
 (define (break>? k1 k2)
   (cond

racket/src/thread/unsafe.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require "atomic.rkt"
+(require racket/fixnum
+         "atomic.rkt"
          "thread.rkt"
          "schedule.rkt"
          "evt.rkt")
@@ -12,21 +13,18 @@
          unsafe-set-on-atomic-timeout!)
 
 (define (unsafe-start-breakable-atomic)
-  (start-atomic))
+  (start-atomic)
+  (current-breakable-atomic (fx+ (current-breakable-atomic) 1)))
 
 (define (unsafe-end-breakable-atomic)
+  (current-breakable-atomic (fx- (current-breakable-atomic) 1))
   (end-atomic))
 
 (define (unsafe-start-atomic)
-  (start-atomic)
+  (start-atomic))
-  (current-break-suspend (add1 (current-break-suspend))))
 
 (define (unsafe-end-atomic)
-  (define bs (sub1 (current-break-suspend)))
+  (end-atomic))
-  (current-break-suspend bs)
-  (end-atomic)
-  (when (zero? bs)
-    (check-for-break)))
 
 (define (unsafe-in-atomic?)
   (positive? (current-atomic)))