cs: repair shared poll set initialization
Esspecially affects filesystem change events on Mac OS and BSDs.
This commit is contained in:
parent
5c7d7aae68
commit
535bfcb0c3
26
pkgs/racket-test/tests/racket/stress/fs-change.rkt
Normal file
26
pkgs/racket-test/tests/racket/stress/fs-change.rkt
Normal 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))))
|
|
@ -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))
|
||||
|
|
|
@ -31,7 +31,7 @@
|
|||
(define-place-local shared-ltps (make-ltps))
|
||||
|
||||
(define (shared-ltps-place-init!)
|
||||
(make-ltps))
|
||||
(set! shared-ltps (make-ltps)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user