cs: further reduce allocation during thread swapping

racket/src/cs/rumble.sls

@@ -53,7 +53,6 @@
           engine-timeout
           engine-return
           call-with-engine-completion
-          current-engine-state
           set-ctl-c-handler!
           get-ctl-c-handler
           set-scheduler-lock-callbacks!

racket/src/cs/rumble/control.ss

@@ -337,7 +337,7 @@
                         (#%apply values r)))])))))]))))
 
 ;; Simplified `call-in-empty-metacontinuation-frame` suitable for swapping engines:
-(define (call-in-empty-metacontinuation-frame-for-swap proc)
+(define (call-with-empty-metacontinuation-frame-for-swap proc)
   (assert-in-uninterrupted)
   (assert-not-in-system-wind)
   (call/cc
@@ -355,7 +355,7 @@
        (current-winders '())
        (current-mark-splice empty-mark-frame)
        (current-metacontinuation (cons mf (current-metacontinuation)))
-       (let ([r (proc)])
+       (let ([r (proc (current-metacontinuation))])
          (let ([mf (car (current-metacontinuation))])
            (pop-metacontinuation-frame)
            ((metacontinuation-frame-resume-k mf) r)))))))
@@ -1423,8 +1423,8 @@
      (maybe-future-barricade orig-tag)
      (let ([tag (strip-impersonator orig-tag)])
        (cond
-        [(#%procedure? k)
+        [(#%procedure? k) ; => an engine
-         (let ([mc (saved-metacontinuation-mc (k))])
+         (let ([mc (k)])
            (make-continuation-mark-set
             (prune-mark-chain-suffix
              who
@@ -1900,9 +1900,7 @@
 ;; ----------------------------------------
 ;; Metacontinuation swapping for engines
 
-(define-record saved-metacontinuation (mc system-winders exn-state))
+(define empty-metacontinuation '())
-
-(define empty-metacontinuation (make-saved-metacontinuation '() '() (create-exception-state)))
 
 ;; Similar to `call-with-current-continuation` plus
 ;; applying an old continuation, but does not run winders;
@@ -1913,17 +1911,10 @@
    [(current-system-wind-start-k)
     => (lambda (k) (call-with-current-metacontinuation-with-system-wind proc k))]
    [else
-    (call-in-empty-metacontinuation-frame-for-swap
+    (call-with-empty-metacontinuation-frame-for-swap proc)]))
-     (lambda ()
-       (proc (make-saved-metacontinuation
-              (current-metacontinuation)
-              (#%$current-winders)
-              (current-exception-state)))))]))
 
 (define (apply-meta-continuation saved k)
-  (current-metacontinuation (saved-metacontinuation-mc saved))
+  (current-metacontinuation saved)
-  (#%$current-winders (saved-metacontinuation-system-winders saved))
-  (current-exception-state (saved-metacontinuation-exn-state saved))
   (k))
 
 ;; ----------------------------------------

racket/src/cs/rumble/engine.ss

@@ -11,7 +11,7 @@
 
 (define-record engine-state (complete-or-expire thread-cell-values init-break-enabled-cell))
 
-(define-virtual-register current-engine-state #f)
+(define-virtual-register current-engine-state (make-engine-state #f #f #f))
 
 (define (set-ctl-c-handler! proc)
   (keyboard-interrupt-handler (case-lambda
@@ -26,6 +26,18 @@
 (define (set-engine-exit-handler! proc)
   (set! engine-exit proc))
 
+(define (currently-in-engine?)
+  (engine-state-complete-or-expire (current-engine-state)))
+
+(define (set-current-engine-state! complete-or-expire thread-cell-values init-break-enabled-cell)
+  (let ([es (current-engine-state)])
+    (set-engine-state-complete-or-expire! es complete-or-expire)
+    (set-engine-state-thread-cell-values! es thread-cell-values)
+    (set-engine-state-init-break-enabled-cell! es init-break-enabled-cell)))
+
+(define (clear-current-engine-state!)
+  (set-current-engine-state! #f #f #f))
+
 ;; An engine is repesented by a procedure that takes three arguments, where the
 ;; procedure must be tail-called either within `call-with-engine-completion` or
 ;; in an engine call's `complete-or-expire` callback:
@@ -81,9 +93,7 @@
     (apply-meta-continuation
      to-saves
      (lambda ()
-       (current-engine-state
+       (set-current-engine-state! complete-or-expire thread-cell-values init-break-enabled-cell)
-        (make-engine-state complete-or-expire thread-cell-values init-break-enabled-cell))
-       (reset-handler engine-reset-handler)
        (timer-interrupt-handler engine-block-via-timer)
        (end-implicit-uninterrupted 'create)
        (set-timer ticks)
@@ -95,18 +105,25 @@
 (define (call-with-engine-completion proc)
   (call-with-current-metacontinuation
    (lambda (saves)
-     (let ([rh (reset-handler)])
+     (let ([rh (reset-handler)]
+           [ws (#%$current-winders)]
+           [exns (current-exception-state)])
+       (reset-handler engine-reset-handler)
+       (#%$current-winders '())
+       (current-exception-state (create-exception-state))
        (proc (lambda args
-               (current-engine-state #f)
+               (clear-current-engine-state!)
                (apply-meta-continuation
                 saves
                 (lambda ()
                   (reset-handler rh)
+                  (#%$current-winders ws)
+                  (current-exception-state exns)
                   (#%apply values args)))))))))
 
 (define (engine-reset-handler)
   (end-uninterrupted 'reset)
-  (if (current-engine-state)
+  (if (currently-in-engine?)
       (engine-return (void))
       (chez:exit)))
 
@@ -122,25 +139,25 @@
    [(timeout?)
     (assert-not-in-uninterrupted)
     (timer-interrupt-handler void)
-    (let ([es (current-engine-state)]
+    (let ([complete-or-expire (engine-state-complete-or-expire (current-engine-state))]
+          [thread-cell-values (engine-state-thread-cell-values (current-engine-state))]
+          [init-break-enabled-cell (engine-state-init-break-enabled-cell (current-engine-state))]
           [remain-ticks (if timeout?
                             0
                             (set-timer 0))])
-      (unless es
+      (unless complete-or-expire
         (error 'engine-block "not currently running an engine"))
       (start-implicit-uninterrupted 'block)
       (call-with-current-metacontinuation
        (lambda (saves)
          (end-implicit-uninterrupted 'block)
-         (current-engine-state #f)
+         (clear-current-engine-state!)
-         ((engine-state-complete-or-expire es)
+         (complete-or-expire (create-engine saves
-          (create-engine
+                                            (lambda (prefix) (prefix))
-           saves
+                                            thread-cell-values
-           (lambda (prefix) (prefix))
+                                            init-break-enabled-cell)
-           (engine-state-thread-cell-values es)
+                             #f
-           (engine-state-init-break-enabled-cell es))
+                             remain-ticks))))]
-          #f
-          remain-ticks))))]
    [() (engine-block #f)]))
 
 (define (engine-block/timeout)
@@ -160,16 +177,16 @@
 (define (engine-return . results)
   (assert-not-in-uninterrupted)
   (timer-interrupt-handler void)
-  (let ([es (current-engine-state)])
+  (let ([complete-or-expire (engine-state-complete-or-expire (current-engine-state))])
-    (unless es
+    (unless complete-or-expire
       (error 'engine-return "not currently running an engine"))
     (let ([remain-ticks (set-timer 0)])
       (start-implicit-uninterrupted 'block)
       (call-with-current-metacontinuation
        (lambda (ignored-saves)
          (end-implicit-uninterrupted 'block)
-         (current-engine-state #f)
+         (clear-current-engine-state!)
-         ((engine-state-complete-or-expire es) #f results remain-ticks))))))
+         (complete-or-expire #f results remain-ticks))))))
 
 (define (make-empty-thread-cell-values)
   (make-ephemeron-eq-hashtable))
@@ -179,10 +196,8 @@
 (define original-thread-id (get-thread-id))
 
 (define (current-engine-thread-cell-values)
-  (let ([es (current-engine-state)])
+  (or (engine-state-thread-cell-values (current-engine-state))
-    (if es
+      (root-thread-cell-values)))
-        (engine-state-thread-cell-values es)
-        (root-thread-cell-values))))
 
 (define (set-current-engine-thread-cell-values! new-t)
   (let ([current-t (current-engine-thread-cell-values)])
@@ -209,7 +224,5 @@
     new-t))
 
 (define (current-engine-init-break-enabled-cell none-v)
-  (let ([es (current-engine-state)])
+  (or (engine-state-init-break-enabled-cell (current-engine-state))
-    (if es
+      none-v))
-        (engine-state-init-break-enabled-cell es)
-        none-v)))

racket/src/cs/rumble/foreign.ss

@@ -213,7 +213,7 @@
 (define/who (ptr-equal? p1 p2)
   (let ([p1 (unwrap-cpointer who p1)]
         [p2 (unwrap-cpointer who p2)])
-    (with-interrupts-disabled ; disable GC while extracting addresses
+    (with-interrupts-disabled* ; disable GC while extracting addresses
      (= (cpointer-address p1) (cpointer-address p2)))))
 
 (define/who (ptr-offset p)
@@ -900,7 +900,7 @@
               (eq? 'utf-16be host-rep)
               (eq? 'utf-32le host-rep)
               (eq? 'utf-32be host-rep))
-          (let ([v (with-interrupts-disabled
+          (let ([v (with-interrupts-disabled*
                     (foreign-ref 'uptr (cpointer-address p) 0))])
             (case host-rep
               [(utf-16le) (utf16->string (uptr->bytes/2-byte-nul v) 'little #t)]
@@ -909,7 +909,7 @@
               [(utf-32be) (utf16->string (uptr->bytes/4-byte-nul v) 'big #t)]))]
          [else
           ;; Disable interrupts to avoid a GC:
-          (with-interrupts-disabled
+          (with-interrupts-disabled*
            ;; Special treatment is needed for 'scheme-object, since the
            ;; host Scheme rejects the use of 'scheme-object with
            ;; `foreign-ref`
@@ -1086,7 +1086,7 @@
                                  "atomic destination" orig-p)]
          [else
           ;; Disable interrupts to avoid a GC:
-          (with-interrupts-disabled
+          (with-interrupts-disabled*
            ;; Special treatment is needed for 'scheme-object, since
            ;; the host Scheme rejects the use of 'scheme-object with
            ;; `foreign-set!`
@@ -1133,7 +1133,7 @@
                                "destination" to
                                "source" from)])]
      [else
-      (with-interrupts-disabled
+      (with-interrupts-disabled*
        (let ([to (+ (cpointer*-address to) to-offset)]
              [from (+ (cpointer*-address from) from-offset)])
        (cond
@@ -1275,7 +1275,7 @@
       (raise-arguments-error 'memset "cannot set non-atomic"
                              "destination" to)]
      [else
-      (with-interrupts-disabled
+      (with-interrupts-disabled*
        (let ([to (fx+ (cpointer*-address to) to-offset)])
          (let loop ([to to] [len len])
            (unless (fx= len 0)
@@ -1420,7 +1420,7 @@
 
 (define/who (free p)
   (let ([p (unwrap-cpointer who p)])
-    (with-interrupts-disabled
+    (with-interrupts-disabled*
      (foreign-free (cpointer-address p)))))
 
 (define-record-type (cpointer/cell make-cpointer/cell cpointer/cell?)
@@ -1618,13 +1618,13 @@
                                                (make-ftype-pointer ,id p))))
                                      ids)
                                 '())))])
-            (let* ([wb (with-interrupts-disabled
+            (let* ([wb (with-interrupts-disabled*
                         (weak-hash-ref ffi-expr->code expr #f))]
                    [code (if wb (car wb) #!bwp)])
               (if (eq? code #!bwp)
                   (let ([code (eval/foreign expr (if call? 'comp-ffi-call 'comp-ffi-back))])
                     (hashtable-set! ffi-code->expr (car code) expr)
-                    (with-interrupts-disabled
+                    (with-interrupts-disabled*
                      (weak-hash-set! ffi-expr->code expr (weak-cons code #f)))
                     code)
                   code)))]
@@ -1667,24 +1667,24 @@
               [proc
                (case-lambda
                 [()
-                 (c->s out-type (with-interrupts-disabled (proc)))]
+                 (c->s out-type (with-interrupts-disabled* (proc)))]
                 [(orig-a)
                  (let ([a (unwrap orig-a (car in-types))])
                    (c->s out-type (retain
                                    orig-a
-                                   (with-interrupts-disabled (proc (unpack a (car in-types)))))))]
+                                   (with-interrupts-disabled* (proc (unpack a (car in-types)))))))]
                 [(orig-a orig-b)
                  (let ([a (unwrap orig-a (car in-types))]
                        [b (unwrap orig-b (cadr in-types))])
                    (c->s out-type (retain
                                    orig-a orig-b
-                                   (with-interrupts-disabled
+                                   (with-interrupts-disabled*
                                     (proc (unpack a (car in-types)) (unpack b (cadr in-types)))))))]
                 [(orig-a orig-b orig-c)
                  (let ([a (unwrap orig-a (car in-types))]
                        [b (unwrap orig-b (cadr in-types))]
                        [c (unwrap orig-c (caddr in-types))])
-                   (c->s out-type (with-interrupts-disabled
+                   (c->s out-type (with-interrupts-disabled*
                                    (retain
                                     orig-a orig-b orig-c
                                     (proc (unpack a (car in-types))
@@ -1697,21 +1697,21 @@
                        [d (unwrap orig-d (cadddr in-types))])
                    (c->s out-type (retain
                                    orig-a orig-b orig-c orig-d
-                                   (with-interrupts-disabled
+                                   (with-interrupts-disabled*
                                     (proc (unpack a (car in-types))
                                           (unpack b (cadr in-types))
                                           (unpack c (caddr in-types))
                                           (unpack d (cadddr in-types)))))))]
                 [orig-args
                  (let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)])
-                   (c->s out-type (with-interrupts-disabled
+                   (c->s out-type (with-interrupts-disabled*
                                    (retain
                                     orig-args
                                     (#%apply proc (map (lambda (a t) (unpack a t)) args in-types))))))])]
               [else
                (lambda orig-args
                  (let ([args (map (lambda (a t) (unwrap a t)) orig-args in-types)])
-                   (c->s out-type (with-interrupts-disabled
+                   (c->s out-type (with-interrupts-disabled*
                                    (retain
                                     orig-args
                                     (#%apply (gen-proc (cpointer-address proc-p))
@@ -1743,7 +1743,7 @@
                                              ;; result is a struct type; need to allocate space for it
                                              (normalized-malloc ret-size ret-malloc-mode))])
                            (when lock (mutex-acquire lock))
-                           (with-interrupts-disabled
+                           (with-interrupts-disabled*
                             (when blocking? (currently-blocking? #t))
                             (retain
                              orig-args

racket/src/cs/rumble/interrupt.ss

@@ -1,4 +1,16 @@
 
+;; Like `with-interrupts-disabled`, but with no winders
+;; and ways returning a single value. Avoiding winders
+;; is important in "foreign.ss" so htat callbacks do
+;; not return to a world with Scheme-level winders, which
+;; will not interact correctly with engines.
+(define-syntax-rule (with-interrupts-disabled* e0 e ...)
+  (begin
+    (disable-interrupts)
+    (let ([v (begin e0 e ...)])
+      (enable-interrupts)
+      v)))
+
 ;; Enabling uninterrupted mode defers a timer callback
 ;; until leaving uninterrupted mode. This is the same
 ;; as disabling and enabling interrupts at the Chez

racket/src/cs/rumble/memory.ss

@@ -95,7 +95,7 @@
                  (fx= gen (collect-maximum-generation)))
         (reachable-size-increments-callback compute-size-increments))
       (when (and (= gen (collect-maximum-generation))
-                 (current-engine-state))
+                 (currently-in-engine?))
         ;; This `set-timer` doesn't necessarily penalize the right thread,
         ;; but it's likely to penalize a thread that is allocating quickly:
         (set-timer 1))

racket/src/cs/thread.sls

@@ -12,7 +12,6 @@
                   [make-engine rumble:make-engine]
                   [engine-timeout rumble:engine-timeout]
                   [engine-return rumble:engine-return]
-                  [current-engine-state rumble:current-engine-state]
                   [call-with-engine-completion rumble:call-with-engine-completion]
                   [make-condition rumble:make-condition]
                   [condition-wait rumble:condition-wait]
@@ -132,7 +131,6 @@
         'make-engine rumble:make-engine
         'engine-timeout rumble:engine-timeout
         'engine-return rumble:engine-return
-        'current-engine-state (lambda (v) (rumble:current-engine-state v))
         'call-with-engine-completion rumble:call-with-engine-completion
         'set-ctl-c-handler! rumble:set-ctl-c-handler!
         'poll-will-executors poll-will-executors

racket/src/thread/bootstrap.rkt

@@ -280,8 +280,6 @@
                   'condition-broadcast (lambda args
                                          (error "condition-broadcast: not ready"))
                   'threaded? (lambda () #f)
-                  'current-engine-state (lambda args
-                                          (error "current-engine state: not ready"))
                   'make-mutex (lambda () (make-semaphore 1))
                   'mutex-acquire (lambda (s) (semaphore-wait s))
                   'mutex-release (lambda (s) (semaphore-post s))

racket/src/thread/host.rkt

@@ -36,7 +36,6 @@
         make-engine
         engine-timeout
         engine-return
-        current-engine-state
         call-with-engine-completion
         current-process-milliseconds
         set-ctl-c-handler!

racket/src/thread/schedule.rkt

@@ -33,7 +33,9 @@
   (make-initial-thread (lambda ()
                          (set-place-host-roots! initial-place (host:current-place-roots))
                          (thunk)))
-  (poll-and-select-thread! 0))
+  (call-with-engine-completion
+   (lambda (done)
+     (poll-and-select-thread! 0))))
 
 ;; Initializes the thread system in a new place:
 (define (call-in-another-main-thread c thunk)
@@ -41,8 +43,8 @@
   (set-root-custodian! c)
   (init-system-idle-evt!)
   (init-future-place!)
-  (call-in-main-thread thunk)
+  (init-schedule-counters!)
-  (init-schedule-counters!))
+  (call-in-main-thread thunk))
 
 ;; ----------------------------------------