place-dead-evt

collects/racket/place.rkt

@@ -25,7 +25,8 @@
          place-channel-put/get
          processor-count
          place
-         (rename-out [pl-place-enabled? place-enabled?]))
+         (rename-out [pl-place-enabled? place-enabled?])
+         place-dead-evt)
 
 (define-struct TH-place (th ch cust) 
   #:property prop:evt (lambda (x) (TH-place-channel-in (TH-place-ch x))))
@@ -66,6 +67,7 @@
 (define (th-place-wait pl) (thread-wait (TH-place-th pl)) 0)
 (define (th-place-kill pl) (custodian-shutdown-all (TH-place-cust pl)))
 (define (th-place-break pl) (break-thread (TH-place-th pl)))
+(define (th-place-dead-evt pl) (thread-dead-evt (TH-place-th pl)))
 (define (th-place-channel)
   (define-values (as ar) (make-th-async-channel))
   (define-values (bs br) (make-th-async-channel))
@@ -134,6 +136,7 @@
 (define-pl place-channel?     pl-place-channel?     th-place-channel?)
 (define-pl place?             pl-place?             TH-place?)
 (define-pl place-message-allowed? pl-place-message-allowed? th-place-message-allowed?)
+(define-pl place-dead-evt     pl-place-dead-evt     th-place-dead-evt)
 
 (define-syntax-rule (define-syntax-case (N a ...) b ...)
   (define-syntax (N stx)

collects/scribblings/reference/evts.scrbl

@@ -191,6 +191,10 @@ generate events (see @racket[prop:evt]).
  would not block. The result as an event is the same as the
  @racket[place-channel-get] result.}
 
+ @item{@racket[_place-dead] --- an event returned by
+ @racket[place-dead-evt] applied to @racket[p] is ready when
+ @racket[p] has terminated.  @ResultItself[_place-dead].}
+
  ]
 
 @;------------------------------------------------------------------------

collects/tests/racket/place-channel.rkt

@@ -174,6 +174,7 @@
   (define b1 (shared-bytes 66 66 66 66))
   (define b2 (make-shared-bytes 4 65))
 
+  ; test place-channel communication of basic types
   (channel-test-basic-types-master place-channel-put/get pl)
   (channel-test-basic-types-master big-sender pl)
 
@@ -209,6 +210,7 @@
   (channel-test-basic-types-master place-channel-put/get pc6)
   (channel-test-basic-types-master big-sender pc6)
 
+  ; test deep copy of cycles
   (let ([try-graph
          (lambda (s)
            (let ([v (read (open-input-string s))])
@@ -225,6 +227,7 @@
 
   (place-wait pl))
 
+  ; test place-break
   (let ([p (place ch
              (with-handlers ([exn:break? (lambda (x) (place-channel-put ch "OK"))])
               (place-channel-put ch "ALIVE")
@@ -236,11 +239,32 @@
   (test "OK" place-channel-get p)
   (place-wait p))
 
+  ; test place-dead-evt
+  (define wbs '())
+  (for ([i (in-range 0 50)])
+    (define p (place ch (void (place-channel-get ch))))
+    (set! wbs
+          (cons
+           (make-weak-box
+            (thread
+             (λ ()
+               (define-values (in out) (place-channel))
+               (place-channel-put p in)
+               (sync 
+                 (handle-evt (place-dead-evt p)
+                   (lambda (x) (printf "Place ~a died\n" i) ))
+                 out))))
+           wbs))
+    (collect-garbage)
+    (set! wbs (filter weak-box-value wbs))
+    (printf "len ~a\n" (length wbs)))
+
+  ; test deep stack handling in places_deep_copy c routine
   (test-long (lambda (x) 3) "Listof ints")
   (test-long (lambda (x) #(1 2)) "Listof vectors")
   (test-long (lambda (x) (intern-num-sym (modulo x 1000))) "Listof symbols")
   (test-long (lambda (x) #s(clown "Binky" "pie")) "Listof prefabs")
-  (test-long (lambda (x) (read (open-input-string "#0=(#0# . #0#)"))) "Listof cycles"))
-
+  (test-long (lambda (x) (read (open-input-string "#0=(#0# . #0#)"))) "Listof cycles")
+  )
 
 ;(report-errs)

src/racket/src/place.c

@@ -43,6 +43,8 @@ static int place_channel_ready(Scheme_Object *so, Scheme_Schedule_Info *sinfo);
 static void place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *o);
 static Scheme_Object *place_async_receive(Scheme_Place_Async_Channel *ch);
 static Scheme_Object *places_deep_copy_to_master(Scheme_Object *so);
+static Scheme_Object *make_place_dead(int argc, Scheme_Object *argv[]);
+static int place_dead_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
 
 #if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
 static Scheme_Object *places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table **ht, 
@@ -102,6 +104,7 @@ void scheme_init_place(Scheme_Env *env)
   PLACE_PRIM_W_ARITY("place-channel-get",     place_receive,   1, 1, plenv);
   PLACE_PRIM_W_ARITY("place-channel?",        place_channel_p, 1, 1, plenv);
   PLACE_PRIM_W_ARITY("place-message-allowed?", place_allowed_p, 1, 1, plenv);
+  PLACE_PRIM_W_ARITY("place-dead-evt",        make_place_dead, 1, 1, plenv);
 
 #ifdef MZ_USE_PLACES
   REGISTER_SO(scheme_def_place_exit_proc);
@@ -123,6 +126,7 @@ void scheme_init_places_once() {
 #ifdef MZ_USE_PLACES
   scheme_add_evt(scheme_place_type,            (Scheme_Ready_Fun)place_channel_ready, NULL, NULL, 1); 
   scheme_add_evt(scheme_place_bi_channel_type, (Scheme_Ready_Fun)place_channel_ready, NULL, NULL, 1);
+  scheme_add_evt(scheme_place_dead_type,       (Scheme_Ready_Fun)place_dead_ready, NULL, NULL, 1);
   mzrt_mutex_create(&id_counter_mutex);
 #endif
 }
@@ -332,6 +336,47 @@ static Scheme_Object *place_break(int argc, Scheme_Object *args[]) {
   return scheme_make_integer(do_place_break(place));
 }
 
+static int place_deadp(Scheme_Object *place) {
+  Scheme_Place_Object *place_obj;
+  int ref = 0;
+  place_obj = (Scheme_Place_Object*) ((Scheme_Place *)place)->place_obj;
+
+  if (place_obj == NULL) {
+    return 1;
+  }
+  else
+  {
+    mzrt_mutex_lock(place_obj->lock);
+
+    ref = place_obj->ref;
+
+    mzrt_mutex_unlock(place_obj->lock);
+  }
+  if (ref > 1) { return 0; }
+  return 1;
+}
+
+static Scheme_Object *make_place_dead(int argc, Scheme_Object *argv[])
+{ 
+  Scheme_Object *b;
+
+  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_place_type))
+    scheme_wrong_type("thread-dead-evt", "place", 0, argc, argv);
+
+  b = scheme_alloc_small_object();
+  b->type = scheme_place_dead_type;
+  SCHEME_PTR_VAL(b) = argv[0];
+  return b;
+} 
+  
+static int place_dead_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo) {
+  if (place_deadp(SCHEME_PTR_VAL(o))) {
+    scheme_set_sync_target(sinfo, o, NULL, NULL, 0, 0, NULL);
+    return 1;
+  }
+  return 0;
+}
+/
 
 # if defined(MZ_PLACES_WAITPID)
 /*============= SIGCHLD SIGNAL HANDLING =============*/

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.1.1.7"
+#define MZSCHEME_VERSION "5.1.1.8"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 1
 #define MZSCHEME_VERSION_Z 1
-#define MZSCHEME_VERSION_W 7
+#define MZSCHEME_VERSION_W 8
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/racket/src/stypes.h

@@ -160,7 +160,7 @@ enum {
   scheme_always_evt_type,               /* 140 */
   scheme_never_evt_type,                /* 141 */
   scheme_progress_evt_type,             /* 142 */
-  scheme_UNUSED_type,                   /* 143 */
+  scheme_place_dead_type,               /* 143 */
   scheme_already_comp_type,             /* 144 */
   scheme_readtable_type,                /* 145 */
   scheme_intdef_context_type,           /* 146 */
@@ -191,7 +191,6 @@ enum {
   scheme_once_used_type,                /* 171 */
   scheme_serialized_symbol_type,        /* 172 */
   scheme_serialized_structure_type,     /* 173 */
-  /* use scheme_UNUSED_type above, first */
 
 #ifdef MZTAG_REQUIRED
   _scheme_last_normal_type_,            /* 174 */

src/racket/src/type.c

@@ -588,6 +588,7 @@ void scheme_register_traversers(void)
   GC_REG_TRAV(scheme_symbol_type, symbol_obj);
 #ifdef MZ_USE_PLACES  
   GC_REG_TRAV(scheme_serialized_symbol_type, bstring_obj);
+  GC_REG_TRAV(scheme_place_dead_type, small_object);
 #endif
   GC_REG_TRAV(scheme_keyword_type, symbol_obj);
   GC_REG_TRAV(scheme_null_type, char_obj); /* small */