cs, thread & io: finish implementing places

Implement place channels and messages, and change `place-enabled?` to
claim that places are enabled, but `processor-count` still reports 1.

The implementation of place channels has an interesting use of
ephemerons --- that is, a use that isn't just solving a key-in-value
problem. Using epehemerons solves the problem of forgetting a place
channel and any thread blocked on the read end when there are no
producers on the write end. Along similar lines, when only the write
end is retained (i.e., no readers), the channel data is forgotten and
writes become a no-op. The read end holds a "read key" and references
the channel data through an ephemeron keyed by a "write key"; the
write end similarly holds a "write key" and uses an ephemeron keyed by
the "read key". This use of an epehemeron implements a reachability
"and": retain the place-channel data only if the read end *and* the
write end are both reachable. (Minor point: a read end also holds onto
the "write key" anytime the channel already has data.)

racket/collects/racket/prefab.rkt

@@ -0,0 +1,36 @@
+#lang racket/base
+
+(provide immutable-prefab-struct-key
+         prefab-key-all-fields-immutable?)
+
+(define (immutable-prefab-struct-key v)
+  (define k (prefab-struct-key v))
+  (and k
+       (all-fields-immutable? k)
+       k))
+
+(define (prefab-key-all-fields-immutable? k)
+  (unless (prefab-key? k)
+    (raise-argument-error 'prefab-key-all-fields-immutable? "prefab-key?" k))
+  (all-fields-immutable? k))
+
+(define (all-fields-immutable? k)
+  (or (symbol? k)
+      (null? k)
+      (let* ([rk (cdr k)] ; skip name
+             [rk (if (and (pair? rk)
+                          (exact-integer? (car rk)))
+                     (cdr rk) ; skip init count
+                     rk)]
+             [rk (if (and (pair? rk)
+                          (pair? (car rk)))
+                     (if (zero? (caar rk))
+                         (cdr rk) ; skip zero auto count
+                         (cons '#(1) (cdr rk))) ; reflect mutable auto field
+                     rk)])
+        (if (and (pair? rk)
+                 (vector? (car rk)))
+            (if (zero? (vector-length (car rk)))
+                (all-fields-immutable? (cdr rk))
+                #f)
+            (all-fields-immutable? rk)))))

racket/src/cs/Makefile

@@ -66,7 +66,7 @@ setup:
 	$(MAKE) run ARGS="-l- setup $(ARGS)"
 
 setup-v:
-	$(MAKE) run ARGS="-W 'info@compiler/cm info@linklet debug@GC:major error' -l- setup $(ARGS)"
+	$(MAKE) run ARGS="-W 'info@compiler/cm info@linklet debug@GC:major error' -l- setup -j 1 $(ARGS)"
 
 run-wpo: $(BUILDDIR)racket.so ../../bin/racket
 	$(SCHEME) --script $(BUILDDIR)racket.so $(RACKET_SETUP_ARGS) $(ARGS)

racket/src/cs/demo/io.ss

@@ -130,4 +130,63 @@
          (test '#(info "cats: hello" 7 cats) msg1)
 
          (log-message demo1-logger 'info 'cats "goodbye" 9)
-         (test '#(info "cats: goodbye" 9 cats) (sync lr1)))))))
+         (test '#(info "cats: goodbye" 9 cats) (sync lr1)))))
+
+
+   ;; ----------------------------------------
+
+   (let* ([place-symbols (make-hasheq)]
+          [register-place-symbol!
+           (lambda (sym proc)
+             (hash-set! place-symbols sym proc))])
+     (set-make-place-ports+fds! make-place-ports+fds)
+     (set-start-place!
+      (lambda (pch mod sym in out err cust plumber)
+        (io-place-init! in out err cust plumber)
+        (lambda (finish)
+          (finish)
+          ((hash-ref place-symbols sym) pch))))
+
+     ;; Check file port passed across places
+     (let ([f (open-input-file "compiled/io.scm")])
+       (file-stream-buffer-mode f 'none)
+       (let ([content (read-bytes 5 f)])
+         (file-position f 0)
+
+         (register-place-symbol! 'read-byte
+                                 (lambda (pch)
+                                   (let ([f (place-channel-get pch)])
+                                     (file-stream-buffer-mode f 'none)
+                                     (let ([b (read-byte f)])
+                                       (close-input-port f)
+                                       (place-channel-put pch b)))))
+         (let-values ([(pl in out err) (dynamic-place 'dummy 'read-byte #f #f #f)])
+           (test (bytes-ref content 0) (read-byte f))
+           (place-channel-put pl f)
+           (test (bytes-ref content 1) (place-channel-get pl))
+           (test (bytes-ref content 2) (read-byte f))
+           (close-input-port f)))))
+
+   ;; Thread can be GCed if it's block on a place channel with no writer
+   (let ()
+     (define-values (left1 right1) (place-channel))
+     (define saved #f)
+     (define not-saved (gensym))
+     (define weak-saved (make-weak-box not-saved))
+     (define weak-right1 (make-weak-box right1))
+     (place-channel-put right1 not-saved)
+     ;; DON'T USE `right1` from here on...
+     (let ()
+       (define weak-thread
+         (make-weak-box
+          (thread (lambda ()
+                    (define local-saved (place-channel-get left1))
+                    (place-channel-get left1) ; no writer for this channel
+                    (set! saved local-saved)))))
+       (sync (system-idle-evt))
+       (collect-garbage)
+       (test #f (weak-box-value weak-right1))
+       (test #f (weak-box-value weak-thread))
+       (test #f (weak-box-value weak-saved))))
+
+   (void)))

racket/src/cs/demo/thread.ss

@@ -191,22 +191,22 @@
            (lambda (sym proc)
              (hash-set! place-symbols sym proc))])
      (set-start-place!
-      (lambda (mod sym in out err cust plumber)
+      (lambda (pch mod sym in out err cust plumber)
         (lambda (finish)
           (finish)
-          ((hash-ref place-symbols sym)))))
+          ((hash-ref place-symbols sym) pch))))
 
      (register-place-symbol! 'nothing void)
      (let-values ([(pl1 in1 out1 err1) (dynamic-place 'dummy 'nothing #f #f #f)])
        (check #t (place? pl1))
        (check 0 (place-wait pl1)))
 
-     (register-place-symbol! 'exit1 (lambda () (exit 1)))
+     (register-place-symbol! 'exit1 (lambda (pch) (exit 1)))
      (let-values ([(pl2 in2 out2 err2) (dynamic-place 'dummy 'exit1 #f #f #f)])
        (check #t (place? pl2))
        (check 1 (place-wait pl2)))
 
-     (register-place-symbol! 'loop (lambda () (let loop () (loop))))
+     (register-place-symbol! 'loop (lambda (pch) (let loop () (loop))))
      (let-values ([(pl3 in3 out3 err3) (dynamic-place 'dummy 'loop #f #f #f)])
        (check #t (place? pl3))
        (place-break pl3)

racket/src/cs/io.sls

@@ -295,8 +295,8 @@
 
     (define (rktio_pipe_results r)
       (values
-       (foreign-ref 'ptr (ptr->address r) 0)
-       (foreign-ref 'ptr (ptr->address r) 1)))
+       (address->ptr (foreign-ref 'uptr (ptr->address r) 0))
+       (address->ptr (foreign-ref 'uptr (ptr->address r) (foreign-sizeof 'uptr)))))
 
     (define (rktio_do_install_os_signal_handler rktio)
       (rktio_install_os_signal_handler rktio))

racket/src/cs/main.sps

@@ -485,13 +485,15 @@
    (set-make-place-ports+fds! make-place-ports+fds)
 
    (set-start-place!
-    (lambda (mod sym in out err cust plumber)
+    (lambda (pch mod sym in out err cust plumber)
       (io-place-init! in out err cust plumber)
       (regexp-place-init!)
       (expander-place-init!)
       (initialize-place!)
-      (lambda ()
-        (dynamic-require mod sym))))
+      (lambda (finish)
+        (finish)
+        (let ([f (dynamic-require mod sym)])
+          (f pch)))))
 
    (when (getenv "PLT_STATS_ON_BREAK")
      (keyboard-interrupt-handler

racket/src/cs/rumble/foreign.ss

@@ -1226,7 +1226,7 @@
     (let* ([bstr (make-bytevector size)]
            [p (make-cpointer bstr #f)])
       (lock-object bstr)
-      (the-foreign-guardian p (lambda () (unlock-object bstr)))
+      (with-global-lock (the-foreign-guardian p (lambda () (unlock-object bstr))))
       p)]
    [else
     (raise-unsupported-error 'malloc

racket/src/cs/rumble/place.ss

@@ -58,7 +58,7 @@
 
 (meta-cond
  [(threaded?)
-  (define (place-enabled?) #f) ;; FIXME
+  (define (place-enabled?) #t)
   (define (fork-place thunk finish-proc)
     (fork-thread (lambda ()
                    (init-virtual-registers)
@@ -79,8 +79,8 @@
 (define (set-start-place! proc)
   (set! do-start-place proc))
 
-(define (start-place path sym in out err cust plumber)
-  (do-start-place path sym in out err cust plumber))
+(define (start-place pch path sym in out err cust plumber)
+  (do-start-place pch path sym in out err cust plumber))
 
 (define (place-exit v)
   (let ([esc (unbox place-esc-box)])

racket/src/expander/common/prefab.rkt

@@ -1,31 +1,8 @@
 #lang racket/base
+(require racket/prefab)
 
 (provide immutable-prefab-struct-key
          all-fields-immutable?)
 
-(define (immutable-prefab-struct-key v)
-  (define k (prefab-struct-key v))
-  (and k
-       (all-fields-immutable? k)
-       k))
-
 (define (all-fields-immutable? k)
-  (or (symbol? k)
-      (null? k)
-      (let* ([rk (cdr k)] ; skip name
-             [rk (if (and (pair? rk)
-                          (exact-integer? (car rk)))
-                     (cdr rk) ; skip init count
-                     rk)]
-             [rk (if (and (pair? rk)
-                          (pair? (car rk)))
-                     (if (zero? (caar rk))
-                         (cdr rk) ; skip zero auto count
-                         (cons '#(1) (cdr rk))) ; reflect mutable auto field
-                     rk)])
-        (if (and (pair? rk)
-                 (vector? (car rk)))
-            (if (zero? (vector-length (car rk)))
-                (all-fields-immutable? (cdr rk))
-                #f)
-            (all-fields-immutable? rk)))))
+  (prefab-key-all-fields-immutable? k))

racket/src/io/demo-thread.rkt

@@ -23,7 +23,7 @@
 
 (call-in-main-thread
  (lambda ()
-
+   
    ;; Make `N` threads trying to write `P` copies
    ;; of each possible byte into a limited pipe, and
    ;; make `N` other threads try to read those bytes.
@@ -185,8 +185,11 @@
      (custodian-shutdown-all c))
 
    ;; Places
+   ;;  BEWARE: we can run some basic places tests in bootstrap mode,
+   ;;  but since "places" are just Racket threads, avoid any rktio-based
+   ;;  blocking operations
    (register-place-symbol! 'report
-                           (lambda ()
+                           (lambda (pch)
                              (write-string "expected place out\n")
                              (write-string "expected place err\n" (current-error-port))))
    (define-values (pl1 pin1 pout1 perr1) (dynamic-place 'dummy 'report
@@ -198,9 +201,10 @@
    (test #f pout1)
    (test #f perr1)
    (test 0 (place-wait pl1))
-
+
+   ;; See warnign about about places in bootstrap-demo mode
    (register-place-symbol! 'echo2
-                           (lambda ()
+                           (lambda (pch)
                              (define s (read-line))
                              (write-string s)
                              (define s2 (list->string (reverse (string->list s))))
@@ -216,6 +220,31 @@
    (test "olleh" (read-string 100 perr2))
    (test 0 (place-wait pl2))
 
+   ;; Can pass a file-stream port through a place channel, but it
+   ;; makes a fresh port on the other end
+   (define-values (left1 right1) (place-channel))
+   (let ([f (open-input-file "compiled/hello.txt")])
+     (file-stream-buffer-mode f 'none)
+     (test #\h (read-char f))
+     (test 1 (file-position f))
+     (place-channel-put left1 f)
+     (define f2 (place-channel-get right1))
+     (file-stream-buffer-mode f2 'none)
+     (test #\e (read-char f2))
+     (test 2 (file-position f2))
+     (close-input-port f2)
+     (test 2 (file-position f))
+     (test #\l (read-char f))
+     (test 3 (file-position f))
+     (close-input-port f))
+   ;; Paths are ok as place messages:
+   (let ([p (bytes->path #"ok" 'windows)])
+     (place-channel-put left1 p)
+     (test p (place-channel-get right1)))
+   (let ([p (bytes->path #"ok" 'unix)])
+     (place-channel-put left1 p)
+     (test p (place-channel-get right1)))
+
    ;; TCP and accept evts
    (parameterize ([current-custodian (make-custodian)])
      (define l (tcp-listen 59078 5 #t))

racket/src/io/host/bootstrap.rkt

@@ -71,6 +71,9 @@
       (eq? always-evt evt)
       (eq? never-evt evt)))
 
+(define-values (prop:place-message place-message? place-message-ref)
+  (make-struct-type-property 'place-message))
+
 (primitive-table '#%pthread
                  (hasheq 'unsafe-make-place-local box
                          'unsafe-place-local-ref unbox
@@ -128,4 +131,5 @@
                          'unsafe-custodian-unregister unsafe-custodian-unregister
                          'thread-push-kill-callback! thread-push-kill-callback!
                          'thread-pop-kill-callback! thread-pop-kill-callback!
-                         'set-get-subprocesses-time! void))
+                         'set-get-subprocesses-time! void
+                         'prop:place-message prop:place-message))

racket/src/io/host/thread.rkt

@@ -54,7 +54,8 @@
         custodian-shut-down?
         current-plumber
         plumber-add-flush!
-        plumber-flush-handle-remove!)
+        plumber-flush-handle-remove!
+        prop:place-message)
 
 (bounce* choice-evt ; raw variant that takes a list of evts
          prop:secondary-evt

racket/src/io/path/path.rkt

@@ -1,7 +1,8 @@
 #lang racket/base
 (require "../print/custom-write.rkt"
          "../port/string-output.rkt"
-         "../locale/string.rkt")
+         "../locale/string.rkt"
+         (only-in "../host/thread.rkt" prop:place-message))
 
 (provide (struct-out path)
          is-path?
@@ -32,7 +33,10 @@
    (lambda (p hc)
      (hc (path-bytes p)))
    (lambda (p hc)
-     (hc (path-bytes p)))))
+     (hc (path-bytes p))))
+  #:property prop:place-message (lambda (self)
+                                  (lambda ()
+                                    (lambda () self))))
 
 (define is-path?
   (let ([path? (lambda (p)