io: make fd-output-port use the fast path

racket/src/io/common/class.rkt

@@ -115,28 +115,30 @@
           [() (values new-fields new-methods override-methods locals statics properties)]
           [((field fld ...) . rest)
            (loop #'rest
-                 (add-procs id (syntax->list #'(fld ...)) "field" #:can-immutable? #t)
+                 (append new-fields
-                 new-methods
+                         (add-procs id (syntax->list #'(fld ...)) "field" #:can-immutable? #t))
-                 override-methods
+                 new-methods override-methods locals statics properties)]
-                 locals
-                 statics
-                 properties)]
           [((public method ...) . rest)
-           (loop #'rest
+           (loop #'rest new-fields
-                 new-fields
+                 (append new-methods
-                 (add-procs methods-id (syntax->list #'(method ...)) "public")
+                         (add-procs methods-id (syntax->list #'(method ...)) "public"))
-                 override-methods
+                 override-methods locals statics properties)]
-                 locals
-                 statics
-                 properties)]
           [((override method ...) . rest)
-           (loop #'rest new-fields new-methods (syntax->list #'(method ...)) locals statics properties)]
+           (loop #'rest new-fields new-methods
+                 (append override-methods (syntax->list #'(method ...)))
+                 locals statics properties)]
           [((private method ...) . rest)
-           (loop #'rest new-fields new-methods override-methods (syntax->list #'(method ...)) statics properties)]
+           (loop #'rest new-fields
+                 new-methods override-methods
+                 (append locals (syntax->list #'(method ...)))
+                 statics properties)]
           [((static method ...) . rest)
-           (loop #'rest new-fields new-methods override-methods locals (syntax->list #'(method ...)) properties)]
+           (loop #'rest new-fields new-methods override-methods locals
+                 (append statics (syntax->list #'(method ...)))
+                 properties)]
           [((property prop ...) . rest)
-           (loop #'rest new-fields new-methods override-methods locals statics (syntax->list #'((#:property . prop) ...)))]
+           (loop #'rest new-fields new-methods override-methods locals statics
+                 (append properties (syntax->list #'((#:property . prop) ...))))]
           [(other . _)
            (raise-syntax-error #f "unrecognized" stx #'other)]))))
   (define all-fields (if super-ci

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

@@ -120,6 +120,29 @@
    [buffer-mode 'block]
    [custodian-reference #f])
 
+  (static
+   [fast-mode!
+    (lambda (amt) ; amt = not yet added to `offset`
+      (when (eq? buffer-mode 'block)
+        (define e end-pos)
+        (set! buffer bstr)
+        (set! buffer-pos e)
+        (set! buffer-end (bytes-length bstr))
+        (define o offset)
+        (when o
+          (set! offset (- (+ o amt) e)))))]
+
+   [slow-mode!
+    (lambda ()
+      (when buffer
+        (set! buffer #f)
+        (define pos buffer-pos)
+        (set! end-pos pos)
+        (define o offset)
+        (when o
+          (set! offset (+ o pos)))
+        (set! buffer-pos buffer-end)))])
+
   (public
     [on-close (lambda () (void))]
     [raise-write-error
@@ -131,6 +154,7 @@
    ;; Returns `#t` if the buffer is already or successfully flushed
    [flush-buffer
     (lambda ()
+      (slow-mode!)
       (cond
         [(not (fx= start-pos end-pos))
          (define n (rktio_write_in rktio fd bstr start-pos end-pos))
@@ -184,6 +208,7 @@
     ;; in atomic mode
     [write-out
      (lambda (src-bstr src-start src-end nonbuffer/nonblock? enable-break? copy?)
+       (slow-mode!)
        (cond
          [(fx= src-start src-end)
           ;; Flush request
@@ -194,10 +219,10 @@
           (define amt (fxmin (fx- src-end src-start) (fx- (bytes-length bstr) end-pos)))
           (bytes-copy! bstr end-pos src-bstr src-start (fx+ src-start amt))
           (set! end-pos (fx+ end-pos amt))
-          (unless nonbuffer/nonblock?
           (when (eq? buffer-mode 'line)
             ;; can temporarily leave atomic mode:
-              (flush-buffer-fully-if-newline src-bstr src-start src-end enable-break?)))
+            (flush-buffer-fully-if-newline src-bstr src-start src-end enable-break?))
+          (fast-mode! amt)
           amt]
          [(not (flush-buffer)) ; <- can temporarily leave atomic mode
           #f]