io: fix pipe slow path and GC
Make the slow path faster by reducing input- and output-end coordination. Also, avoid retaining one end just because the other end is retained. This change involves adding an indirection for the fast-path buffers so that management for both ends of a pipe can be centralized independent of the ports.
This commit is contained in:
Matthew Flatt
parent
f0aa8573fe
commit
e266da929d
|
|
@ -26,11 +26,12 @@
|
|||
(check who output-port? out)
|
||||
(let ([out (->core-output-port out)])
|
||||
(start-atomic)
|
||||
(define pos (core-port-buffer-pos out))
|
||||
(define buffer (core-port-buffer out))
|
||||
(define pos (direct-pos buffer))
|
||||
(cond
|
||||
[(pos . fx< . (core-port-buffer-end out))
|
||||
(bytes-set! (core-port-buffer out) pos b)
|
||||
(set-core-port-buffer-pos! out (fx+ pos 1))
|
||||
[(pos . fx< . (direct-end buffer))
|
||||
(bytes-set! (direct-bstr buffer) pos b)
|
||||
(set-direct-pos! buffer (fx+ pos 1))
|
||||
(when (core-port-count out)
|
||||
(port-count-byte! out b))
|
||||
(end-atomic)]
|
||||
|
|
|
|||
|
|
@ -33,8 +33,9 @@
|
|||
;; in atomic mode
|
||||
[in-buffer-pos
|
||||
(lambda ()
|
||||
(if buffer
|
||||
buffer-pos
|
||||
(define b buffer)
|
||||
(if (direct-bstr b)
|
||||
(direct-pos b)
|
||||
pos))])
|
||||
|
||||
(override
|
||||
|
|
@ -43,19 +44,21 @@
|
|||
(set! commit-manager #f) ; to indicate closed
|
||||
(progress!)
|
||||
(set! bstr #f)
|
||||
(when buffer
|
||||
(set! offset buffer-pos)
|
||||
(set! buffer #f)))]
|
||||
(define b buffer)
|
||||
(when (direct-bstr b)
|
||||
(set! offset (direct-pos b))
|
||||
(set-direct-bstr! b #f)))]
|
||||
[file-position
|
||||
(case-lambda
|
||||
[() (or alt-pos (in-buffer-pos))]
|
||||
[(given-pos)
|
||||
(define len buffer-end)
|
||||
(define b buffer)
|
||||
(define len (direct-end b))
|
||||
(define new-pos (if (eof-object? given-pos)
|
||||
len
|
||||
(min len given-pos)))
|
||||
(if buffer
|
||||
(set! buffer-pos new-pos)
|
||||
(if (direct-bstr b)
|
||||
(set-direct-pos! b new-pos)
|
||||
(set! pos new-pos))
|
||||
(set! alt-pos (and (not (eof-object? given-pos))
|
||||
(given-pos . > . new-pos)
|
||||
|
|
@ -67,16 +70,17 @@
|
|||
|
||||
[read-in
|
||||
(lambda (dest-bstr start end copy?)
|
||||
(define len buffer-end)
|
||||
(define b buffer)
|
||||
(define len (direct-end b))
|
||||
(define i (in-buffer-pos))
|
||||
(cond
|
||||
[(i . < . len)
|
||||
(define amt (min (- end start) (fx- len i)))
|
||||
(define new-pos (fx+ i amt))
|
||||
;; Keep/resume fast mode
|
||||
(set! buffer-pos new-pos)
|
||||
(set-direct-pos! b new-pos)
|
||||
(set! offset 0)
|
||||
(set! buffer bstr)
|
||||
(set-direct-bstr! b bstr)
|
||||
(bytes-copy! dest-bstr start bstr i new-pos)
|
||||
(progress!)
|
||||
amt]
|
||||
|
|
@ -84,8 +88,9 @@
|
|||
|
||||
[peek-in
|
||||
(lambda (dest-bstr start end skip progress-evt copy?)
|
||||
(define b buffer)
|
||||
(define len (direct-end b))
|
||||
(define i (in-buffer-pos))
|
||||
(define len buffer-end)
|
||||
(define at-pos (+ i skip))
|
||||
(cond
|
||||
[(and progress-evt (sync/timeout 0 progress-evt))
|
||||
|
|
@ -98,19 +103,20 @@
|
|||
|
||||
[byte-ready
|
||||
(lambda (work-done!)
|
||||
((in-buffer-pos) . < . buffer-end))]
|
||||
((in-buffer-pos) . < . (direct-end buffer)))]
|
||||
|
||||
[get-progress-evt
|
||||
(lambda ()
|
||||
(atomically
|
||||
(unless progress-sema
|
||||
;; set port to slow mode:
|
||||
(when buffer
|
||||
(define i buffer-pos)
|
||||
(define b buffer)
|
||||
(when (direct-bstr b)
|
||||
(define i (direct-pos b))
|
||||
(set! pos i)
|
||||
(set! offset i)
|
||||
(set! buffer #f)
|
||||
(set! buffer-pos buffer-end)))
|
||||
(set-direct-bstr! b #f)
|
||||
(set-direct-pos! b (direct-end b))))
|
||||
(make-progress-evt)))]
|
||||
|
||||
[commit
|
||||
|
|
@ -119,32 +125,23 @@
|
|||
progress-evt ext-evt
|
||||
;; in atomic mode, maybe in a different thread:
|
||||
(lambda ()
|
||||
(define len buffer-end)
|
||||
(define b buffer)
|
||||
(define len (direct-end b))
|
||||
(define i (in-buffer-pos))
|
||||
(let ([amt (min amt (- len i))])
|
||||
(define dest-bstr (make-bytes amt))
|
||||
(bytes-copy! dest-bstr 0 bstr i (+ i amt))
|
||||
;; Keep/resume fast mode
|
||||
(set! buffer-pos (fx+ i amt))
|
||||
(set! buffer bstr)
|
||||
(set-direct-pos! b (fx+ i amt))
|
||||
(set-direct-bstr! b bstr)
|
||||
(set! offset 0)
|
||||
(progress!)
|
||||
(finish dest-bstr)))))]
|
||||
|
||||
[count-lines!
|
||||
(lambda ()
|
||||
(when buffer
|
||||
(define i buffer-pos)
|
||||
(set! offset i)
|
||||
(set! pos i)
|
||||
(set! buffer #f)
|
||||
(set! buffer-pos buffer-end)))]))
|
||||
(finish dest-bstr)))))]))
|
||||
|
||||
(define (make-input-bytes bstr name)
|
||||
(new bytes-input-port
|
||||
[name name]
|
||||
[buffer bstr]
|
||||
[buffer-end (bytes-length bstr)]
|
||||
[buffer (direct bstr 0 (bytes-length bstr))]
|
||||
[bstr bstr]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
|
@ -180,19 +177,21 @@
|
|||
|
||||
[slow-mode!
|
||||
(lambda ()
|
||||
(when buffer
|
||||
(define s buffer-pos)
|
||||
(define b buffer)
|
||||
(when (direct-bstr b)
|
||||
(define s (direct-pos b))
|
||||
(set! pos s)
|
||||
(set! buffer-pos buffer-end)
|
||||
(set! buffer #f)
|
||||
(set-direct-pos! b (direct-end b))
|
||||
(set-direct-bstr! b #f)
|
||||
(set! offset s)
|
||||
(set! max-pos (fxmax s max-pos))))]
|
||||
|
||||
[fast-mode!
|
||||
(lambda ()
|
||||
(set! buffer bstr)
|
||||
(set! buffer-pos pos)
|
||||
(set! buffer-end (bytes-length bstr))
|
||||
(define b buffer)
|
||||
(set-direct-bstr! b bstr)
|
||||
(set-direct-pos! b pos)
|
||||
(set-direct-end! b (bytes-length bstr))
|
||||
(set! offset 0))])
|
||||
|
||||
(override
|
||||
|
|
@ -214,7 +213,9 @@
|
|||
(port-count! out v bstr start)))]
|
||||
[file-position
|
||||
(case-lambda
|
||||
[() (if buffer buffer-pos pos)]
|
||||
[()
|
||||
(define b buffer)
|
||||
(if (direct-bstr b) (direct-pos b) pos)]
|
||||
[(new-pos)
|
||||
(slow-mode!)
|
||||
(define len (bytes-length bstr))
|
||||
|
|
|
|||
|
|
@ -207,7 +207,7 @@
|
|||
|
||||
;; in atomic mode
|
||||
(define (increment-offset! in amt)
|
||||
(unless (core-port-buffer in)
|
||||
(unless (direct-bstr (core-port-buffer in))
|
||||
(define old-offset (core-port-offset in))
|
||||
(when old-offset
|
||||
(set-core-port-offset! in (+ amt old-offset)))))
|
||||
|
|
|
|||
|
|
@ -126,24 +126,26 @@
|
|||
[fast-mode!
|
||||
(lambda (amt) ; amt = not yet added to `offset`
|
||||
(when (eq? buffer-mode 'block)
|
||||
(define b buffer)
|
||||
(define e end-pos)
|
||||
(set! buffer bstr)
|
||||
(set! buffer-pos e)
|
||||
(set! buffer-end (bytes-length bstr))
|
||||
(set-direct-bstr! b bstr)
|
||||
(set-direct-pos! b e)
|
||||
(set-direct-end! b (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)
|
||||
(define b buffer)
|
||||
(when (direct-bstr b)
|
||||
(set-direct-bstr! b #f)
|
||||
(define pos (direct-pos b))
|
||||
(set! end-pos pos)
|
||||
(define o offset)
|
||||
(when o
|
||||
(set! offset (+ o pos)))
|
||||
(set! buffer-pos buffer-end)))])
|
||||
(set-direct-pos! b (direct-end b))))])
|
||||
|
||||
(public
|
||||
[on-close (lambda () (void))]
|
||||
|
|
@ -257,7 +259,8 @@
|
|||
(case-lambda
|
||||
[()
|
||||
(define pos (get-file-position fd))
|
||||
(and pos (+ pos (fx- (if buffer buffer-pos end-pos) start-pos)))]
|
||||
(define b buffer)
|
||||
(and pos (+ pos (fx- (if (direct-bstr b) (direct-pos b) end-pos) start-pos)))]
|
||||
[(pos)
|
||||
(flush-buffer-fully #f)
|
||||
;; flushing can leave atomic mode, so make sure the
|
||||
|
|
|
|||
|
|
@ -40,7 +40,8 @@
|
|||
|
||||
[buffer-adjust-pos
|
||||
(lambda (i)
|
||||
(- i (fx- end-pos (if buffer buffer-pos pos))))]
|
||||
(define b buffer)
|
||||
(- i (fx- end-pos (if (direct-bstr b) (direct-pos b) pos))))]
|
||||
|
||||
;; in atomic mode
|
||||
[default-buffer-mode
|
||||
|
|
@ -93,10 +94,11 @@
|
|||
;; in atomic mode
|
||||
[fast-mode!
|
||||
(lambda (amt) ; amt = not yet added to `offset`
|
||||
(set! buffer bstr)
|
||||
(define b buffer)
|
||||
(set-direct-bstr! b bstr)
|
||||
(define s pos)
|
||||
(set! buffer-pos s)
|
||||
(set! buffer-end end-pos)
|
||||
(set-direct-pos! b s)
|
||||
(set-direct-end! b end-pos)
|
||||
(define o offset)
|
||||
(when o
|
||||
(set! offset (- (+ o amt) s))))]
|
||||
|
|
@ -104,14 +106,15 @@
|
|||
;; in atomic mode
|
||||
[slow-mode!
|
||||
(lambda ()
|
||||
(when buffer
|
||||
(define s buffer-pos)
|
||||
(define b buffer)
|
||||
(when (direct-bstr b)
|
||||
(define s (direct-pos b))
|
||||
(define o offset)
|
||||
(when o
|
||||
(set! offset (+ o s)))
|
||||
(set! pos s)
|
||||
(set! buffer #f)
|
||||
(set! buffer-pos buffer-end)))])
|
||||
(set-direct-bstr! b #f)
|
||||
(set-direct-pos! b (direct-end b))))])
|
||||
|
||||
(override
|
||||
;; in atomic mode
|
||||
|
|
@ -159,7 +162,8 @@
|
|||
(sync/timeout 0 progress-evt))
|
||||
#f]
|
||||
[else
|
||||
(define s (if buffer buffer-pos pos))
|
||||
(define b buffer)
|
||||
(define s (if (direct-bstr b) (direct-pos b) pos))
|
||||
(define peeked-amt (fx- end-pos s))
|
||||
(cond
|
||||
[(peeked-amt . > . skip)
|
||||
|
|
@ -180,7 +184,8 @@
|
|||
[byte-ready
|
||||
(lambda (work-done!)
|
||||
(let loop ()
|
||||
(define peeked-amt (fx- end-pos (if buffer buffer-pos pos)))
|
||||
(define b buffer)
|
||||
(define peeked-amt (fx- end-pos (if (direct-bstr b) (direct-pos b) pos)))
|
||||
(cond
|
||||
[(peeked-amt . fx> . 0) #t]
|
||||
[peeked-eof? #t]
|
||||
|
|
|
|||
|
|
@ -47,11 +47,9 @@
|
|||
[else
|
||||
(raise-argument-error 'pipe-contact-length "(or/c pipe-input-port? pipe-output-port?)" p)]))
|
||||
(atomically
|
||||
(let ([input (pipe-data-input d)])
|
||||
(when input (send pipe-input-port input sync-data)))
|
||||
(let ([output (pipe-data-output d)])
|
||||
(when output (send pipe-output-port output sync-data)))
|
||||
(send pipe-data d content-length)))
|
||||
(with-object pipe-data d
|
||||
(sync-both)
|
||||
(content-length))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -63,18 +61,46 @@
|
|||
[peeked-amt 0] ; peeked but not yet read, effectively extends `limit`
|
||||
[start 0]
|
||||
[end 0]
|
||||
[input #f] ; #f => closed
|
||||
[output #f] ; #f => closed
|
||||
[input-ref #f] ; #f => closed
|
||||
[output-ref #f] ; #f => closed
|
||||
[input-buffer #f]
|
||||
[output-buffer #f]
|
||||
[read-ready-sema #f]
|
||||
[write-ready-sema #f]
|
||||
[more-read-ready-sema #f] ; for lookahead peeks
|
||||
[read-ready-evt #f]
|
||||
[write-ready-evt #f])
|
||||
|
||||
;; All methods in atomic mode.
|
||||
;; Beware that the input port must be synced to sure that `start`
|
||||
;; represents the current position before using these methods.
|
||||
(private)
|
||||
|
||||
;; All static methods in atomic mode.
|
||||
(static
|
||||
;; sync local fields with input buffer without implying slow mode
|
||||
[sync-input
|
||||
(lambda ()
|
||||
(define b input-buffer)
|
||||
(when (direct-bstr b)
|
||||
(define pos (direct-pos b))
|
||||
(set! start (if (fx= pos len)
|
||||
0
|
||||
pos))))]
|
||||
;; sync local fields with output buffer without implying slow mode
|
||||
[sync-output
|
||||
(lambda ()
|
||||
(define b output-buffer)
|
||||
(when (direct-bstr b)
|
||||
(define pos (direct-pos b))
|
||||
(set! end (if (fx= pos len)
|
||||
0
|
||||
pos))))]
|
||||
|
||||
|
||||
[sync-both
|
||||
(lambda ()
|
||||
(sync-input)
|
||||
(sync-output))]
|
||||
|
||||
;; assumes sync'ed
|
||||
[content-length
|
||||
(lambda ()
|
||||
(define s start)
|
||||
|
|
@ -83,40 +109,34 @@
|
|||
(fx- e s)
|
||||
(fx+ e (fx- len s))))]
|
||||
|
||||
;; assumes sync'ed
|
||||
[input-empty?
|
||||
(lambda ()
|
||||
(fx= start end))]
|
||||
|
||||
;; assumes sync'ed
|
||||
[output-full?
|
||||
(lambda ()
|
||||
(define l limit)
|
||||
(and l
|
||||
((content-length) . >= . (+ l peeked-amt))))]
|
||||
|
||||
;; Used before/after read:
|
||||
;; Used before read:
|
||||
[check-output-unblocking
|
||||
(lambda ()
|
||||
(when (output-full?) (semaphore-post write-ready-sema)))]
|
||||
[check-input-blocking
|
||||
(lambda ()
|
||||
(when (input-empty?)
|
||||
(semaphore-wait read-ready-sema)
|
||||
(when output
|
||||
(send pipe-output-port output on-input-empty))))]
|
||||
(when write-ready-sema
|
||||
(semaphore-post write-ready-sema)
|
||||
(set! write-ready-sema #f)))]
|
||||
|
||||
;; Used before/after write:
|
||||
;; Used before write:
|
||||
[check-input-unblocking
|
||||
(lambda ()
|
||||
(when (and (input-empty?) output) (semaphore-post read-ready-sema))
|
||||
(when read-ready-sema
|
||||
(semaphore-post read-ready-sema)
|
||||
(set! read-ready-sema #f))
|
||||
(when more-read-ready-sema
|
||||
(semaphore-post more-read-ready-sema)
|
||||
(set! more-read-ready-sema #f)))]
|
||||
[check-output-blocking
|
||||
(lambda ()
|
||||
(when (output-full?)
|
||||
(semaphore-wait write-ready-sema)
|
||||
(when input
|
||||
(send pipe-input-port input on-output-full))))]
|
||||
|
||||
;; Used after peeking:
|
||||
[peeked!
|
||||
|
|
@ -125,6 +145,9 @@
|
|||
(check-output-unblocking)
|
||||
(set! peeked-amt amt)))]))
|
||||
|
||||
(define (make-ref v) (make-weak-box v))
|
||||
(define (ref-value r) (weak-box-value r))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(class pipe-input-port #:extends commit-input-port
|
||||
|
|
@ -138,12 +161,10 @@
|
|||
(define s start)
|
||||
(define e end)
|
||||
(unless (fx= s e)
|
||||
(set! buffer bstr)
|
||||
(set! buffer-pos s)
|
||||
;; don't read last byte, because the output
|
||||
;; end needs to know about a transition to
|
||||
;; the empty state
|
||||
(set! buffer-end (fx- (if (s . fx< . e) e len) 1))
|
||||
(define b buffer)
|
||||
(set-direct-bstr! b bstr)
|
||||
(set-direct-pos! b s)
|
||||
(set-direct-end! b (if (s . fx< . e) e len))
|
||||
(define o offset)
|
||||
(when o
|
||||
(set! offset (- (+ o amt) s))))))]
|
||||
|
|
@ -151,34 +172,18 @@
|
|||
[slow-mode!
|
||||
(lambda ()
|
||||
(with-object pipe-data d
|
||||
(when buffer
|
||||
(define pos buffer-pos)
|
||||
(define b buffer)
|
||||
(when (direct-bstr b)
|
||||
(define pos (direct-pos b))
|
||||
(define o offset)
|
||||
(when o
|
||||
(set! offset (+ o pos)))
|
||||
(set! start (if (fx= pos len) 0 pos))
|
||||
(set! buffer #f)
|
||||
(set! buffer-pos buffer-end))
|
||||
(define out output)
|
||||
(when out
|
||||
(send pipe-output-port out sync-data))))])
|
||||
(set-direct-bstr! b #f)
|
||||
(set-direct-pos! b (direct-end b)))
|
||||
(sync-output)))])
|
||||
|
||||
(static
|
||||
[sync-data
|
||||
(lambda ()
|
||||
(when buffer
|
||||
(with-object pipe-data d
|
||||
(define pos buffer-pos)
|
||||
(set! start (if (fx= pos len)
|
||||
0
|
||||
pos)))))]
|
||||
[sync-data-both
|
||||
(lambda ()
|
||||
(sync-data)
|
||||
(with-object pipe-data d
|
||||
(define out output)
|
||||
(when out
|
||||
(send pipe-output-port out sync-data))))]
|
||||
[on-resize
|
||||
(lambda ()
|
||||
(slow-mode!))]
|
||||
|
|
@ -199,7 +204,7 @@
|
|||
(with-object pipe-data d
|
||||
(cond
|
||||
[(input-empty?)
|
||||
(if output
|
||||
(if output-ref
|
||||
read-ready-evt
|
||||
eof)]
|
||||
[else
|
||||
|
|
@ -222,7 +227,6 @@
|
|||
(set! start (modulo (fx+ s amt) len))
|
||||
(set! peeked-amt (fxmax 0 (fx- peeked-amt amt)))
|
||||
amt]))
|
||||
(check-input-blocking)
|
||||
(progress!)
|
||||
(fast-mode! amt)
|
||||
amt])))]
|
||||
|
|
@ -231,7 +235,7 @@
|
|||
(lambda (dest-bstr dest-start dest-end skip progress-evt copy?)
|
||||
(with-object pipe-data d
|
||||
(assert-atomic)
|
||||
(sync-data-both)
|
||||
(sync-both)
|
||||
(define content-amt (content-length))
|
||||
(cond
|
||||
[(and progress-evt
|
||||
|
|
@ -239,12 +243,13 @@
|
|||
#f]
|
||||
[(content-amt . <= . skip)
|
||||
(cond
|
||||
[(not output) eof]
|
||||
[(not output-ref) eof]
|
||||
[else
|
||||
(unless (or (zero? skip) more-read-ready-sema)
|
||||
(set! more-read-ready-sema (make-semaphore))
|
||||
(when output
|
||||
(send pipe-output-port output on-need-more-ready)))
|
||||
(define out (ref-value output-ref))
|
||||
(when out
|
||||
(send pipe-output-port out on-need-more-ready)))
|
||||
(define evt (if (zero? skip)
|
||||
read-ready-evt
|
||||
(wrap-evt (semaphore-peek-evt more-read-ready-sema)
|
||||
|
|
@ -270,17 +275,17 @@
|
|||
(lambda (work-done!)
|
||||
(assert-atomic)
|
||||
(with-object pipe-data d
|
||||
(or (not output)
|
||||
(or (not output-ref)
|
||||
(begin
|
||||
(sync-data-both)
|
||||
(sync-both)
|
||||
(not (fx= 0 (content-length)))))))]
|
||||
|
||||
[close
|
||||
(lambda ()
|
||||
(with-object pipe-data d
|
||||
(when input
|
||||
(when input-ref
|
||||
(slow-mode!)
|
||||
(set! input #f)
|
||||
(set! input-ref #f)
|
||||
(progress!))))]
|
||||
|
||||
[get-progress-evt
|
||||
|
|
@ -288,7 +293,7 @@
|
|||
(atomically
|
||||
(with-object pipe-data d
|
||||
(cond
|
||||
[(not input) always-evt]
|
||||
[(not input-ref) always-evt]
|
||||
[else
|
||||
(slow-mode!)
|
||||
(make-progress-evt)]))))]
|
||||
|
|
@ -330,7 +335,6 @@
|
|||
(set! start (fxmodulo (fx+ s amt) len))
|
||||
(progress!)
|
||||
(fast-mode! amt)
|
||||
(check-input-blocking)
|
||||
(finish dest-bstr)])))))]))]
|
||||
|
||||
[count-lines!
|
||||
|
|
@ -348,25 +352,22 @@
|
|||
(lambda (amt) ; amt = not yet added to `offset`
|
||||
(with-object pipe-data d
|
||||
(define lim limit)
|
||||
(define avail (and lim (- lim (content-length)
|
||||
;; don't fill last byte, because the input
|
||||
;; end needs to know about a trasition to the
|
||||
;; full state
|
||||
1)))
|
||||
(define avail (and lim (- lim (content-length))))
|
||||
(when (or (not avail) (avail . <= . 0))
|
||||
(define s start)
|
||||
(define e end)
|
||||
(set! buffer bstr)
|
||||
(set! buffer-pos e)
|
||||
(set! buffer-end (let ([end (if (s . fx<= . e)
|
||||
(if (fx= s 0)
|
||||
(fx- len 1)
|
||||
len)
|
||||
(fx- s 1))])
|
||||
(if (and avail
|
||||
((fx- end e) . > . avail))
|
||||
(fx+ e avail)
|
||||
end)))
|
||||
(define e end)
|
||||
(define b buffer)
|
||||
(set-direct-bstr! b bstr)
|
||||
(set-direct-pos! b e)
|
||||
(set-direct-end! b (let ([end (if (s . fx<= . e)
|
||||
(if (fx= s 0)
|
||||
(fx- len 1)
|
||||
len)
|
||||
(fx- s 1))])
|
||||
(if (and avail
|
||||
((fx- end e) . > . avail))
|
||||
(fx+ e avail)
|
||||
end)))
|
||||
(define o offset)
|
||||
(when o
|
||||
(set! offset (- (+ o amt) e))))))]
|
||||
|
|
@ -374,34 +375,18 @@
|
|||
[slow-mode!
|
||||
(lambda ()
|
||||
(with-object pipe-data d
|
||||
(when buffer
|
||||
(define pos buffer-pos)
|
||||
(define b buffer)
|
||||
(when (direct-bstr b)
|
||||
(define pos (direct-pos b))
|
||||
(define o offset)
|
||||
(when o
|
||||
(set! offset (+ o pos)))
|
||||
(set! end (if (fx= pos len) 0 pos))
|
||||
(set! buffer #f)
|
||||
(set! buffer-pos buffer-end))
|
||||
(define in input)
|
||||
(when in
|
||||
(send pipe-input-port in sync-data))))])
|
||||
(set-direct-bstr! b #f)
|
||||
(set-direct-pos! b (direct-end b)))
|
||||
(sync-input)))])
|
||||
|
||||
(static
|
||||
[sync-data
|
||||
(lambda ()
|
||||
(when buffer
|
||||
(with-object pipe-data d
|
||||
(define pos buffer-pos)
|
||||
(set! end (if (fx= pos len)
|
||||
0
|
||||
pos)))))]
|
||||
[sync-data-both
|
||||
(lambda ()
|
||||
(sync-data)
|
||||
(with-object pipe-data d
|
||||
(define in input)
|
||||
(when in
|
||||
(send pipe-output-port in sync-data #f))))]
|
||||
[on-input-empty
|
||||
(lambda ()
|
||||
(slow-mode!))]
|
||||
|
|
@ -416,7 +401,6 @@
|
|||
(assert-atomic)
|
||||
(slow-mode!)
|
||||
(with-object pipe-data d
|
||||
(send pipe-input-port input sync-data)
|
||||
(let try-again ()
|
||||
(define top-pos (if (fx= start 0)
|
||||
(fx- len 1)
|
||||
|
|
@ -426,7 +410,9 @@
|
|||
[(or (not limit)
|
||||
((+ limit peeked-amt) . > . (fx- len 1)))
|
||||
;; grow pipe size
|
||||
(send pipe-input-port input on-resize)
|
||||
(define in (ref-value input-ref))
|
||||
(when in
|
||||
(send pipe-input-port in on-resize))
|
||||
(define new-bstr (make-bytes (min+1 (and limit (+ limit peeked-amt)) (* len 2))))
|
||||
(cond
|
||||
[(fx= 0 start)
|
||||
|
|
@ -460,7 +446,6 @@
|
|||
(bytes-copy! bstr end src-bstr src-start (fx+ src-start amt))
|
||||
(let ([new-end (fx+ end amt)])
|
||||
(set! end (if (fx= new-end len) 0 new-end)))
|
||||
(check-output-blocking)
|
||||
(fast-mode! amt)
|
||||
amt])]
|
||||
[(fx= end top-pos)
|
||||
|
|
@ -476,7 +461,6 @@
|
|||
(check-input-unblocking)
|
||||
(bytes-copy! bstr 0 src-bstr src-start (fx+ src-start amt))
|
||||
(set! end amt)
|
||||
(check-output-blocking)
|
||||
(fast-mode! amt)
|
||||
amt])])]
|
||||
[(end . fx< . (fx- start 1))
|
||||
|
|
@ -488,7 +472,6 @@
|
|||
(check-input-unblocking)
|
||||
(bytes-copy! bstr end src-bstr src-start (fx+ src-start amt))
|
||||
(set! end (fx+ end amt))
|
||||
(check-output-blocking)
|
||||
(fast-mode! amt)
|
||||
amt])]
|
||||
[else
|
||||
|
|
@ -502,33 +485,25 @@
|
|||
;; in atomic mode
|
||||
(lambda ()
|
||||
(with-object pipe-data d
|
||||
(when output
|
||||
(when output-ref
|
||||
(slow-mode!)
|
||||
(set! output #f)
|
||||
(when write-ready-sema
|
||||
(semaphore-post write-ready-sema))
|
||||
(when more-read-ready-sema
|
||||
(semaphore-post more-read-ready-sema))
|
||||
(semaphore-post read-ready-sema))))]))
|
||||
(set! output-ref #f)
|
||||
(check-input-unblocking))))]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (make-pipe-ends [limit #f] [input-name 'pipe] [output-name 'pipe])
|
||||
(define len (min+1 limit 16))
|
||||
(define read-ready-sema (make-semaphore))
|
||||
(define write-ready-sema (and limit (make-semaphore 1)))
|
||||
(define write-ready-evt (if limit
|
||||
(semaphore-peek-evt write-ready-sema)
|
||||
always-evt))
|
||||
|
||||
(define d (new pipe-data
|
||||
[bstr (make-bytes len)]
|
||||
[len len]
|
||||
[limit limit]
|
||||
[read-ready-sema read-ready-sema]
|
||||
[write-ready-sema write-ready-sema]
|
||||
[read-ready-evt (wrap-evt (semaphore-peek-evt read-ready-sema)
|
||||
(lambda (v) 0))]
|
||||
[write-ready-evt write-ready-evt]))
|
||||
[limit limit]))
|
||||
|
||||
(define write-ready-evt (if limit
|
||||
(pipe-write-poller d)
|
||||
always-evt))
|
||||
(define read-ready-evt (pipe-read-poller d))
|
||||
|
||||
(define input (new pipe-input-port
|
||||
[name input-name]
|
||||
|
|
@ -538,8 +513,12 @@
|
|||
[evt write-ready-evt]
|
||||
[d d]))
|
||||
|
||||
(set-pipe-data-input! d input)
|
||||
(set-pipe-data-output! d output)
|
||||
(set-pipe-data-input-buffer! d (core-port-buffer input))
|
||||
(set-pipe-data-output-buffer! d (core-port-buffer output))
|
||||
(set-pipe-data-input-ref! d (make-ref input))
|
||||
(set-pipe-data-output-ref! d (make-ref output))
|
||||
(set-pipe-data-write-ready-evt! d write-ready-evt)
|
||||
(set-pipe-data-read-ready-evt! d read-ready-evt)
|
||||
|
||||
(values input output))
|
||||
|
||||
|
|
@ -550,3 +529,45 @@
|
|||
(port-count-lines! ip)
|
||||
(port-count-lines! op))
|
||||
(values ip op))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Note: a thread blocked on writing to a limited pipe cannot be GCed
|
||||
;; due to the use of `replace-evt`.
|
||||
(struct pipe-write-poller (d)
|
||||
#:property
|
||||
prop:evt
|
||||
(poller
|
||||
(lambda (pwp ctx)
|
||||
(with-object pipe-data (pipe-write-poller-d pwp)
|
||||
(sync-both)
|
||||
(cond
|
||||
[(not (output-full?))
|
||||
(values (list pwp) #f)]
|
||||
[else
|
||||
(unless write-ready-sema
|
||||
(set! write-ready-sema (make-semaphore)))
|
||||
(define in (ref-value input-ref))
|
||||
(when in
|
||||
(send pipe-input-port in on-output-full))
|
||||
(values #f (replace-evt (semaphore-peek-evt write-ready-sema)
|
||||
(lambda (v) pwp)))])))))
|
||||
|
||||
(struct pipe-read-poller (d)
|
||||
#:property
|
||||
prop:evt
|
||||
(poller
|
||||
(lambda (prp ctx)
|
||||
(with-object pipe-data (pipe-read-poller-d prp)
|
||||
(sync-both)
|
||||
(cond
|
||||
[(not (input-empty?))
|
||||
(values (list 0) #f)]
|
||||
[else
|
||||
(unless read-ready-sema
|
||||
(set! read-ready-sema (make-semaphore)))
|
||||
(define out (ref-value output-ref))
|
||||
(when out
|
||||
(send pipe-output-port out on-input-empty))
|
||||
(values #f (wrap-evt (semaphore-peek-evt read-ready-sema)
|
||||
(lambda (v) 0)))])))))
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
"evt.rkt")
|
||||
|
||||
(provide (struct-out core-port)
|
||||
(struct-out direct)
|
||||
(struct-out location)
|
||||
get-core-port-offset)
|
||||
|
||||
|
|
@ -14,23 +15,23 @@
|
|||
|
||||
[data #f] ; FIXME: remove after all uses are converted
|
||||
|
||||
;; When `buffer` is #f, it enables a shortcut for reading and
|
||||
;; writing, where `buffer-pos` must also be less than `buffer-end`
|
||||
;; for the shortcut to apply. The shortcut is not necessarily
|
||||
;; always taken, just if it is used, the `buffer-pos` position can
|
||||
;; be adjusted and the port's methods must adapt accordingly. The
|
||||
;; `buffer` and `buffer-end` fields are modified only by the port's
|
||||
;; methods, however.
|
||||
;; When `(direct-bstr buffer)` is not #f, it enables a shortcut for
|
||||
;; reading and writing, where `(direct-pos buffer)` must also be
|
||||
;; less than `(direct-end buffer)` for the shortcut to apply. The
|
||||
;; shortcut is not necessarily always taken, just if it is used,
|
||||
;; the `(direct-pos buffer)` position can be adjusted and the
|
||||
;; port's methods must adapt accordingly. The `(direct-bstr
|
||||
;; buffer)` and `(direct-end buffer)` fields are modified only by
|
||||
;; the port's methods, however.
|
||||
;;
|
||||
;; For an input port, shortcut mode implies that `prepare-change`
|
||||
;; does not need to be called, and no checking is needed for whether
|
||||
;; the port is closed.
|
||||
;;
|
||||
;; A non-#f `buffer` further implies that `buffer-pos` should be
|
||||
;; added to `offset` to get the true offset.
|
||||
[buffer #f]
|
||||
[buffer-pos 0] ; if < `buffer-end`, allows direct read/write on `buffer`
|
||||
[buffer-end 0]
|
||||
;; A non-#f `(direct-bstr buffer)` further implies that
|
||||
;; `(direct-pos buffer)` should be added to `offset` to get the
|
||||
;; true offset.
|
||||
[buffer (direct #f 0 0)]
|
||||
|
||||
[closed? #f]
|
||||
[closed-sema #f]
|
||||
|
|
@ -81,15 +82,22 @@
|
|||
[prop:object-name (struct-field-index name)]
|
||||
[prop:secondary-evt port->evt]))
|
||||
|
||||
(struct direct ([bstr #:mutable]
|
||||
[pos #:mutable]
|
||||
[end #:mutable])
|
||||
#:authentic)
|
||||
|
||||
(struct location ([state #:mutable] ; state of UTF-8 decoding
|
||||
[cr-state #:mutable] ; state of CRLF counting as a single LF
|
||||
[line #:mutable] ; count newlines
|
||||
[column #:mutable] ; count UTF-8 characters in line
|
||||
[position #:mutable])) ; count UTF-8 characters
|
||||
[position #:mutable]) ; count UTF-8 characters
|
||||
#:authentic)
|
||||
|
||||
(define (get-core-port-offset p)
|
||||
(define offset (core-port-offset p))
|
||||
(define buffer (core-port-buffer p))
|
||||
(and offset
|
||||
(if (core-port-buffer p)
|
||||
(+ offset (core-port-buffer-pos p))
|
||||
(if (direct-bstr buffer)
|
||||
(+ offset (direct-pos buffer))
|
||||
offset)))
|
||||
|
|
|
|||
|
|
@ -58,15 +58,16 @@
|
|||
(end-atomic)
|
||||
eof]
|
||||
[else
|
||||
(define buf-pos (core-port-buffer-pos in))
|
||||
(define buf-end (core-port-buffer-end in))
|
||||
(define buffer (core-port-buffer in))
|
||||
(define buf-pos (direct-pos buffer))
|
||||
(define buf-end (direct-end buffer))
|
||||
(cond
|
||||
[(buf-pos . fx< . buf-end)
|
||||
;; Read bytes directly from buffer
|
||||
(define v (fxmin (fx- buf-end buf-pos) (fx- end start)))
|
||||
(define new-pos (fx+ buf-pos v))
|
||||
(bytes-copy! bstr start (core-port-buffer in) buf-pos new-pos)
|
||||
(set-core-port-buffer-pos! in new-pos)
|
||||
(bytes-copy! bstr start (direct-bstr buffer) buf-pos new-pos)
|
||||
(set-direct-pos! buffer new-pos)
|
||||
(when (or (pair? extra-count-ins) (core-port-count in))
|
||||
(port-count-all! in extra-count-ins v bstr start))
|
||||
(end-atomic)
|
||||
|
|
@ -152,13 +153,14 @@
|
|||
(end-atomic)
|
||||
eof]
|
||||
[else
|
||||
(define buf-pos (+ (core-port-buffer-pos in) skip))
|
||||
(define buf-end (core-port-buffer-end in))
|
||||
(define buffer (core-port-buffer in))
|
||||
(define buf-pos (+ (direct-pos buffer) skip))
|
||||
(define buf-end (direct-end buffer))
|
||||
(cond
|
||||
[(buf-pos . < . buf-end)
|
||||
;; Copy bytes from buffer
|
||||
(define v (min (- buf-end buf-pos) (- end start)))
|
||||
(bytes-copy! bstr start (core-port-buffer in) buf-pos (fx+ buf-pos v))
|
||||
(bytes-copy! bstr start (direct-bstr buffer) buf-pos (fx+ buf-pos v))
|
||||
(end-atomic)
|
||||
v]
|
||||
[else
|
||||
|
|
@ -205,11 +207,12 @@
|
|||
;; Try the buffer shortcut first
|
||||
(define (read-a-byte who in #:special-ok? [special-ok? #f])
|
||||
(start-atomic)
|
||||
(define pos (core-port-buffer-pos in))
|
||||
(define buffer (core-port-buffer in))
|
||||
(define pos (direct-pos buffer))
|
||||
(cond
|
||||
[(pos . fx< . (core-port-buffer-end in))
|
||||
(define b (bytes-ref (core-port-buffer in) pos))
|
||||
(set-core-port-buffer-pos! in (fx+ pos 1))
|
||||
[(pos . fx< . (direct-end buffer))
|
||||
(define b (bytes-ref (direct-bstr buffer) pos))
|
||||
(set-direct-pos! buffer (fx+ pos 1))
|
||||
(when (core-port-count in)
|
||||
(port-count-byte! in b))
|
||||
(end-atomic)
|
||||
|
|
@ -232,10 +235,11 @@
|
|||
;; Try the buffer shortcut first
|
||||
(define (peek-a-byte who in skip-k #:special-ok? [special-ok? #f])
|
||||
(start-atomic)
|
||||
(define pos (+ (core-port-buffer-pos in) skip-k))
|
||||
(define buffer (core-port-buffer in))
|
||||
(define pos (+ (direct-pos buffer) skip-k))
|
||||
(cond
|
||||
[(pos . < . (core-port-buffer-end in))
|
||||
(define b (bytes-ref (core-port-buffer in) pos))
|
||||
[(pos . < . (direct-end buffer))
|
||||
(define b (bytes-ref (direct-bstr buffer) pos))
|
||||
(end-atomic)
|
||||
b]
|
||||
[else
|
||||
|
|
|
|||
|
|
@ -23,14 +23,15 @@
|
|||
(end-atomic)
|
||||
0]
|
||||
[else
|
||||
(define buf-pos (core-port-buffer-pos out))
|
||||
(define buf-end (core-port-buffer-end out))
|
||||
(define buffer (core-port-buffer out))
|
||||
(define buf-pos (direct-pos buffer))
|
||||
(define buf-end (direct-end buffer))
|
||||
(cond
|
||||
[(buf-pos . fx< . buf-end)
|
||||
;; Copy bytes directly to buffer
|
||||
(define v (fxmin (fx- buf-end buf-pos) (fx- end start)))
|
||||
(bytes-copy! (core-port-buffer out) buf-pos bstr start (fx+ start v))
|
||||
(set-core-port-buffer-pos! out (fx+ buf-pos v))
|
||||
(bytes-copy! (direct-bstr buffer) buf-pos bstr start (fx+ start v))
|
||||
(set-direct-pos! buffer (fx+ buf-pos v))
|
||||
(when (or (pair? extra-count-outs) (core-port-count out))
|
||||
(port-count-all! out extra-count-outs v bstr start))
|
||||
(end-atomic)
|
||||
|
|
|
|||
|
|
@ -133,7 +133,7 @@
|
|||
(sandman
|
||||
;; sleep
|
||||
(lambda (timeout-at)
|
||||
(host:sleep (/ (- (or timeout-at (distant-future)) (current-inexact-milliseconds)) 1000.0)))
|
||||
(host:sleep (max 0.0 (/ (- (or timeout-at (distant-future)) (current-inexact-milliseconds)) 1000.0))))
|
||||
|
||||
;; poll
|
||||
(lambda (mode wakeup)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user