thread & io: performance improvement

Part of this change restores a `++direct` that was lost in 98ae91e0ba
for "racket/src/thread" to make the atomicity state a virtual
register. Also make `display` on a byte string more directly call
`write-bytes`. That change restores a 5-10% speed improvement for
`racketcs -cl racket/base`.

racket/src/expander/extract/primitive-table.rkt

@@ -4,8 +4,8 @@
 ;; Replace
 ;;  (hash-ref (or (primitive-table '<table>) ...) <id> [default])
 ;; with just <id> if <table> is in `primitive-table-directs`.
-(define (substitute-primitive-table-access s primitive-table-directs)
+(define (substitute-primitive-table-access l primitive-table-directs)
-  (let loop ([s s])
+  (define (subst s)
     (cond
       [(primitive-table-lookup-match s)
        => (lambda (tables+id)
@@ -17,8 +17,25 @@
                (string->symbol (string-append prefix (symbol->string (cdr tables+id))))]
               [else s]))]
       [(pair? s)
-       (cons (loop (car s)) (loop (cdr s)))]
+       (cons (subst (car s)) (subst (cdr s)))]
-      [else s])))
+      [else s]))
+  (let loop ([l l])
+    (cond
+      [(null? l) null]
+      [else
+       (let ([s (car l)])
+         ;; Watch out for `(define x x)` and drop it
+         (cond
+           [(and (pair? s)
+                 (eq? 'define-values (car s))
+                 (pair? (cadr s))
+                 (null? (cdadr s)))
+            (define rhs (subst (caddr s)))
+            (if (eq? rhs (caadr s))
+                (loop (cdr l))
+                (cons `(define-values ,(cadr s) ,rhs)
+                      (loop (cdr l))))]
+           [else (cons (subst s) (loop (cdr l)))]))])))
 
 (define (primitive-table-lookup-match s)
   (cond

racket/src/io/Makefile

@@ -7,6 +7,10 @@ RACO = $(RACKET) -N raco -l- raco
 # Can be set to empty to avoid building rktio
 RKTIO_DEP=../build/so-rktio/Makefile
 
+# When flattening, replace a dynamic lookup from a primitive table to
+# a direct use of the primitive name:
+DIRECT = ++direct thread
+
 io-src: $(RKTIO_DEP)
 	$(RACO) make ../expander/bootstrap-run.rkt
 	$(MAKE) io-src-generate
@@ -18,7 +22,7 @@ GENERATE_ARGS = -t main.rkt --submod main \
                 --depends $(BUILDDIR)compiled/io-dep.rktd \
                 --makefile-depends $(DEPENDSDIR)compiled/io.rktl $(BUILDDIR)compiled/io.d \
                 -c $(BUILDDIR)compiled/cache-src \
-                -k ../.. -s -x \
+                -k ../.. -s -x $(DIRECT) \
                 -o $(BUILDDIR)compiled/io.rktl
 
 # This target can be used with a `RACKET` that builds via `-l- setup --chain ...`

racket/src/io/host/bootstrap.rkt

@@ -96,8 +96,8 @@
                          'async-evt async-evt
                          'schedule-info-current-exts schedule-info-current-exts
                          'current-sandman current-sandman
-                         'start-atomic start-atomic
+                         'unsafe-start-atomic start-atomic
-                         'end-atomic end-atomic
+                         'unsafe-end-atomic end-atomic
                          'start-atomic/no-interrupts start-atomic
                          'end-atomic/no-interrupts end-atomic
                          'in-atomic-mode? in-atomic-mode?

racket/src/io/host/thread.rkt

@@ -1,7 +1,10 @@
 #lang racket/base
-(require (only-in '#%linklet primitive-table))
+(require racket/private/primitive-table
+         (only-in '#%linklet primitive-table))
 
-(provide atomically
+(provide start-atomic
+         end-atomic
+         atomically
          non-atomically
          atomically/no-interrupts/no-wind
          assert-atomic
@@ -11,14 +14,21 @@
   (or (primitive-table '#%thread)
       (error '#%thread "scheduler cooperation not supported by host")))
 
-(define-syntax bounce
+(define-syntax-rule (bounce id ...)
-  (syntax-rules ()
-    [(_ id)
   (begin
-       (provide id)
+    (provide id ...)
-       (define id (hash-ref table 'id)))]
+    (import-from-primitive-table
-    [(_ id ...)
+     (#%thread)
-     (begin (bounce id) ...)]))
+     id ...)))
+
+;; Values with `bounce*` cannot be redirected
+;; to refer directly to exports of `thread`,
+;; generally because there's no such export
+(define-syntax-rule (bounce* id ...)
+  (begin
+    (provide id ...)
+    (define id (hash-ref table 'id))
+    ...))
 
 (bounce make-semaphore
         semaphore-post
@@ -26,13 +36,17 @@
         semaphore-peek-evt
         wrap-evt
         always-evt
-        choice-evt ; raw variant that takes a list of evts
         sync
         sync/timeout
         evt?
-        sync-atomic-poll-evt?
         prop:evt
+        unsafe-start-atomic
+        unsafe-end-atomic
+        current-custodian)
+
+(bounce* choice-evt ; raw variant that takes a list of evts
          prop:secondary-evt
+         sync-atomic-poll-evt?
          poller
          poller-evt
          poll-ctx-poll?
@@ -44,18 +58,18 @@
          async-evt
          schedule-info-current-exts
          current-sandman
-        start-atomic
-        end-atomic
          start-atomic/no-interrupts ; => disable GC, too, if GC can call back
          end-atomic/no-interrupts
          in-atomic-mode?
-        current-custodian
          unsafe-custodian-register
          unsafe-custodian-unregister
          thread-push-kill-callback!
          thread-pop-kill-callback!
          set-get-subprocesses-time!)
 
+(define start-atomic unsafe-start-atomic)
+(define end-atomic unsafe-end-atomic)
+
 (define-syntax-rule (atomically e ...)
   (begin
     (start-atomic)

racket/src/io/print/main.rkt

@@ -58,9 +58,17 @@
     (void)))
 
 (define (do-display who v o [max-length #f])
+  (cond
+    [(and (bytes? v) (not max-length))
+     (write-bytes v o)
+     (void)]
+    [(and (string? v) (not max-length))
+     (write-string v o)
+     (void)]
+    [else
      (define config (make-print-config))
      (dots (p who v DISPLAY-MODE o (sub3 max-length) (detect-graph v DISPLAY-MODE config) config) o)
-  (void))
+     (void)]))
 
 (define/who (write v [o (current-output-port)])
   (check who output-port? o)

racket/src/thread/Makefile

@@ -8,13 +8,17 @@ thread-src:
 	$(RACO) make ../expander/bootstrap-run.rkt
 	$(MAKE) thread-src-generate
 
+# When flattening, replace a dynamic lookup from a primitive table to
+# a direct use of the primitive name:
+DIRECT = ++direct pthread
+
 GENERATE_ARGS = -t main.rkt --submod main \
                 --check-depends $(BUILDDIR)compiled/thread-dep.rktd \
                 ++depend-module ../expander/bootstrap-run.rkt \
                 --depends $(BUILDDIR)compiled/thread-dep.rktd \
                 --makefile-depends $(DEPENDSDIR)compiled/thread.rktl $(BUILDDIR)compiled/thread.d \
                 -c $(BUILDDIR)compiled/cache-src \
-                -k ../.. -s -x \
+                -k ../.. -s -x $(DIRECT) \
                 -o $(BUILDDIR)compiled/thread.rktl
 
 # This target can be used with a `RACKET` that builds via `-l- setup --chain ...`

racket/src/thread/instance.rkt

@@ -7,6 +7,7 @@
          "atomic.rkt"
          "custodian.rkt"
          "thread.rkt"
+         "unsafe.rkt"
          "time.rkt")
 
 ;; Unsafe scheduler-cooperation functions are made available to
@@ -39,8 +40,8 @@
           'current-sandman current-sandman
           'schedule-info-current-exts schedule-info-current-exts
           'schedule-info-did-work! schedule-info-did-work!
-          'start-atomic start-atomic
+          'unsafe-start-atomic unsafe-start-atomic
-          'end-atomic end-atomic
+          'unsafe-end-atomic unsafe-end-atomic
           'start-atomic/no-interrupts start-atomic/no-interrupts
           'end-atomic/no-interrupts end-atomic/no-interrupts
           'in-atomic-mode? in-atomic-mode?