From 2d3ee903ec93a73826f6e2150cf765ee82e3979a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Apr 2019 15:01:25 -0600 Subject: [PATCH] cs: implement filesystem change events --- pkgs/base/info.rkt | 2 +- racket/src/cs/c/gen-system.rkt | 4 +- racket/src/cs/rumble.sls | 1 + racket/src/cs/rumble/system.ss | 5 +- racket/src/expander/boot/handler.rkt | 10 +- racket/src/io/demo.rkt | 13 ++ racket/src/io/filesystem-change-evt/main.rkt | 118 +++++++++++++++++-- racket/src/io/host/pthread.rkt | 3 +- racket/src/io/sandman/ltps.rkt | 26 ++++ racket/src/io/sandman/main.rkt | 10 +- racket/src/racket/src/schvers.h | 4 +- racket/src/racket/src/startup.inc | 52 ++++---- racket/src/thread/place-local.rkt | 6 + racket/src/thread/place-object.rkt | 10 +- racket/src/thread/schedule.rkt | 30 +++-- racket/src/thread/stats.rkt | 2 +- 16 files changed, 219 insertions(+), 77 deletions(-) create mode 100644 racket/src/io/sandman/ltps.rkt diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 31c55f5903..a616b62a86 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -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])) diff --git a/racket/src/cs/c/gen-system.rkt b/racket/src/cs/c/gen-system.rkt index 6d5a56494f..41a01b6c72 100644 --- a/racket/src/cs/c/gen-system.rkt +++ b/racket/src/cs/c/gen-system.rkt @@ -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))) diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index 5d94cf83a4..c23a5f589e 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -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 diff --git a/racket/src/cs/rumble/system.ss b/racket/src/cs/rumble/system.ss index dbca41dce6..46a1cc4f80 100644 --- a/racket/src/cs/rumble/system.ss +++ b/racket/src/cs/rumble/system.ss @@ -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 diff --git a/racket/src/expander/boot/handler.rkt b/racket/src/expander/boot/handler.rkt index ee967d8b4a..d43135e018 100644 --- a/racket/src/expander/boot/handler.rkt +++ b/racket/src/expander/boot/handler.rkt @@ -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)) @@ -539,7 +535,9 @@ (cond [(symbol? s-parsed) ;; Return a genenerated symnol - (make-resolved-module-path + (make-resolved-module-path + s-parsed + #; (cons s-parsed subm-path))] [(not (or (path? s-parsed) (vector? s-parsed))) diff --git a/racket/src/io/demo.rkt b/racket/src/io/demo.rkt index 571a3bf3f0..2ad8e2722a 100644 --- a/racket/src/io/demo.rkt +++ b/racket/src/io/demo.rkt @@ -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]) diff --git a/racket/src/io/filesystem-change-evt/main.rkt b/racket/src/io/filesystem-change-evt/main.rkt index b9efbd112a..c77fae7c54 100644 --- a/racket/src/io/filesystem-change-evt/main.rkt +++ b/racket/src/io/filesystem-change-evt/main.rkt @@ -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))])))) diff --git a/racket/src/io/host/pthread.rkt b/racket/src/io/host/pthread.rkt index b3e42d3df2..027141ceb7 100644 --- a/racket/src/io/host/pthread.rkt +++ b/racket/src/io/host/pthread.rkt @@ -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!) diff --git a/racket/src/io/sandman/ltps.rkt b/racket/src/io/sandman/ltps.rkt new file mode 100644 index 0000000000..4c02624d04 --- /dev/null +++ b/racket/src/io/sandman/ltps.rkt @@ -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)) diff --git a/racket/src/io/sandman/main.rkt b/racket/src/io/sandman/main.rkt index 769e58bc8f..c07881ce71 100644 --- a/racket/src/io/sandman/main.rkt +++ b/racket/src/io/sandman/main.rkt @@ -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 diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 14d523c080..6d28d0809a 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -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) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index a2aca26fe0..92b04b2a87 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -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))))" diff --git a/racket/src/thread/place-local.rkt b/racket/src/thread/place-local.rkt index fc9c91745b..395c0cd1e2 100644 --- a/racket/src/thread/place-local.rkt +++ b/racket/src/thread/place-local.rkt @@ -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)) diff --git a/racket/src/thread/place-object.rkt b/racket/src/thread/place-object.rkt index 62e0e17420..0aa61edd30 100644 --- a/racket/src/thread/place-object.rkt +++ b/racket/src/thread/place-object.rkt @@ -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)) diff --git a/racket/src/thread/schedule.rkt b/racket/src/thread/schedule.rkt index 150f3de1e5..1c15bf01b6 100644 --- a/racket/src/thread/schedule.rkt +++ b/racket/src/thread/schedule.rkt @@ -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) diff --git a/racket/src/thread/stats.rkt b/racket/src/thread/stats.rkt index 3fe0341388..7870f1317c 100644 --- a/racket/src/thread/stats.rkt +++ b/racket/src/thread/stats.rkt @@ -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