cs: further reduce allocation during thread swapping

2019-10-04 15:51:35 -06:00 · 2019-10-04 15:51:35 -06:00 · d3d0bffb88
commit d3d0bffb88
parent f9e12dc9bc
10 changed files with 86 additions and 74 deletions
--- a/racket/src/cs/rumble.sls
+++ b/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!
--- a/racket/src/cs/rumble/control.ss
+++ b/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)
-         (let ([mc (saved-metacontinuation-mc (k))])
+        [(#%procedure? k) ; => an engine
+         (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 (make-saved-metacontinuation '() '() (create-exception-state)))
+(define empty-metacontinuation '())

 ;; 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
-     (lambda ()
-       (proc (make-saved-metacontinuation
-              (current-metacontinuation)
-              (#%$current-winders)
-              (current-exception-state)))))]))
+    (call-with-empty-metacontinuation-frame-for-swap proc)]))

 (define (apply-meta-continuation saved k)
-  (current-metacontinuation (saved-metacontinuation-mc saved))
-  (#%$current-winders (saved-metacontinuation-system-winders saved))
-  (current-exception-state (saved-metacontinuation-exn-state saved))
+  (current-metacontinuation saved)
  (k))

 ;; ----------------------------------------
--- a/racket/src/cs/rumble/engine.ss
+++ b/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
-        (make-engine-state complete-or-expire thread-cell-values init-break-enabled-cell))
-       (reset-handler engine-reset-handler)
+       (set-current-engine-state! complete-or-expire thread-cell-values init-break-enabled-cell)
       (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)))

@ -116,31 +133,31 @@
    (pending-interrupt-callback engine-block/timeout)]
   [else
    (engine-block/timeout)]))
-    
+
 (define engine-block
  (case-lambda
   [(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)
-         ((engine-state-complete-or-expire es)
-          (create-engine
-           saves
-           (lambda (prefix) (prefix))
-           (engine-state-thread-cell-values es)
-           (engine-state-init-break-enabled-cell es))
-          #f
-          remain-ticks))))]
+         (clear-current-engine-state!)
+         (complete-or-expire (create-engine saves
+                                            (lambda (prefix) (prefix))
+                                            thread-cell-values
+                                            init-break-enabled-cell)
+                             #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)])
-    (unless es
+  (let ([complete-or-expire (engine-state-complete-or-expire (current-engine-state))])
+    (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)
-         ((engine-state-complete-or-expire es) #f results remain-ticks))))))
+         (clear-current-engine-state!)
+         (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)])
-    (if es
-        (engine-state-thread-cell-values es)
-        (root-thread-cell-values))))
+  (or (engine-state-thread-cell-values (current-engine-state))
+      (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)])
-    (if es
-        (engine-state-init-break-enabled-cell es)
-        none-v)))
+  (or (engine-state-init-break-enabled-cell (current-engine-state))
+      none-v))
--- a/racket/src/cs/rumble/foreign.ss
+++ b/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
--- a/racket/src/cs/rumble/interrupt.ss
+++ b/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
--- a/racket/src/cs/rumble/memory.ss
+++ b/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))
--- a/racket/src/cs/thread.sls
+++ b/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
--- a/racket/src/thread/bootstrap.rkt
+++ b/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))
--- a/racket/src/thread/host.rkt
+++ b/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!
--- a/racket/src/thread/schedule.rkt
+++ b/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))

 ;; ----------------------------------------