From c3059f7e824f412adfea3d622e98bab9c6568ada Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Wed, 29 Jun 2011 12:26:31 -0600 Subject: [PATCH] place-dead-evt --- collects/racket/place.rkt | 5 ++- collects/scribblings/reference/evts.scrbl | 4 ++ collects/tests/racket/place-channel.rkt | 28 +++++++++++++- src/racket/src/place.c | 45 +++++++++++++++++++++++ src/racket/src/schvers.h | 4 +- src/racket/src/stypes.h | 3 +- src/racket/src/type.c | 1 + 7 files changed, 83 insertions(+), 7 deletions(-) diff --git a/collects/racket/place.rkt b/collects/racket/place.rkt index 7f3329cf19..f1e68dc0df 100644 --- a/collects/racket/place.rkt +++ b/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) diff --git a/collects/scribblings/reference/evts.scrbl b/collects/scribblings/reference/evts.scrbl index 877f5cbafb..8f913ac4a7 100644 --- a/collects/scribblings/reference/evts.scrbl +++ b/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].} + ] @;------------------------------------------------------------------------ diff --git a/collects/tests/racket/place-channel.rkt b/collects/tests/racket/place-channel.rkt index b591abd283..7b97673c83 100644 --- a/collects/tests/racket/place-channel.rkt +++ b/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) diff --git a/src/racket/src/place.c b/src/racket/src/place.c index 0b53c4c5dd..612e32e953 100644 --- a/src/racket/src/place.c +++ b/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 =============*/ diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index e7905721b6..497003ffe8 100644 --- a/src/racket/src/schvers.h +++ b/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) diff --git a/src/racket/src/stypes.h b/src/racket/src/stypes.h index 33c6d26471..5d924738a8 100644 --- a/src/racket/src/stypes.h +++ b/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 */ diff --git a/src/racket/src/type.c b/src/racket/src/type.c index fcad6238e9..e11c8893d5 100644 --- a/src/racket/src/type.c +++ b/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 */