cs: implement filesystem change events

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]))

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)))

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

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

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))
@@ -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)))

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])

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
+(define (filesystem-change-evt? v)
-  (case-lambda
+  (fs-change-evt? v))
-   [(p) (error 'filesystem-change-evt "unsupported")]
-   [(p fail) (fail)]))
 
-(define/who (filesystem-change-evt-cancel e)
+(define/who (filesystem-change-evt p [fail (lambda ()
-  (check who filesystem-change-evt? e)
+                                             (raise (exn:fail:unsupported
-  (void))
+                                                     "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))]))))

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!)

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))

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

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)

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\""
+"                                                                  \"main.rkt\""
-"                                                                        (string-append file_0 \".rkt\"))))"
+"                                                                  (string-append file_0 \".rkt\"))))"
-"(let-values(((col_0)"
+"(let-values(((col_0)(if(null? cols_0) file_0(car cols_0))))"
-"(if(null? cols_0) file_0(car cols_0))))"
+"(let-values(((col-path_0)(if(null? cols_0) null(cdr 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()"
 "(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))"
+" #t))))))))"
-"(if log-performance?"
-"(let-values()(end-performance-region))"
-"(void)))))))))"
-"(if log-performance?"
-"(let-values()(end-performance-region))"
-"(void)))))))"
 "(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))))"

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))

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
+               [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
   #: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
+         '()))                ; dequeue-semas
-         0                    ; recent-process-milliseconds
-         0                    ; skipped-time-accums
-         0))                  ; thread-swap-count
 
 (define initial-place (make-place (host:make-mutex)
                                   root-custodian))

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! current-place t)
-    (set-place-current-thread! pl t)
+  (set! thread-swap-count (add1 thread-swap-count))
-    (set-place-thread-swap-count! pl (add1 (place-thread-swap-count pl))))
   (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))
+     (define n skipped-time-accums)
-     (set-place-skipped-time-accums! pl (add1 n))
+     (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! recent-process-milliseconds now)
-     (set-place-skipped-time-accums! pl 0)
+     (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)

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