cs: repair shared poll set initialization

Esspecially affects filesystem change events on Mac OS and BSDs.
This commit is contained in:
Matthew Flatt 2019-04-29 07:40:22 -06:00
parent 5c7d7aae68
commit 535bfcb0c3
4 changed files with 31 additions and 3 deletions

View File

@ -0,0 +1,26 @@
#lang racket/base
(require racket/place
racket/file)
(define (go)
(place
pch
(define path (make-temporary-file))
(call-with-output-file* path #:exists 'append void)
(for ([i (in-range 50)])
(define c (make-custodian))
(parameterize ([current-custodian c])
(define fcs
(for/list ([j (in-range 100)])
(define fc (filesystem-change-evt path))
(sync/timeout 0 fc)
(if (even? j)
(call-with-output-file* path #:exists 'append (lambda (o) (write-byte 48 o)))
(filesystem-change-evt-cancel fc))
fc))
(map sync fcs))
(custodian-shutdown-all c))
(delete-file path)))
(module+ main
(map place-wait (for/list ([i 4]) (go))))

View File

@ -28,6 +28,8 @@
rktio-place-init!)
(submod "error/main.rkt"
place-init)
(only-in "sandman/ltps.rkt"
shared-ltps-place-init!)
"port/place.rkt")
(provide (all-from-out "port/main.rkt")
@ -60,6 +62,7 @@
(sandman-place-init!)
(rktio-place-init!)
(logger-init!)
(shared-ltps-place-init!)
(install-error-value->string-handler!)
(init-current-directory!)
(init-current-ports! in-fd out-fd err-fd cust plumber))

View File

@ -31,7 +31,7 @@
(define-place-local shared-ltps (make-ltps))
(define (shared-ltps-place-init!)
(make-ltps))
(set! shared-ltps (make-ltps)))
;; ----------------------------------------

View File

@ -62,8 +62,7 @@
(define-place-local awoken-threads '())
(define (sandman-place-init!)
(set! lock (make-lock))
(shared-ltps-place-init!))
(set! lock (make-lock)))
(void
(current-sandman