suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: implement filesystem change events

Browse Source
This commit is contained in:
Matthew Flatt 2019-04-25 15:01:25 -06:00
parent 20672cd60a
commit 2d3ee903ec
16 changed files with 219 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "7.3.0.2")
(define version "7.3.0.3")
(define deps `("racket-lib"
["racket" #:version ,version]))

4
racket/src/cs/c/gen-system.rkt
View File

@ -44,7 +44,9 @@
'library-subpath-convention (if windows? 'windows 'unix)
'so-suffix (if windows? #".dll" (system-type 'so-suffix))
'so-mode 'local
'fs-change '#(#f #f #f #f)
'fs-change (if windows?
'#(supported scalable low-latency #f)
(system-type 'fs-change))
'target-machine (if (equal? "any" (vector-ref (current-command-line-arguments) 2))
#f
machine)))

1
racket/src/cs/rumble.sls
View File

@ -491,6 +491,7 @@
system-library-subpath-string ; not exported to Racket
set-get-machine-info! ; not exported to Racket
set-cross-mode! ; not exported to Racket
set-fs-change-properties! ; not exported to Racket
unsafe-car
unsafe-cdr

5
racket/src/cs/rumble/system.ss
View File

@ -14,6 +14,9 @@
(define cross-mode 'infer)
(define (set-cross-mode! m) (set! cross-mode m))
(define fs-change-properties '#(#f #f #f #f))
(define (set-fs-change-properties! vec) (set! fs-change-properties vec))
(define (system-type* mode)
(case mode
[(vm) 'chez-scheme]
@ -31,7 +34,7 @@
[(a6nt ta6nt i3nt ti3nt) (string->utf8 ".dll")]
[else (string->utf8 ".so")])]
[(so-mode) 'local]
[(fs-change) '#(#f #f #f #f)] ; when this changes, change "gen-system.rkt", too
[(fs-change) fs-change-properties]
[(target-machine) (machine-type)]
[(cross) cross-mode]
[else (raise-argument-error 'system-type

8
racket/src/expander/boot/handler.rkt
View File

@ -460,16 +460,12 @@
(cond
[(symbol? s)
(or (path-cache-get (cons s (get-reg)))
(performance-region
['eval 'resolve-symbol]
(let-values ([(cols file) (split-relative-string (symbol->string s) #f)])
(let* ([f-file (if (null? cols)
"main.rkt"
(string-append file ".rkt"))]
[col (if (null? cols) file (car cols))]
[col-path (if (null? cols) null (cdr cols))])
(performance-region
['eval 'resolve-find]
(find-col-file (if (not subm-path)
show-collection-err
;; Invent a fictional collection directory, if necessary,
@ -479,7 +475,7 @@
col
col-path
f-file
#t))))))]
#t))))]
[(string? s)
(let* ([dir (get-dir)])
(or (path-cache-get (cons s dir))
@ -540,6 +536,8 @@
[(symbol? s-parsed)
;; Return a genenerated symnol
(make-resolved-module-path
s-parsed
#;
(cons s-parsed subm-path))]
[(not (or (path? s-parsed)
(vector? s-parsed)))

13
racket/src/io/demo.rkt
View File

@ -765,6 +765,19 @@
;; ----------------------------------------
(call-with-output-file "compiled/demo-file3" void 'replace)
(define e (filesystem-change-evt "compiled/demo-file3" (lambda () 'no)))
(unless (eq? e 'no)
(test #t (evt? e))
;; (test #f (sync/timeout 0.01 e)) ; bootstrap doesn't handle this
(call-with-output-file "compiled/demo-file3" (lambda (o) (write-char #\x o)) 'append)
(test e (sync/timeout 0.01 e))
(test e (sync/timeout 0.01 e))
(filesystem-change-evt-cancel e))
(delete-file "compiled/demo-file3")
;; ----------------------------------------
'read-string
(time
(let loop ([j 10])

118
racket/src/io/filesystem-change-evt/main.rkt
View File

@ -1,17 +1,117 @@
#lang racket/base
(require "../common/check.rkt")
(require "../common/check.rkt"
"../path/path.rkt"
"../path/split.rkt"
"../format/main.rkt"
"../file/host.rkt"
"../file/error.rkt"
"../file/main.rkt"
"../host/rktio.rkt"
"../host/thread.rkt"
"../host/pthread.rkt"
"../sandman/main.rkt"
"../sandman/ltps.rkt")
(provide filesystem-change-evt?
filesystem-change-evt
filesystem-change-evt-cancel)
(define (filesystem-change-evt? v) #f)
(struct fs-change-evt ([rfc #:mutable]
[cust-ref #:mutable])
#:reflection-name 'filesystem-change-evt
#:property prop:evt (poller
;; in atomic mode
(lambda (fc ctx)
(define rfc (fs-change-evt-rfc fc))
(cond
[(not rfc) (values (list fc) #f)]
[(eqv? (rktio_poll_fs_change_ready rktio rfc) RKTIO_POLL_READY)
(values (list fc) #f)]
[else
(sandman-poll-ctx-add-poll-set-adder!
ctx
(lambda (ps)
(rktio_poll_add_fs_change rktio rfc ps)))
(values #f fc)]))))
(define filesystem-change-evt
(case-lambda
[(p) (error 'filesystem-change-evt "unsupported")]
[(p fail) (fail)]))
(define (filesystem-change-evt? v)
(fs-change-evt? v))
(define/who (filesystem-change-evt-cancel e)
(check who filesystem-change-evt? e)
(void))
(define/who (filesystem-change-evt p [fail (lambda ()
(raise (exn:fail:unsupported
"filesystem-change-evt: unsupported"
(current-continuation-marks))))])
(check who path-string? p)
(check who (procedure-arity-includes/c 0) fail)
(define fn (->host p who '(exists)))
(start-atomic)
(define file-rfc (rktio_fs_change rktio fn shared-ltps))
(define rfc
(cond
[(rktio-error? file-rfc)
(end-atomic)
(cond
[(and (zero? (bitwise-and (rktio_fs_change_properties rktio) RKTIO_FS_CHANGE_FILE_LEVEL))
(rktio_file_exists rktio fn))
;; try directory containing the file
(define-values (base name dir) (split-path (host-> fn)))
(define base-fn (->host base who '(exists)))
(start-atomic)
(rktio_fs_change rktio base-fn shared-ltps)]
[else
(start-atomic)
file-rfc])]
[else file-rfc]))
(cond
[(rktio-error? rfc)
(end-atomic)
(cond
[(racket-error? rfc RKTIO_ERROR_UNSUPPORTED)
(fail)]
[else
(raise-filesystem-error who rfc (format "error generating event\n path: ~a"
(host-> fn)))])]
[else
(define fc (fs-change-evt rfc #f))
(define cust-ref (unsafe-custodian-register (current-custodian)
fc
;; in atomic mode
(lambda (fc) (close-fc fc))
#f
#t))
(set-fs-change-evt-cust-ref! fc cust-ref)
(unsafe-add-global-finalizer fc (lambda () (close-fc fc)))
(end-atomic)
fc]))
(define/who (filesystem-change-evt-cancel fc)
(check who filesystem-change-evt? fc)
(start-atomic)
(close-fc fc)
(end-atomic))
;; in atomic mode
(define (close-fc fc)
(define rfc (fs-change-evt-rfc fc))
(when rfc
(unsafe-custodian-unregister fc (fs-change-evt-cust-ref fc))
(set-fs-change-evt-cust-ref! fc #f)
(set-fs-change-evt-rfc! fc #f)
(rktio_fs_change_forget rktio rfc)))
(void (set-fs-change-properties!
(let ([props (rktio_fs_change_properties rktio)])
(define (set? a b) (not (eqv? 0 (bitwise-and a b))))
(cond
[(and (set? props RKTIO_FS_CHANGE_NEED_LTPS)
(eq? shared-ltps rktio_NULL))
'#(#f #f #f #f)]
[else
(vector (and (set? props RKTIO_FS_CHANGE_SUPPORTED)
'supported)
(and (set? props RKTIO_FS_CHANGE_SCALABLE)
'scalable)
(and (set? props RKTIO_FS_CHANGE_LOW_LATENCY)
'low-latency)
(and (set? props RKTIO_FS_CHANGE_FILE_LEVEL)
'file-level))]))))

3
racket/src/io/host/pthread.rkt
View File

@ -25,4 +25,5 @@
unsafe-place-local-set!
unsafe-add-global-finalizer
unsafe-strip-impersonator
prop:unsafe-authentic-override)
prop:unsafe-authentic-override
set-fs-change-properties!)

26
racket/src/io/sandman/ltps.rkt Normal file
View File

@ -0,0 +1,26 @@
#lang racket/base
(require "../host/rktio.rkt"
"../host/thread.rkt"
"../host/place-local.rkt")
(provide shared-ltps
shared-ltps-place-init!)
(define (make-ltps)
(define ltps (rktio_ltps_open rktio))
(unless (rktio-error? ltps)
(unsafe-custodian-register (current-custodian)
ltps
;; in atomic mode
(lambda (ltps)
(rktio_ltps_close rktio ltps))
#f
#f))
(if (rktio-error? ltps)
rktio_NULL
ltps))
(define-place-local shared-ltps (make-ltps))
(define (shared-ltps-place-init!)
(make-ltps))

10
racket/src/io/sandman/main.rkt
View File

@ -4,7 +4,8 @@
"../common/internal-error.rkt"
"../host/thread.rkt"
"../host/rktio.rkt"
"lock.rkt")
"lock.rkt"
"ltps.rkt")
;; Create an extended sandman that can sleep with a rktio poll set. An
;; external-event set might be naturally implemented with a poll set,
@ -58,7 +59,8 @@
(define-place-local awoken-threads '())
(define (sandman-place-init!)
(set! lock (make-lock)))
(set! lock (make-lock))
(shared-ltps-place-init!))
(void
(current-sandman
@ -82,14 +84,14 @@
(unless (and sleep-secs (sleep-secs . <= . 0.0))
(cond
[background-sleep
(rktio_start_sleep rktio (or sleep-secs 0.0) ps rktio_NULL background-sleep-fd)
(rktio_start_sleep rktio (or sleep-secs 0.0) ps shared-ltps background-sleep-fd)
(background-sleep)
(rktio_end_sleep rktio)]
[else
(rktio_sleep rktio
(or sleep-secs 0.0)
ps
rktio_NULL)]))
shared-ltps)]))
(rktio_poll_set_forget rktio ps))
;; poll

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "7.3.0.2"
#define MZSCHEME_VERSION "7.3.0.3"
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

52
racket/src/racket/src/startup.inc
View File

@ -4814,7 +4814,7 @@ static const char *startup_source =
" 12"
" 0"
" #f"
" null"
"(list(cons prop:authentic #t))"
"(current-inspector)"
" #f"
" '(0 1 2 3 4 5 6 7 8 9 10 11)"
@ -5938,7 +5938,18 @@ static const char *startup_source =
"(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)"
"(let-values()"
"(let-values()"
"(make-struct-type 'syntax-state #f 3 0 #f null(current-inspector) #f '(1 2) #f 'syntax-state)))))"
"(make-struct-type"
" 'syntax-state"
" #f"
" 3"
" 0"
" #f"
"(list(cons prop:authentic #t))"
"(current-inspector)"
" #f"
" '(1 2)"
" #f"
" 'syntax-state)))))"
"(values"
" struct:_0"
" make-_0"
@ -11329,6 +11340,7 @@ static const char *startup_source =
" 0"
" #f"
"(list"
"(cons prop:authentic #t)"
"(cons"
" prop:serialize"
"(lambda(b_0 ser-push!_0 reachable-scopes_0)"
@ -19821,6 +19833,7 @@ static const char *startup_source =
" #%call-with-values"
" make-pthread-parameter"
" break-enabled-key"
" engine-block"
" fasl->s-exp/intern))))"
"(define-values(phase-shift-id)(make-built-in-symbol! 'phase))"
"(define-values(dest-phase-id)(make-built-in-symbol! 'dest-phase))"
@ -23298,7 +23311,7 @@ static const char *startup_source =
"(1/make-instance"
" 'deserialize"
" #f"
" 'constant"
" 'consistent"
" 'deserialize-module-path-indexes"
" deserialize-module-path-indexes"
" 'syntax-module-path-index-shift"
@ -65328,29 +65341,14 @@ static const char *startup_source =
"(let-values(((or-part_0)(path-cache-get(cons s_1(get-reg_0)))))"
"(if or-part_0"
" or-part_0"
"(begin"
"(if log-performance?"
"(let-values()(start-performance-region 'eval 'resolve-symbol))"
"(void))"
"(begin0"
"(let-values()"
"(let-values(((cols_0 file_0)"
"(split-relative-string(symbol->string s_1) #f)))"
"(let-values(((f-file_0)"
"(if(null? cols_0)"
" \"main.rkt\""
" (string-append file_0 \".rkt\"))))"
"(let-values(((col_0)"
"(if(null? cols_0) file_0(car cols_0))))"
"(let-values(((col-path_0)"
"(if(null? cols_0) null(cdr cols_0))))"
"(begin"
"(if log-performance?"
"(let-values()"
"(start-performance-region 'eval 'resolve-find))"
"(void))"
"(begin0"
"(let-values()"
" \"main.rkt\""
" (string-append file_0 \".rkt\"))))"
"(let-values(((col_0)(if(null? cols_0) file_0(car cols_0))))"
"(let-values(((col-path_0)(if(null? cols_0) null(cdr cols_0))))"
"(find-col-file"
"(if(not subm-path_0)"
" show-collection-err_0"
@ -65362,13 +65360,7 @@ static const char *startup_source =
" col_0"
" col-path_0"
" f-file_0"
" #t))"
"(if log-performance?"
"(let-values()(end-performance-region))"
"(void)))))))))"
"(if log-performance?"
"(let-values()(end-performance-region))"
"(void)))))))"
" #t))))))))"
"(if(string? s_1)"
"(let-values()"
"(let-values(((dir_0)(get-dir_0)))"
@ -65443,7 +65435,7 @@ static const char *startup_source =
"(path->complete-path(expand-user-path(cadr s_1))(get-dir_0)))))"
"(void))))))))"
"(if(symbol? s-parsed_0)"
"(let-values()(1/make-resolved-module-path(cons s-parsed_0 subm-path_0)))"
"(let-values()(1/make-resolved-module-path s-parsed_0))"
"(if(not"
"(let-values(((or-part_0)(path? s-parsed_0)))"
"(if or-part_0 or-part_0(vector? s-parsed_0))))"

6
racket/src/thread/place-local.rkt
View File

@ -7,6 +7,12 @@
;; Just like the one from `racket/private/place-local`, but using the
;; exports of "host.rkt" so we can test in bootstrapping mode.
;; When compiled as part of Racket CS, a variable defined with
;; `define-place-local` turns into a reserved slot in a place array,
;; where the place array is in a virtual register. So, access and
;; update of the variable is relatively fast. Any non-#f initial value
;; must be explicitly installed for a new place, however.
(define-syntax-rule (define-place-local id v)
(begin
(define cell (unsafe-make-place-local v))

10
racket/src/thread/place-object.rkt
View File

@ -26,10 +26,7 @@
[pending-break #:mutable] ; #f, 'break, 'hangup, or 'terminate
done-waiting ; hash table of places to ping when this one ends
[wakeup-handle #:mutable]
[dequeue-semas #:mutable] ; semaphores reflecting place-channel waits to recheck
[recent-process-milliseconds #:mutable] ; used by scheduler
[skipped-time-accums #:mutable] ; used by scheduler
[thread-swap-count #:mutable]) ; number of thread swaps
[dequeue-semas #:mutable]); semaphores reflecting place-channel waits to recheck
#:property prop:evt (struct-field-index pch)
#:property prop:place-message (lambda (self) (lambda () (lambda () (place-pch self)))))
@ -52,10 +49,7 @@
#f ; pending-break
(make-hasheq) ; done-waiting
#f ; wakeup-handle
'() ; dequeue-semas
0 ; recent-process-milliseconds
0 ; skipped-time-accums
0)) ; thread-swap-count
'())) ; dequeue-semas
(define initial-place (make-place (host:make-mutex)
root-custodian))

30
racket/src/thread/schedule.rkt
View File

@ -41,10 +41,19 @@
(set-root-custodian! c)
(init-system-idle-evt!)
(init-future-place!)
(call-in-main-thread thunk))
(call-in-main-thread thunk)
(init-schedule-counters!))
;; ----------------------------------------
(define-place-local recent-process-milliseconds 0)
(define-place-local skipped-time-accums 0)
(define-place-local thread-swap-count 0)
(define (init-schedule-counters!)
(set! recent-process-milliseconds 0)
(set! skipped-time-accums 0)
(set! thread-swap-count 0))
(define (select-thread! [pending-callbacks null])
(let loop ([g root-thread-group] [pending-callbacks pending-callbacks] [none-k maybe-done])
(define callbacks (if (null? pending-callbacks)
@ -74,9 +83,8 @@
(set-thread-engine! t 'running)
(set-thread-sched-info! t #f)
(current-thread t)
(let ([pl current-place])
(set-place-current-thread! pl t)
(set-place-thread-swap-count! pl (add1 (place-thread-swap-count pl))))
(set-place-current-thread! current-place t)
(set! thread-swap-count (add1 thread-swap-count))
(run-callbacks-in-engine
e callbacks
(lambda (e)
@ -234,24 +242,20 @@
;; that don't keep swapping themselves out.
(define (accum-cpu-time! t timeout?)
(define pl current-place)
(cond
[(not timeout?)
(define n (place-skipped-time-accums pl))
(set-place-skipped-time-accums! pl (add1 n))
(define n skipped-time-accums)
(set! skipped-time-accums (add1 n))
(when (= n 100)
(accum-cpu-time! t #t))]
[else
(define start (place-recent-process-milliseconds pl))
(define start recent-process-milliseconds)
(define now (current-process-milliseconds))
(set-place-recent-process-milliseconds! pl now)
(set-place-skipped-time-accums! pl 0)
(set! recent-process-milliseconds now)
(set! skipped-time-accums 0)
(set-thread-cpu-time! t (+ (thread-cpu-time t)
(- now start)))]))
(define (thread-swap-count)
(place-thread-swap-count current-place))
;; ----------------------------------------
(define-place-local atomic-timeout-callback #f)

2
racket/src/thread/stats.rkt
View File

@ -20,7 +20,7 @@
(maybe-set! 1 (current-milliseconds))
(maybe-set! 2 (current-gc-milliseconds))
(maybe-set! 3 0) ; # of GCs
(maybe-set! 4 (thread-swap-count)) ; # of thread switches
(maybe-set! 4 thread-swap-count) ; # of thread swaps
(maybe-set! 5 0) ; # of stack overflows
(maybe-set! 6 0) ; # of threads scheduled for running
(maybe-set! 7 0) ; # of syntax objects read