Back to index

plt-scheme  4.2.1
places.c
Go to the documentation of this file.
00001 
00002 #include "schpriv.h"
00003 
00004 /* READ ONLY SHARABLE GLOBALS */
00005 static Scheme_Object *place_main_symbol;
00006 
00007 #ifdef MZ_USE_PLACES
00008 
00009 #include "mzrt.h"
00010 
00011 
00012 mz_proc_thread *scheme_master_proc_thread;
00013 THREAD_LOCAL mz_proc_thread *proc_thread_self;
00014 
00015 Scheme_Object *scheme_place(int argc, Scheme_Object *args[]);
00016 static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]);
00017 static Scheme_Object *scheme_place_sleep(int argc, Scheme_Object *args[]);
00018 static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[]);
00019 static void load_namespace(char *namespace_name);
00020 static void load_namespace_utf8(Scheme_Object *namespace_name);
00021 static Scheme_Object *scheme_places_deep_copy_in_master(Scheme_Object *so);
00022 
00023 # ifdef MZ_PRECISE_GC
00024 static void register_traversers(void);
00025 # endif
00026 
00027 static void *place_start_proc(void *arg);
00028 
00029 # define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env)
00030 
00031 #else
00032 
00033 # define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, not_implemented, a1, a2, env)
00034 
00035 static Scheme_Object *not_implemented(int argc, Scheme_Object **argv)
00036 {
00037   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "not supported");
00038   return NULL;
00039 }
00040 
00041 # ifdef MZ_PRECISE_GC
00042 static void register_traversers(void) { }
00043 # endif
00044 
00045 #endif
00046 
00047 /*========================================================================*/
00048 /*                             initialization                             */
00049 /*========================================================================*/
00050 void scheme_init_place(Scheme_Env *env)
00051 {
00052   Scheme_Env *plenv;
00053 
00054 #ifdef MZ_PRECISE_GC
00055   register_traversers();
00056 #endif
00057   
00058   place_main_symbol = scheme_intern_symbol("place-main");
00059   plenv = scheme_primitive_module(scheme_intern_symbol("#%place"), env);
00060 
00061   PLACE_PRIM_W_ARITY("place",       scheme_place,       1, 2, plenv);
00062   PLACE_PRIM_W_ARITY("place-sleep", scheme_place_sleep, 1, 1, plenv);
00063   PLACE_PRIM_W_ARITY("place-wait",  scheme_place_wait,  1, 1, plenv);
00064   PLACE_PRIM_W_ARITY("place?",      scheme_place_p,     1, 1, plenv);
00065 
00066   scheme_finish_primitive_module(plenv);
00067 }
00068 
00069 #ifdef MZ_USE_PLACES
00070 
00071 /************************************************************************/
00072 /************************************************************************/
00073 /************************************************************************/
00074 
00075 /* FIXME this struct probably will need to be garbage collected as stuff
00076  * is added to it */
00077 typedef struct Place_Start_Data {
00078   int argc;
00079   Scheme_Object *thunk;
00080   Scheme_Object *module;
00081   Scheme_Object *channel;
00082   Scheme_Object *current_library_collection_paths;
00083 } Place_Start_Data;
00084 
00085 static void null_out_runtime_globals() {
00086   scheme_current_thread           = NULL;
00087   scheme_first_thread             = NULL;
00088   scheme_main_thread              = NULL;
00089                                                                    
00090   scheme_current_runstack_start   = NULL;
00091   scheme_current_runstack         = NULL;
00092   scheme_current_cont_mark_stack  = 0;
00093   scheme_current_cont_mark_pos    = 0;
00094 }
00095 
00096 Scheme_Object *scheme_place_sleep(int argc, Scheme_Object *args[]) {
00097   mzrt_sleep(SCHEME_INT_VAL(args[0]));
00098   return scheme_void;
00099 }
00100 
00101 Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
00102   Scheme_Place          *place;
00103   Place_Start_Data      *place_data;
00104   mz_proc_thread        *proc_thread;
00105   Scheme_Object         *collection_paths;
00106 
00107   /* create place object */
00108   place = MALLOC_ONE_TAGGED(Scheme_Place);
00109   place->so.type = scheme_place_type;
00110 
00111   /* pass critical info to new place */
00112   place_data = MALLOC_ONE(Place_Start_Data);
00113   place_data->argc = argc;
00114   if (argc == 1) {
00115     place_data->thunk    = args[0];
00116   }
00117   else if (argc == 2 ) {
00118     place_data->module   = args[0];
00119     place_data->channel  = args[1];
00120   }
00121   else {
00122     scheme_wrong_count_m("place", 1, 2, argc, args, 0);
00123   }
00124   collection_paths = scheme_current_library_collection_paths(0, NULL);
00125   collection_paths = scheme_places_deep_copy_in_master(collection_paths);
00126   place_data->current_library_collection_paths = collection_paths;
00127 
00128   /* create new place */
00129   proc_thread = mz_proc_thread_create(place_start_proc, place_data);
00130   place->proc_thread = proc_thread;
00131 
00132   return (Scheme_Object*) place;
00133 }
00134 
00135 static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]) {
00136   void                  *rc;
00137   Scheme_Place          *place;
00138   place = (Scheme_Place *) args[0];
00139 
00140   rc = mz_proc_thread_wait((mz_proc_thread *)place->proc_thread);
00141   
00142   return scheme_void;
00143 }
00144 
00145 static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[])
00146 {
00147   return SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type) ? scheme_true : scheme_false;
00148 }
00149 
00150 static void load_namespace(char *namespace_name) {
00151   load_namespace_utf8( scheme_make_utf8_string(namespace_name));
00152 }
00153 
00154 static void load_namespace_utf8(Scheme_Object *namespace_name) {
00155   Scheme_Object *nsreq;
00156   Scheme_Object *a[1];
00157   Scheme_Thread * volatile p;
00158   mz_jmp_buf * volatile saved_error_buf;
00159   mz_jmp_buf new_error_buf;
00160 
00161   nsreq = scheme_builtin_value("namespace-require");
00162   a[0] = scheme_make_pair(scheme_intern_symbol("lib"),
00163       scheme_make_pair(namespace_name, scheme_make_null()));
00164 
00165   p = scheme_get_current_thread();
00166   saved_error_buf = p->error_buf;
00167   p->error_buf = &new_error_buf;
00168   if (!scheme_setjmp(new_error_buf))
00169     scheme_apply(nsreq, 1, a);
00170   p->error_buf = saved_error_buf;
00171 }
00172 
00173 Scheme_Object *scheme_places_deep_copy(Scheme_Object *so)
00174 {
00175   Scheme_Object *new_so = so;
00176   if (SCHEME_INTP(so)) {
00177     return so;
00178   }
00179 
00180   switch (so->type) {
00181     case scheme_char_string_type: /*43*/
00182       new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1);
00183       break;
00184     case scheme_unix_path_type:
00185       new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
00186       break;
00187     case scheme_symbol_type:
00188       {
00189         Scheme_Symbol *sym = (Scheme_Symbol *)so;
00190         new_so = scheme_intern_exact_symbol(sym->s, sym->len);
00191       }
00192       break;
00193     case scheme_pair_type:
00194       {
00195         Scheme_Object *car;
00196         Scheme_Object *cdr;
00197         Scheme_Object *pair;
00198         car = scheme_places_deep_copy(SCHEME_CAR(so));
00199         cdr = scheme_places_deep_copy(SCHEME_CDR(so));
00200         pair = scheme_make_pair(car, cdr);
00201         return pair;
00202       }
00203       break;
00204     case scheme_null_type:
00205       new_so = so;
00206       break;
00207     case scheme_resolved_module_path_type:
00208       abort();
00209       break;
00210     default:
00211       abort();
00212       break;
00213   }
00214   return new_so;
00215 }
00216 
00217 static void *place_start_proc(void *data_arg) {
00218   void *stack_base;
00219   Scheme_Object *thunk;
00220   Place_Start_Data *place_data;
00221   Scheme_Object *a[2];
00222   int ptid;
00223   ptid = mz_proc_thread_self();
00224 
00225 
00226   stack_base = PROMPT_STACK(stack_base);
00227   place_data = (Place_Start_Data *) data_arg;
00228  
00229   printf("Startin place: proc thread id%u\n", ptid);
00230 
00231   /* create pristine THREAD_LOCAL variables*/
00232   null_out_runtime_globals();
00233 
00234   /* scheme_make_thread behaves differently if the above global vars are not null */
00235 #ifdef MZ_PRECISE_GC
00236   GC_construct_child_gc();
00237 #endif
00238   scheme_place_instance_init(stack_base);
00239   a[0] = place_data->current_library_collection_paths;
00240   scheme_current_library_collection_paths(1, a);
00241 
00242 
00243   if (place_data->argc == 1)
00244   {
00245     load_namespace("scheme/init");
00246     thunk = place_data->thunk;
00247     scheme_apply(thunk, 0, NULL);
00248     stack_base = NULL;
00249   } else {
00250     Scheme_Object *place_main;
00251     a[0] = scheme_places_deep_copy(place_data->module);
00252     a[1] = place_main_symbol;
00253     place_main = scheme_dynamic_require(2, a);
00254 
00255     a[0] = scheme_places_deep_copy(place_data->channel);
00256     scheme_apply(place_main, 1, a);
00257   }
00258 
00259   return scheme_true;
00260 }
00261 
00262 Scheme_Object *scheme_places_deep_copy_in_master(Scheme_Object *so) {
00263 #if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
00264   void *return_payload;
00265   return_payload = scheme_master_fast_path(5, so);
00266   return (Scheme_Object*) return_payload;
00267 #endif
00268   return so;
00269 }
00270 
00271 #ifdef MZ_PRECISE_GC
00272 static void* scheme_master_place_handlemsg(int msg_type, void *msg_payload);
00273 static void *master_scheme_place(void *data) {
00274   mz_proc_thread *myself;
00275   myself = proc_thread_self;
00276   GC_switch_in_master_gc();
00277 
00278   while(1) {
00279     int recv_type;
00280     void *recv_payload;
00281     pt_mbox *origin;
00282     Scheme_Object *o;
00283 
00284     pt_mbox_recv(myself->mbox, &recv_type, &recv_payload, &origin);
00285     o = scheme_master_place_handlemsg(recv_type, recv_payload);
00286     pt_mbox_send(origin, 2, (void *) o, NULL);
00287   }
00288   return NULL;
00289 }
00290 
00291 static void* scheme_master_place_handlemsg(int msg_type, void *msg_payload)
00292 {
00293   switch(msg_type) {
00294     case 1:
00295       {
00296         Scheme_Object *o;
00297         Scheme_Object *copied_o;
00298         copied_o = scheme_places_deep_copy((Scheme_Object *)msg_payload);
00299         o = scheme_intern_resolved_module_path_worker(copied_o);
00300         return o;
00301       }
00302       break;
00303     case 3:
00304       {
00305         Scheme_Object *o;
00306         Scheme_Symbol_Parts *parts;
00307         parts = (Scheme_Symbol_Parts *) msg_payload;
00308         o = (Scheme_Object *)scheme_intern_exact_symbol_in_table_worker(parts->table, parts->kind, parts->name, parts->len);
00309         return o;
00310       }
00311       break;
00312     case 5:
00313       { 
00314         Scheme_Object *copied_o;
00315         copied_o = scheme_places_deep_copy((Scheme_Object *)msg_payload);
00316         return copied_o;
00317       }
00318       break;
00319   }
00320   return NULL;
00321 }
00322 
00323 void* scheme_master_fast_path(int msg_type, void *msg_payload) {
00324   Scheme_Object *o;
00325   void *original_gc;
00326 
00327   original_gc = GC_switch_to_master_gc();
00328   o = scheme_master_place_handlemsg(msg_type, msg_payload);
00329   GC_switch_back_from_master(original_gc);
00330 
00331   return o;
00332 }
00333 
00334 
00335 void spawn_master_scheme_place() {
00336   mzrt_proc_first_thread_init();
00337   
00338 
00339   //scheme_master_proc_thread = mz_proc_thread_create(master_scheme_place, NULL);
00340   scheme_master_proc_thread = ~0;
00341 
00342 }
00343 #endif
00344 
00345 /*========================================================================*/
00346 /*                       precise GC traversers                            */
00347 /*========================================================================*/
00348 
00349 #ifdef MZ_PRECISE_GC
00350 
00351 START_XFORM_SKIP;
00352 
00353 #define MARKS_FOR_PLACES_C
00354 #include "mzmark.c"
00355 
00356 static void register_traversers(void)
00357 {
00358   GC_REG_TRAV(scheme_place_type, place_val);
00359 }
00360 
00361 END_XFORM_SKIP;
00362 
00363 #endif
00364 
00365 /************************************************************************/
00366 /************************************************************************/
00367 /************************************************************************/
00368 
00369 #endif