Skip to content
Browse files

Implemented partly-parallel context split; currently broken

  • Loading branch information...
1 parent 0a9ebf7 commit 2a2a02f1af98d414e52f3e0ba43c676997424287 @lucasaiu committed
View
6 BOOTSTRAP
@@ -20,8 +20,8 @@ set -ex
# # This assumes ../unpatched-trunk contains an unpatched, configured
# # and compiled version of the OCaml source.
# PATCHED="$(pwd)"
-PATCHED="/home/luca/reentrant-runtime/working/trunk/"
-UNPATCHED="$PATCHED/../unpatched-trunk/"
+PATCHED="/home/luca/reentrant-runtime/repos/ocaml-development--more-advanced/"
+UNPATCHED="$PATCHED/../../unpatched-trunk/"
OLD="/tmp/old/"
COMPILERWITHOLDRUNTIME="/tmp/compiler-with-old-runtime/"
COMPILERWITHNEWRUNTIME="/tmp/compiler-with-new-runtime/"
@@ -29,6 +29,8 @@ export OLDOCAMLC="$OLD/byterun/ocamlrun $OLD/ocamlc"
export COMPILERWITHOLDRUNTIMEOCAMLC="$OLD/byterun/ocamlrun $COMPILERWITHOLDRUNTIME/ocamlc-stage1 -nostdlib -I $COMPILERWITHOLDRUNTIME/stdlib -use-runtime $COMPILERWITHOLDRUNTIME/byterun/ocamlrun"
export COMPILERWITHNEWRUNTIMEOCAMLC="$COMPILERWITHNEWRUNTIME/byterun/ocamlrun $COMPILERWITHNEWRUNTIME/ocamlc -nostdlib -I $COMPILERWITHNEWRUNTIME/stdlib -use-runtime $COMPILERWITHNEWRUNTIME/byterun/ocamlrun"
+cd "$PATCHED"
+
echo "Preparing temporary directories..."
rm -rf "$OLD" "$COMPILERWITHOLDRUNTIME" "$COMPILERWITHNEWRUNTIME"
cp -af "$UNPATCHED" "$OLD"
View
8 README.md
@@ -44,7 +44,7 @@ first argument.
Once all functions will have been rewritten like that, we should
implement the former version (without the first argument) by looking
up the context in the thread local storage, using the function
-"caml_get_global_context()".
+"caml_get_global_context()" [renamed into caml_get_thread_local_context --Luca Saiu].
Since we needed a global lock for all the runtimes, it has been
implemented as "caml_enter_blocking_section()" (which should still be
@@ -53,7 +53,11 @@ functions "caml_enter_lock_section()" and
"caml_leave_lock_section()". These functions don't do anything right
now, but locking should be added within the thread libraries by
redefining "caml_enter_lock_section_hook" and
-"caml_leave_lock_section_hook".
+"caml_leave_lock_section_hook". [FIXME: these names are very
+counterintuitive. Why do we have to name "caml_enter_lock_section"
+and "caml_enter_blocking_section" so similarly? --Luca Saiu. The name
+"caml_enter_lock_section" was terrible to begin with: see
+http://d.hatena.ne.jp/camlspotter/20100309/1268111257 ]
For static variables within libraries, the library should define its
own runtime context, and use "caml_get_library_context_r(...)" to
View
19 asmcomp/cmmgen.ml
@@ -1878,24 +1878,11 @@ let compunit size ulam =
Cint(Nativeint.minus_one); (* generate only one word which will store the offset, initializing it with
-1, an invalid value recognized as a special "uninitialized" marker.
--Luca Saiu REENTRANTRUNTIME *)
+ Cstring glob; (* useful for debugging --Luca Saiu REENTRANTRUNTIME *)
+ Cint8 0; (* '\0'-terminate the string *)
+ Calign 8; (* Don't break the alignment of what follows because of the string*)
] :: c3
-(* Backup, before my possibly extensive changes --Luca Saiu REENTRANTRUNTIME *)
-(* let compunit size ulam = *)
-(* let glob = Compilenv.make_symbol None in *)
-(* let init_code = transl ulam in *)
-(* let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry_r"); *)
-(* fun_args = []; *)
-(* fun_body = init_code; fun_fast = false; *)
-(* fun_dbg = Debuginfo.none }] in *)
-(* let c2 = transl_all_functions StringSet.empty c1 in *)
-(* let c3 = emit_all_constants c2 in *)
-(* Printf.printf "!!!!!!!!!!! size: %i; size_addr: %i\n" size size_addr; *)
-(* Cdata [Cint(block_header 0 size); *)
-(* Cglobal_symbol glob; *)
-(* Cdefine_symbol glob; *)
-(* Cskip(size * size_addr)] :: c3 (\* FIXME: this Cskip generates the .space line for the module. Instead of the skip I have to generate a C procedure call --Luca Saiu REENTRANTRUNTIME*\) *)
-
(*
CAMLprim value caml_cache_public_method (value meths, value tag, value *cache)
{
View
1 asmrun/backtrace.c
@@ -69,6 +69,7 @@ void caml_stash_backtrace_r(CAML_R, value exn, uintnat pc, char * sp, char * tra
caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
if (caml_backtrace_buffer == NULL) return;
}
+ fprintf(stderr, "$$$$$ FIXME Context %p: caml_stash_backtrace_r [FIXME: make sure this is reentrant; I don't think it is now]\n", ctx);
if (caml_frame_descriptors == NULL) caml_init_frame_descriptors_r(ctx);
while (1) {
View
1 asmrun/natdynlink.c
@@ -84,6 +84,7 @@ CAMLprim value caml_natdynlink_run_r(CAML_R, void *handle, value symbol) {
unit = String_val(symbol);
sym = optsym("__frametable");
+ fprintf(stderr, "$$$$$ FIXME Context %p: caml_natdynlink_run_r [FIXME: make sure this is reentrant; I don't think it is now]\n", ctx);
if (NULL != sym) caml_register_frametable_r(ctx, sym);
sym = optsym("");
View
15 asmrun/roots.c
@@ -50,6 +50,8 @@ static caml_link *cons(void *data, caml_link *tl) {
static caml_link *frametables = NULL;
void caml_register_frametable_r(CAML_R, intnat *table) {
+caml_acquire_global_lock();
+ fprintf(stderr, "$$$$$ Context %p: caml_register_frametable_r (table is at %p)\n", ctx, table);
frametables = cons(table,frametables);
if (NULL != caml_frame_descriptors) {
@@ -57,10 +59,13 @@ void caml_register_frametable_r(CAML_R, intnat *table) {
caml_frame_descriptors = NULL;
/* force caml_init_frame_descriptors to be called */
}
+caml_release_global_lock();
}
void caml_init_frame_descriptors_r(CAML_R)
{
+ fprintf(stderr, "$$$$$ Context %p: caml_init_frame_descriptors_r: BEGIN\n", ctx);
+caml_acquire_global_lock();
intnat num_descr, tblsize, i, j, len;
intnat * tbl;
frame_descr * d;
@@ -113,9 +118,12 @@ void caml_init_frame_descriptors_r(CAML_R)
d = (frame_descr *) nextd;
}
}
+caml_release_global_lock();
+ fprintf(stderr, "$$$$$ Context %p: caml_init_frame_descriptors_r: END\n", ctx);
}
void caml_register_dyn_global_r(CAML_R, void *v) {
+ /* No synchronization needed: this is context-local */
caml_dyn_globals = cons((void*) v,caml_dyn_globals);
}
@@ -123,6 +131,8 @@ void caml_register_dyn_global_r(CAML_R, void *v) {
heap. */
void caml_oldify_local_roots_r (CAML_R)
{
+ fprintf(stderr, "$$$$$ Context %p [thread %p]: caml_oldify_local_roots_r\n", ctx, (void*)(pthread_self()));caml_dump_global_mutex();
+caml_acquire_global_lock();
char * sp;
uintnat retaddr;
value * regs;
@@ -223,6 +233,7 @@ void caml_oldify_local_roots_r (CAML_R)
caml_final_do_young_roots_r (ctx, &caml_oldify_one_r);
/* Hook */
if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one_r);
+caml_release_global_lock();
}
/* Call [darken] on all roots */
@@ -234,6 +245,7 @@ void caml_darken_all_roots_r (CAML_R)
void caml_do_roots_r (CAML_R, scanning_action f)
{
+caml_acquire_global_lock();
int i, j;
value glob;
caml_link *lnk;
@@ -263,12 +275,14 @@ void caml_do_roots_r (CAML_R, scanning_action f)
caml_final_do_strong_roots_r (ctx, f);
/* Hook */
if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f);
+caml_release_global_lock();
}
void caml_do_local_roots_r(CAML_R, scanning_action f, char * bottom_of_stack,
uintnat last_retaddr, value * gc_regs,
struct caml__roots_block * local_roots)
{
+caml_acquire_global_lock();
char * sp;
uintnat retaddr;
value * regs;
@@ -337,6 +351,7 @@ void caml_do_local_roots_r(CAML_R, scanning_action f, char * bottom_of_stack,
}
}
}
+caml_release_global_lock();
}
uintnat caml_stack_usage_r (CAML_R)
View
4 asmrun/stack.h
@@ -84,8 +84,8 @@ extern int caml_frame_descriptors_mask;
extern void caml_init_frame_descriptors(dont_use);
extern void caml_init_frame_descriptors_r(CAML_R);
-extern void caml_register_frametable(dont_use, intnat *);
-extern void caml_register_frametable_r(CAML_R, intnat *);
+//extern void caml_register_frametable(dont_use, intnat *); // Not used from the outside
+//extern void caml_register_frametable_r(CAML_R, intnat *); // Not used from the outside
extern void caml_register_dyn_global(dont_use, void *);
extern void caml_register_dyn_global_r(CAML_R, void *);
View
12 asmrun/startup.c
@@ -146,7 +146,7 @@ static void parse_camlrunparam_r(CAML_R)
}
}
-extern __thread caml_global_context *caml_context; // in context.c
+//extern __thread caml_global_context *caml_context; // in context.c // FIXME: remove this: it's now a thread-local static variable
/* FIXME: refactor: call this from caml_main_rr --Luca Saiu REENTRANTRUNTIME */
caml_global_context* caml_make_empty_context(void)
@@ -154,9 +154,10 @@ caml_global_context* caml_make_empty_context(void)
// FIXME: lock
/* Make a new context in which to unmarshal back the byte array back
into a big data structure, copying whatever's needed: */
- caml_global_context *old_thread_local_context = caml_context;
+ //caml_global_context *old_thread_local_context = caml_get_thread_local_context();
caml_global_context *ctx = caml_initialize_first_global_context();
- caml_context = old_thread_local_context; // undo caml_initialize_first_global_context's trashing of the __thread variable
+ ctx->descriptor->kind = caml_global_context_nonmain_local;
+ //caml_set_thread_local_context(old_thread_local_context); // undo caml_initialize_first_global_context's trashing of the __thread variable
// FIXME: unlock
/* Initialize the abstract machine */
@@ -168,6 +169,10 @@ caml_global_context* caml_make_empty_context(void)
/* No need to call caml_init_signals for each context: its
initialization only needs to be performed once */
caml_debugger_init_r (ctx); /* force debugger.o stub to be linked */
+
+ /* Make the new context be the thread-local context for this thread: */
+ caml_set_thread_local_context(ctx);
+
return ctx;
}
@@ -184,6 +189,7 @@ caml_global_context* caml_main_rr(char **argv)
#endif
value res;
char tos;
+ caml_context_initialize_global_stuff();
CAML_R = caml_initialize_first_global_context();
caml_init_ieee_floats();
View
BIN boot/context.cmi
Binary file not shown.
View
BIN boot/libcamlrun.a
Binary file not shown.
View
BIN boot/myocamlbuild
Binary file not shown.
View
BIN boot/myocamlbuild.boot
Binary file not shown.
View
BIN boot/ocamlc
Binary file not shown.
View
BIN boot/ocamldep
Binary file not shown.
View
BIN boot/ocamllex
Binary file not shown.
View
BIN boot/ocamlrun
Binary file not shown.
View
BIN boot/ocamlrun.boot
Binary file not shown.
View
BIN boot/stdlib.cma
Binary file not shown.
View
1 byterun/callback.c
@@ -94,6 +94,7 @@ CAMLexport value caml_callbackN_exn_r(CAML_R, value closure, int narg, value arg
local_callback_code[5] = 1;
local_callback_code[6] = STOP;
#ifdef THREADED_CODE
+ // FIXME: this hasn't been replaced with an "_r" version; is it intentional? --Luca Saiu REENTRANTRUNTIME
caml_thread_code(local_callback_code, sizeof(local_callback_code));
#endif /*THREADED_CODE*/
res = caml_interprete(local_callback_code, sizeof(local_callback_code));
View
146 byterun/context.c
@@ -39,17 +39,16 @@
#include "alloc.h"
#include "intext.h"
-__thread caml_global_context *caml_context;
+static __thread caml_global_context *the_thread_local_caml_context = NULL;
caml_global_context *caml_get_thread_local_context(void)
{
- /* fprintf(stderr, "get caml_context %x\n", caml_context); */
- return caml_context;
+ return the_thread_local_caml_context;
}
void caml_set_thread_local_context(caml_global_context *new_caml_context)
{
- caml_context = new_caml_context;
+ the_thread_local_caml_context = new_caml_context;
}
extern void caml_enter_blocking_section_default(void);
@@ -62,7 +61,7 @@ extern char caml_globals_map[];
#endif
/* The global lock: */
-static pthread_mutex_t caml_global_mutex;
+static pthread_mutex_t caml_global_mutex = (pthread_mutex_t)(long)0xdeaddeaddeaddead;
caml_global_context *caml_initialize_first_global_context(void)
{
@@ -362,7 +361,7 @@ section. */
/* from parsing.c */
ctx->caml_parser_trace = 0;
- caml_context = ctx;
+ //caml_context = ctx;
/*
fprintf(stderr, "set caml_context %x\n", ctx);
fprintf(stderr, "enter_blocking_section_hook = %lx (%lx)\n",
@@ -386,19 +385,16 @@ section. */
ctx->c_globals.allocated_size = INITIAL_C_GLOBALS_ALLOCATED_SIZE;
ctx->c_globals.used_size = 0;
ctx->c_globals.array = caml_stat_alloc(ctx->c_globals.allocated_size);
-
+
+ /* By default, a context is associated with its creating thread: */
+ ctx->thread = pthread_self();
+ caml_set_thread_local_context(ctx);
+
/* Make a local descriptor for this context: */
ctx->descriptor = caml_stat_alloc(sizeof(struct caml_global_context_descriptor));
ctx->descriptor->kind = caml_global_context_main;
ctx->descriptor->content.local_context.context = ctx;
- /* Create the global lock: */
- pthread_mutexattr_t attributes;
- pthread_mutexattr_init(&attributes);
- pthread_mutexattr_settype(&attributes, PTHREAD_MUTEX_RECURSIVE_NP);
- pthread_mutex_init(&caml_global_mutex, &attributes);
- pthread_mutexattr_destroy(&attributes);
-
return ctx;
}
@@ -432,13 +428,36 @@ void* caml_context_local_c_variable_r(CAML_R, caml_c_global_id id){
void caml_scan_caml_globals_r(CAML_R, scanning_action f){
int i, caml_global_no = ctx->caml_globals.used_size / sizeof(value);
- /* if(caml_global_no != 0) */
- /* printf("Context %p: scanning the %i Caml globals\n", ctx, caml_global_no); */
- /* else */
- /* printf("Context %p: there are no Caml globals to scan\n", ctx); */
+ if(ctx != caml_get_thread_local_context())
+ {fprintf(stderr, "Context %p: it's different from the thread-local context %p !!!\n", ctx, caml_get_thread_local_context()); fflush(stderr);};
+
+ /*
+ fprintf(stderr, "Context %p: ", ctx);;
+ switch(ctx->descriptor->kind){
+ case caml_global_context_main:
+ fprintf(stderr, "this is the main context.\n"); break;
+ case caml_global_context_nonmain_local:
+ fprintf(stderr, "this is a non-main local context.\n"); break;
+ case caml_global_context_remote:
+ fprintf(stderr, "this is a remote context [!!!]\n"); break;
+ default:
+ fprintf(stderr, "impossible [!!!]\n");
+ } // switch
+ fflush(stderr);
+ */
+
+ if(caml_get_thread_local_context()->descriptor->kind == caml_global_context_nonmain_local){
+ if(caml_global_no != 0)
+ {fprintf(stderr, "Context %p: scanning the %i Caml globals\n", ctx, caml_global_no); fflush(stderr);}
+ else
+ {fprintf(stderr, "~~~~~~~~~~~~~~~~~~~~~~~ Context %p: there are no Caml globals to scan [!!!]\n", ctx); fflush(stderr);}
+ }
+
value *caml_globals = (value*)(ctx->caml_globals.array);
for(i = 0; i < caml_global_no; i ++){
value *root_pointer = caml_globals + i;
+ if(*root_pointer == 0)
+ fprintf(stderr, "%%%%%%%%%% Context %p: the %i-th root is zero!\n", ctx, i);
f(ctx, *root_pointer, root_pointer);
}
//printf("Scanning Caml globals: end\n");
@@ -464,13 +483,15 @@ void caml_scan_caml_globals_r(CAML_R, scanning_action f){
be changed. --Luca Saiu REENTRANTRUNTIME*/
void caml_enter_lock_section_default(void)
{
+ caml_acquire_global_lock(); // FIXME: experimental --Luca Saiu
}
void caml_leave_lock_section_default(void)
{
+ caml_release_global_lock(); // FIXME: experimental --Luca Saiu
}
-/* I'm leaving these as globals, shared bu all contexts. --Luca Saiu REENTRANTRUNTIME*/
+/* I'm leaving these as globals, shared by all contexts. --Luca Saiu REENTRANTRUNTIME*/
void (*caml_enter_lock_section_hook)(void) = caml_enter_lock_section_default;
void (*caml_leave_lock_section_hook)(void)= caml_leave_lock_section_default;
void caml_enter_lock_section_r(CAML_R)
@@ -569,14 +590,19 @@ static long first_unused_word_offset = 0; // the first word is unused
void caml_register_module_r(CAML_R, size_t size_in_bytes, long *offset_pointer){
/* Compute the size in words, which is to say how many globals are there: */
int size_in_words = size_in_bytes / sizeof(void*);
+ /* We keep the module name right after the offset pointer, as a read-only string: */
+ char *module_name = (char*)offset_pointer + sizeof(long);
+
Assert(size_in_words * sizeof(void*) == size_in_bytes); /* there's a whole number of globals */
- /* fprintf(stderr, "caml_register_module_r: BEGIN [%lu bytes at %p]\n", */
- /* (unsigned long)size_in_bytes, */
- /* offset_pointer); */
+ fprintf(stderr, "Context %p: ??????? caml_register_module_r [%s]: BEGIN [%lu bytes at %p]\n",
+ ctx,
+ module_name,
+ (unsigned long)size_in_bytes,
+ offset_pointer); fflush(stderr);
/* If this is the first time we register this module, make space for its globals in
ctx->caml_globals. If the module was already registered, do nothing. */
- caml_acquire_global_lock_r(ctx);
+ caml_acquire_global_lock();
if(*offset_pointer == -1){
/* fprintf(stderr, "Registering the module %p for the first time: making place for %i globals\n", offset_pointer, (int)size_in_words); */
/* fprintf(stderr, "first_unused_word_offset is %i\n", (int)first_unused_word_offset); */
@@ -590,11 +616,11 @@ void caml_register_module_r(CAML_R, size_t size_in_bytes, long *offset_pointer){
}
/* else */
/* fprintf(stderr, "The module %p has already been registered: its offset is %i\n", offset_pointer, (int)*offset_pointer); */
- caml_release_global_lock_r(ctx);
+ caml_release_global_lock();
/* fprintf(stderr, "The offset (in bytes) we just wrote at %p is %li\n", offset_pointer, *offset_pointer); */
/* fprintf(stderr, "The context is at %p\n", (void*)ctx); */
/* fprintf(stderr, "Globals are at %p\n", (void*)ctx->caml_globals.array); */
- /* fprintf(stderr, "caml_register_module_r: registered %p. END (still alive)\n\n", offset_pointer); */
+ fprintf(stderr, "caml_register_module_r: registered %p [%s]. END (still alive)\n", offset_pointer, module_name); fflush(stderr);
}
void caml_after_module_initialization_r(CAML_R, size_t size_in_bytes, long *offset_pointer){
@@ -647,30 +673,66 @@ CAMLprim value caml_context_is_remote_r(CAML_R, value descriptor)
== caml_global_context_remote);
}
-/* /\* A function with an interface easier to call from OCaml: *\/ */
-/* CAM__Lprim value caml_context_clone_and_return_value_r(CAML_R, value unit){ */
-/* return Val_unit; // FIXME: remove this function */
-/* } */
+void caml_context_initialize_global_stuff(void){
+ /* Attempt to prevent multiple initialization. This will not always
+ work, because of missing synchronization: we can't use the global
+ mutex, since we're gonna initialize it here. */
+ static int already_initialized = 0;
+ if(already_initialized){
+ fprintf(stderr, "caml_initialize_global_stuff: called more than once\n");
+ fflush(stderr);
+ exit(EXIT_FAILURE);
+ }
+ already_initialized = 1;
+
+ /* Create the global lock: */
+ pthread_mutexattr_t attributes;
+ pthread_mutexattr_init(&attributes);
+ int result = pthread_mutexattr_settype(&attributes, PTHREAD_MUTEX_RECURSIVE_NP);
+ if(result){
+ fprintf(stderr, "++++++++ [thread %p] pthread_mutexattr_settype failed\n", (void*)(pthread_self())); fflush(stderr);
+ exit(EXIT_FAILURE);
+ }
+ pthread_mutex_init(&caml_global_mutex, &attributes);
+ fprintf(stderr, "= {%u %p | %p}\n", caml_global_mutex.__data.__count, (void*)(long)caml_global_mutex.__data.__count, (void*)(pthread_self())); fflush(stderr);
+ pthread_mutexattr_destroy(&attributes);
+}
-void caml_acquire_global_lock_r(CAML_R){
+void caml_acquire_global_lock(void){
/* FIXME: is this needed? I wanna play it safe --Luca Saiu REENTRANTRUNTIME */
+ int old_value = caml_global_mutex.__data.__count;
+ int old_owner = caml_global_mutex.__data.__owner;
int result __attribute__((unused));
- //caml_enter_lock_section_r(ctx);
+ INIT_CAML_R;
+ //caml_enter_blocking_section_r(ctx);
result = pthread_mutex_lock(&caml_global_mutex);
+ //caml_leave_blocking_section_r(ctx);
+ /////BEGIN
+ if(result){
+ fprintf(stderr, "++++++++ [context %p] [thread %p] pthread_mutex_lock failed\n", ctx, (void*)(pthread_self())); fflush(stderr);
+ exit(EXIT_FAILURE);
+ }
+ //fprintf(stderr, "+[context %p] {%u %p->%u %p | %p}\n", ctx, old_value, (void*)(long)old_owner, caml_global_mutex.__data.__count, (void*)(long)caml_global_mutex.__data.__owner, (void*)(pthread_self())); fflush(stderr);
+ /////END
Assert(result == 0);
}
-void caml_release_global_lock_r(CAML_R){
+void caml_release_global_lock(void){
+ int old_value = caml_global_mutex.__data.__count;
+ int old_owner = caml_global_mutex.__data.__owner;
+ INIT_CAML_R;
+ //caml_enter_blocking_section_r(ctx);
int result __attribute__((unused)) = pthread_mutex_unlock(&caml_global_mutex);
+ //caml_leave_blocking_section_r(ctx);
Assert(result == 0);
- /* FIXME: is this needed? I wanna play it safe --Luca Saiu REENTRANTRUNTIME */
- //caml_leave_lock_section_r(ctx);
+ /////BEGIN
+ if(result){
+ fprintf(stderr, "++++++++ [context %p] [thread %p] pthread_mutex_unlock failed\n", ctx, (void*)(pthread_self())); fflush(stderr);
+ exit(EXIT_FAILURE);
+ }
+ //fprintf(stderr, "-[context %p] {%u %p->%u %p | %p}\n", ctx, old_value, (void*)(long)old_owner, caml_global_mutex.__data.__count, (void*)(long)caml_global_mutex.__data.__owner, (void*)(pthread_self())); fflush(stderr);
+ /////END
}
-/* CA__MLprim value caml_context_dump_r(CAML_R, value unit){ */
-/* #ifdef NATIVE_CODE */
-/* //printf("%p->caml_bottom_of_stack is %p\n", ctx, ctx->caml_bottom_of_stack); */
-/* return Val_long((long)(ctx->caml_bottom_of_stack)); */
-/* #else */
-/* return Val_long(0); */
-/* #endif /\* else (#ifdef NATIVE_CODE) *\/ */
-/* } */
+void caml_dump_global_mutex(void){
+ fprintf(stderr, "{%u %p | %p}\n", caml_global_mutex.__data.__count, (void*)(long)caml_global_mutex.__data.__owner, (void*)(pthread_self())); fflush(stderr);
+}
View
17 byterun/context.h
@@ -29,9 +29,12 @@
#include <setjmp.h> // FIXME: remove if not needed in the end --Luca Saiu REENTRANTRUNTIME
#include "config.h"
#include "misc.h"
-
#include "extensible_buffer.h"
+/* An initialization function to be called at startup, once and only once: */
+void caml_context_initialize_global_stuff(void);
+
+
/* The sentinel can be located anywhere in memory, but it must not be
adjacent to any heap object. */
typedef struct fl_sentinel {
@@ -298,7 +301,7 @@ struct caml_global_context {
/* FIXME: This is the version by Fabrice, which looks out-of-date
with respect to his changes in asmrun/roots.c. Keeping it as it is
- in this comment, for the time begin --Luca Saiu REENTRANTRUNTIME */
+ in this comment, for the time being --Luca Saiu REENTRANTRUNTIME */
/* char * caml_top_of_stack; */
/* intnat caml_globals_inited; */
/* intnat caml_globals_scanned; */
@@ -532,6 +535,7 @@ struct caml_global_context {
/* Procedure parameters: */
struct caml_global_context *after_longjmp_context;
char *after_longjmp_serialized_blob;
+ pthread_t thread;
}; /* struct caml_global_context */
/* Context descriptors may be either local or remote: */
@@ -541,7 +545,8 @@ enum caml_global_context_descriptor_kind{
caml_global_context_remote
}; /* enum caml_global_context_kind */
-/* A local context descriptor trivially refers a context: */
+/* A local context descriptor trivially refers a context. This is
+ used for the main context and for non-main local contexts. */
struct caml_local_context_descriptor{
struct caml_global_context *context;
}; /* struct caml_local_context */
@@ -909,7 +914,9 @@ void* caml_context_local_c_variable_r(CAML_R, caml_c_global_id id);
void caml_register_module_r(CAML_R, size_t size_in_bytes, long *offset_pointer);
/* Acquire or release a global mutex: */
-void caml_acquire_global_lock_r(CAML_R);
-void caml_release_global_lock_r(CAML_R);
+void caml_acquire_global_lock(void);
+void caml_release_global_lock(void);
+// FIXME: remove this after debugging
+void caml_dump_global_mutex(void);
#endif
View
418 byterun/context_split.c
@@ -3,6 +3,8 @@
#include <unistd.h>
#include <string.h>
#include <pthread.h>
+#include <semaphore.h>
+#include <limits.h> // FIXME: remove if not used in the end
#define CAML_CONTEXT_ROOTS /* GC-protection macros */
#include "mlvalues.h"
@@ -12,23 +14,31 @@
#include "signals.h"
#include "memory.h"
#include "fail.h"
-#include "callback.h" // for caml_callback_r
+#include "callback.h" // for caml_callback_r and friends
#include "alloc.h"
#include "intext.h"
-#include "gc_ctrl.h" // FIXME: remove after debugging
-#include "compact.h" // FIXME: remove after debugging
+#include "gc_ctrl.h" // FIXME: remove after debugging, if possible
+#include "compact.h" // FIXME: remove after debugging, if possible
+
+/* We implement a slightly more general facility than what is declared
+ in the header. Each serialized context contains globals, plus a
+ tuple of values which may share pointers (not necessarily one
+ single closure). */
static value caml_tuple_of_c_array_r(CAML_R, value *array, size_t element_no)
{
/* No need for GC protection: this is the only allocation, and if
the GC moves the objects pointed by array at allocation time,
that's no problem. */
- //printf(">>>>>>>>>element_no is %i\n", (int)element_no);
+ //fprintf(stderr, ">>>>>>>>>element_no is %i\n", (int)element_no);
value result = caml_alloc_tuple_r(ctx, element_no);
int i;
- for(i = 0; i < element_no; i ++)
+ for(i = 0; i < element_no; i ++){
+ if(array[i] == 0)
+ fprintf(stderr, "%%%%%%%%%% Context %p: the %i-th array element is zero!\n", ctx, i);
caml_initialize_r(ctx, &Field(result, i), array[i]);
+ }
return result;
}
@@ -38,8 +48,11 @@ static void caml_copy_tuple_elements_r(CAML_R, value *to_array, size_t *to_eleme
size_t element_no = Wosize_val(from_tuple);
*to_element_no = element_no;
int i;
- for(i = 0; i < element_no; i ++)
+ for(i = 0; i < element_no; i ++){
+ if(Field(from_tuple, i) == 0)
+ fprintf(stderr, "%%%%%%%%%% Context %p: the %i-th tuple element is zero!\n", ctx, i);
to_array[i] = Field(from_tuple, i);
+ }
}
static value caml_pair_r(CAML_R, value left, value right)
@@ -65,11 +78,13 @@ value caml_global_tuple_r(CAML_R)
point: no need fot GC protection: */
value globals = caml_alloc_tuple_r(ctx, global_no);
int i;
- for(i = 0; i < global_no; i ++)
+ for(i = 0; i < global_no; i ++){
+ if(((value*)ctx->caml_globals.array)[i] == 0)
+ fprintf(stderr, "%%%%%%%%%% Context %p: the %i-th global is zero!\n", ctx, i);
caml_initialize_r(ctx, &Field(globals, i), ((value*)ctx->caml_globals.array)[i]);
-
+ }
int element_no = Wosize_val(globals);
- printf("[native] The tuple has %i elements; it should be %i\n", (int)element_no, (int)global_no);
+ fprintf(stderr, "[native] The tuple has %i elements; it should be %i\n", (int)element_no, (int)global_no);
return globals;
#else /* bytecode */
@@ -77,7 +92,7 @@ value caml_global_tuple_r(CAML_R)
// FIXME: for debugging only. Remove: BEGIN
value globals = ctx->caml_global_data;
int element_no = Wosize_val(globals);
- printf("[bytecode] The tuple has %i elements\n", (int)element_no);
+ fprintf(stderr, "[bytecode] The tuple has %i elements\n", (int)element_no);
// FIXME: for debugging only. Remove: END
return ctx->caml_global_data;
@@ -95,7 +110,7 @@ void caml_set_globals_r(CAML_R, value global_tuple){
from the Caml heap, in either branch. */
#ifdef NATIVE_CODE
size_t global_tuple_size = Wosize_val(global_tuple);
- //printf("caml_set_globals_r: there are %i globals to be copied\n", (int)global_tuple_size);
+ //fprintf(stderr, "caml_set_globals_r: there are %i globals to be copied\n", (int)global_tuple_size);
caml_resize_extensible_buffer(&ctx->caml_globals,
global_tuple_size * sizeof(value),
1);
@@ -105,7 +120,7 @@ void caml_set_globals_r(CAML_R, value global_tuple){
to_globals, &to_global_no,
global_tuple);
Assert(to_global_no == global_tuple_size);
- //printf("TTTTTTTTTTT: there are now %i globals in the child context\n", (int)(ctx->caml_globals.used_size / sizeof(value)));
+ //fprintf(stderr, "TTTTTTTTTTT: there are now %i globals in the child context\n", (int)(ctx->caml_globals.used_size / sizeof(value)));
#else /* bytecode */
ctx->caml_global_data = global_tuple;
// FIXME: is this needed? It might be. It's in startup.c, right after loading
@@ -134,7 +149,7 @@ static char* caml_globals_and_data_as_c_byte_array_r(CAML_R, value *data, size_t
/* Make a big structure holding all globals and user-specified data: */
globals_and_data = caml_globals_and_data_r(ctx, data, element_no);
-
+
/* Serialize it into a malloced string, and return the string: */
flags = /* Marshal.Closures :: Marshal.Cross_context :: [] */
//caml_pair_r(ctx, Val_int(0), /* Marshal.Closures, 1st constructor */
@@ -151,12 +166,11 @@ static char* caml_globals_and_data_as_c_byte_array_r(CAML_R, value *data, size_t
/* Marshal the big data structure into a byte array: */
caml_output_value_to_malloc_r(ctx, globals_and_data, flags,
&serialized_tuple, &serialized_tuple_length);
- printf("Ok-Q 100: ...serialized the huge structure into the blob at %p (length %.2fMB).\n", (void*)globals_and_data, serialized_tuple_length / 1024. / 1024.);
+ fprintf(stderr, "Ok-Q 100: ...serialized the huge structure into the blob at %p (length %.2fMB).\n", (void*)globals_and_data, serialized_tuple_length / 1024. / 1024.);
CAMLreturnT(char*, serialized_tuple);
}
-/* This function also frees the buffer pointed by globals_and_data_as_c_array, which must be malloc'ed. */
static void caml_install_globals_and_data_as_c_byte_array_r(CAML_R, value *to_values, char *globals_and_data_as_c_array){
/* No need to GC-protect anything here. We have no Caml objects to
GC-protect before initializing globals_and_data by a call to
@@ -164,215 +178,227 @@ static void caml_install_globals_and_data_as_c_byte_array_r(CAML_R, value *to_va
allocate anything in this function. */
value globals_and_data, global_tuple, data_tuple;
size_t to_value_no __attribute__((unused));
- //printf("Ok-A 100\n");
+ //fprintf(stderr, "Ok-A 100\n");
/* Deserialize globals and data from the byte array, and access each
element of the pair. */
+ //fprintf(stderr, "Context %p: L0 [thread %p]\n", ctx, (void*)(pthread_self())); fflush(stderr);
globals_and_data =
- caml_input_value_from_malloc_r(ctx, globals_and_data_as_c_array, 0); // this also frees the buffer */
+ caml_input_value_from_block_r(ctx,
+ globals_and_data_as_c_array,
+ /* FIXME: this third parameter is useless in practice: ask the OCaml people to
+ provide an alternate version of caml_input_value_from_block_r with two parameters.
+ I don't want to mess up the interface myself, since I'm doing a lot of other
+ invasive changes --Luca Saiu REENTRANTRUNTIME */
+ LONG_MAX);
+ //fprintf(stderr, "Context %p: L1 [thread %p]\n", ctx, (void*)(pthread_self())); fflush(stderr);
+ //caml_input_value_from_malloc_r(ctx, globals_and_data_as_c_array, 0); // this also frees the buffer */
global_tuple = Field(globals_and_data, 0);
data_tuple = Field(globals_and_data, 1);
+ //fprintf(stderr, "Context %p: L2 [thread %p]\n", ctx, (void*)(pthread_self())); fflush(stderr);
/* Replace the context globals with what we got: */
caml_set_globals_r(ctx, global_tuple);
- //printf("Ok-A 500\n");
+ //fprintf(stderr, "Context %p: L3 [thread %p]\n", ctx, (void*)(pthread_self())); fflush(stderr);
/* Copy deserialized data from the tuple where the user requested; the tuple
will be GC'd: */
caml_copy_tuple_elements_r(ctx,
to_values, &to_value_no,
data_tuple);
- //printf("Ok-A 600 (the tuple has %i elements)\n", (int)to_value_no);
+ //fprintf(stderr, "Context %p: L4 [thread %p]\n", ctx, (void*)(pthread_self())); fflush(stderr);
+ //fprintf(stderr, "Ok-A 600 (the tuple has %i elements)\n", (int)to_value_no);
}
-/* No "_r" suffix, nor CAML_R here: I view this function as quite
- special since its the first parameter is not "the implicit current
- context". */
-caml_global_context* caml_split_context(caml_global_context *from_ctx,
- value *to_values,
- value *from_values,
- size_t value_no){
- char *serialized_data =
- caml_globals_and_data_as_c_byte_array_r(from_ctx, from_values, value_no);
-
- caml_global_context *to_ctx = caml_make_empty_context();
- caml_set_thread_local_context(to_ctx); // FIXME: this is horrible
- caml_install_globals_and_data_as_c_byte_array_r(to_ctx, to_values, serialized_data);
- //printf("RRRRRRRRRRRR: there are %i globals in the child context\n", (int)(to_ctx->caml_globals.used_size / sizeof(value)));
- caml_set_thread_local_context(from_ctx); // FIXME: this is horrible
- return to_ctx;
+/* Implement the interface specified in the header file. */
+
+/* struct caml_context_blob{ */
+/* char *data; */
+/* int reference_count; */
+/* }; /\* struct *\/ */
+
+static char* caml_serialize_context(CAML_R, value function)
+{
+ CAMLparam1(function);
+ char *result = caml_globals_and_data_as_c_byte_array_r(ctx, &function, 1);
+ CAMLreturnT(char*, result);
}
-static void caml_run_in_new_context_then_exit_r(CAML_R, char *serialized_data){
+static void caml_deserialize_and_run_in_this_thread(char *blob, int index, sem_t *semaphore, /*out*/caml_global_context **to_context)
+{
+ CAML_R = caml_make_empty_context(); // this also sets the thread-local context
CAMLparam0();
- CAMLlocal1(new_thunk);
- caml_set_thread_local_context(ctx); // FIXME: this is horrible
- //caml_verb_gc = 255;
-#ifdef NATIVE_CODE
- char tos;
- //printf("In the child context caml_bottom_of_stack is %p\n", caml_bottom_of_stack);
- ///*ctx->*/caml_bottom_of_stack = &tos;
- /*ctx->*/caml_top_of_stack = &tos;
-#endif /* #ifdef NATIVE_CODE */
- //printf("caml_run_in_new_context_then_exit_r [0] Gc'ing in the new context with no data, just to check whether it crashes\n");
- caml_gc_compaction_r(ctx, Val_unit); //!
- //printf("caml_run_in_new_context_then_exit_r [1] still alive.\n");
- //caml_local_roots = NULL;
- caml_install_globals_and_data_as_c_byte_array_r(ctx, &new_thunk, serialized_data); // this free's the C buffer
- ////
- //printf("caml_run_in_new_context_then_exit_r [A]: new_thunk is %p\n", (void*)new_thunk);
- //caml_gc_compaction_r(ctx, Val_unit); //!
- //printf("caml_run_in_new_context_then_exit_r [B]: new_thunk is %p\n", (void*)new_thunk);
- /* caml_gc_compaction_r(ctx, Val_unit); //! */
- /* printf("caml_run_in_new_context_then_exit_r [B2]: new_thunk is %p\n", (void*)new_thunk); */
- ////
- //printf("caml_run_in_new_context_then_exit_r [C]: calling new_thunk\n");
+ CAMLlocal2(function, result_or_exception);
+
+//fprintf(stderr, "W0[context %p] [thread %p] (index %i) BBBBBBBBBBBBBBBBBBBBBBBBBB\n", ctx, (void*)(pthread_self()), index); fflush(stderr); caml_acquire_global_lock(); // FIXME: a test. this is obviously unusable in production
+ fprintf(stderr, "W1 [context %p] ctx->caml_local_roots is %p\n", ctx, caml_local_roots); fflush(stderr);
+ /* Make a new context, and deserialize the blob into it: */
+ fprintf(stderr, "W2 [context %p] [thread %p] (index %i)\n", ctx, (void*)(pthread_self()), index); fflush(stderr);
+ caml_gc_compaction_r(ctx, Val_unit); //!!!!!
+ fprintf(stderr, "W3 [context %p] [thread %p] (index %i) (function %p)\n", ctx, (void*)(pthread_self()), index, (void*)function); fflush(stderr);
+
+ // Allocate some trash:
+ caml_pair_r(ctx,
+ caml_pair_r(ctx, Val_int(1), Val_int(2)),
+ caml_pair_r(ctx, Val_int(3), Val_int(4)));
+
+ caml_install_globals_and_data_as_c_byte_array_r(ctx, &function, blob);
+ fprintf(stderr, "W4 [context %p] [thread %p] (index %i) (function %p)\n", ctx, (void*)(pthread_self()), index, (void*)function); fflush(stderr);
+ caml_gc_compaction_r(ctx, Val_unit); //!!!!!
+
+/* caml_empty_minor_heap_r(ctx); */
+/* caml_finish_major_cycle_r (ctx); */
+/* caml_compact_heap_r (ctx); */
+/* caml_final_do_calls_r (ctx); */
+
+ fprintf(stderr, "W5 [context %p] [thread %p] (index %i) (function %p)\n", ctx, (void*)(pthread_self()), index, (void*)function); fflush(stderr);
+ *to_context = ctx;
+
+ /* We're done with the blob: unpin it via the semaphore, so that it
+ can be destroyed when all threads have deserialized. */
+//fprintf(stderr, "W5.5context %p] [thread %p] (index %i) EEEEEEEEEEEEEEEEEEEEEEEEEE\n", ctx, (void*)(pthread_self()), index); fflush(stderr); caml_release_global_lock(); // FIXME: a test. this is obviously inefficient
+ sem_post(semaphore);
+
+ /* Run the Caml function: */
+ fprintf(stderr, "W6 [context %p] [thread %p] (index %i) (function %p)\n", ctx, (void*)(pthread_self()), index, (void*)function); fflush(stderr);
+ caml_gc_compaction_r(ctx, Val_unit); //!!!!!
+ fprintf(stderr, "W7 [context %p] [thread %p] (index %i) (%i globals) ctx->caml_local_roots is %p\n", ctx, (void*)(pthread_self()), index, (int)(ctx->caml_globals.used_size / sizeof(value)), caml_local_roots); fflush(stderr);
+ caml_dump_global_mutex();
+
+ result_or_exception = caml_callback_exn_r(ctx, function, Val_int(index));
+ if(Is_exception_result(result_or_exception)){
+ fprintf(stderr, "W7.5 [context %p] [thread %p] (index %i): the ocaml code raised an exception: FIXME: implement this case\n", ctx, (void*)(pthread_self()), index); fflush(stderr);
+ exit(EXIT_FAILURE);
+ } // if
+
+ fprintf(stderr, "W8 [context %p] [thread %p] (index %i): STILL ALIVE AFTER RUNNING THE OCAML CODE\n", ctx, (void*)(pthread_self()), index); fflush(stderr);
#ifdef NATIVE_CODE
- //printf("In the child context caml_bottom_of_stack is %p\n", /*ctx->*/caml_bottom_of_stack);
-#endif /* #ifdef NATIVE_CODE */
- caml_callback_r(ctx, new_thunk, Val_unit);
- fprintf(stderr, "caml_run_in_new_context_then_exit_r: SUCCESS, about to exit\n");
- exit(EXIT_FAILURE);
- CAMLreturn0; // unreachable
+ //fprintf(stderr, "@@@@@ In the child context caml_bottom_of_stack is %p\n", caml_bottom_of_stack);
+#endif // #ifdef NATIVE_CODE
+ caml_gc_compaction_r(ctx, Val_unit); //!!!!!@@@@@@@@@@@@@@
+ fprintf(stderr, "W9 [context %p] [thread %p] (index %i)\n", ctx, (void*)(pthread_self()), index); fflush(stderr);
+ //caml_dump_global_mutex();
+ CAMLreturn0;
}
-/* A function with an interface easier to call from OCaml: */
-CAMLprim value caml_context_fork_and_run_thunk_r(CAML_R, value thunk){
- CAMLparam1(thunk);
- printf("OK-PP(a): %p\n", (void*)thunk);
- //caml_gc_minor_r(ctx, Val_unit);
- //int i; for(i = 0; i < 10; i++) caml_gc_minor_r(ctx, Val_unit);
- caml_gc_compaction_r(ctx, Val_unit);
- printf("OK-PP(b): %p\n", (void*)thunk);
- //CAMLlocal1(new_thunk);
-
- char *serialized_data =
- caml_globals_and_data_as_c_byte_array_r(ctx, &thunk, 1);
-
- printf("OK-PP(c): %p\n", (void*)thunk);
- int fork_result = fork();
- switch(fork_result){
- case -1:
- caml_failwith_r(ctx, "fork failed");
-// FIXME: swap back the child and parent branches
- //default: /* parent process */
- case 0:
- fprintf(stderr, "[Hello from the child process]\n");
- free(serialized_data);
- break;
- //case 0: /* child process */
- default:
- fprintf(stderr, "[Hello from the parent process]\n");
- // FIXME: handle exceptions
-
- /* caml_global_context *new_context = caml_make_empty_context(); */
- /* caml_run_in_new_context(new_context, serialized_data); */
- /* exit(EXIT_SUCCESS); */
- ctx->after_longjmp_function = caml_run_in_new_context_then_exit_r;
- ctx->after_longjmp_context = caml_make_empty_context();
- ctx->after_longjmp_serialized_blob = serialized_data;
- longjmp(ctx->where_to_longjmp, 1);
- //CAMLreturn(Val_unit); // unreachable
- } /* switch */
- //CAMLreturn(caml_value_of_context_descriptor(new_context->descriptor));
- CAMLreturn(Val_unit); // unreachable
+struct caml_thread_arguments{
+ char *blob;
+ sem_t *semaphore;
+ caml_global_context **split_contexts;
+ int index;
+}; /* struct */
+
+static void* caml_deserialize_and_run_in_this_thread_as_thread_function(void *args_as_void_star)
+{
+ struct caml_thread_arguments *args = args_as_void_star;
+ //fprintf(stderr, "Q0 (index %i)\n", args->index);
+ //sleep(12); // FIXME: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ //fprintf(stderr, "Q1 (index %i)\n", args->index);
+ caml_deserialize_and_run_in_this_thread(args->blob, args->index, args->semaphore, args->split_contexts + args->index);
+ fprintf(stderr, "Q2 (index %i) [about to free args]\n", args->index); fflush(stderr);
+ caml_stat_free(args);
+ fprintf(stderr, "Q3 (index %i): about to exit the thread\n", args->index); fflush(stderr);
+ return NULL;
+}
+static void caml_split_and_destroy_blob_r(CAML_R, char *blob, caml_global_context **split_contexts, size_t how_many, sem_t *semaphore)
+{
+ fprintf(stderr, "CONTEXT %p: >>>> The parent context is %p\n", ctx, ctx);
+#ifdef NATIVE_CODE
+ fprintf(stderr, "@@@@@ In the parent context caml_bottom_of_stack is %p\n", caml_bottom_of_stack);
+#endif // #ifdef NATIVE_CODE
+ fprintf(stderr, "CONTEXT %p: >>>> A nice collection before starting...\n", ctx);
+ caml_gc_compaction_r(ctx, Val_unit); //!!!!!
+ fprintf(stderr, "CONTEXT %p: >>>> Still alive. Good. Now creating threds.\n", ctx);
+ int i;
+ for(i = 0; i < how_many; i ++){
+ //sleep(10); // FIXME: !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ pthread_t thread;
+ struct caml_thread_arguments *args = caml_stat_alloc(sizeof(struct caml_thread_arguments));
+ int pthread_create_result;
+ args->blob = blob;
+ args->semaphore = semaphore;
+ args->split_contexts = split_contexts;
+ args->index = i;
+ pthread_create_result =
+ pthread_create(&thread, NULL, caml_deserialize_and_run_in_this_thread_as_thread_function, args);
+ if(pthread_create_result != 0)
+ caml_failwith_r(ctx, "pthread_create failed"); // FIXME: blob is leaked is this case
+ } /* for */
+ /* Wait for the last thread to use the blob, then destroy it: */
+ fprintf(stderr, "Context %p: >>>> Waiting for every thread to deserialize...\n", ctx);
+ for(i = 0; i < how_many; i ++){
+ fprintf(stderr, "Context %p: >>>> Before doing P; showing the mutex\n", ctx); caml_dump_global_mutex();
+ sem_wait(semaphore);
+ fprintf(stderr, "Context %p: >>>> One child thread has finished with the blob; waiting for %i more...\n", ctx, (int)(how_many - i - 1));
+ }
+ fprintf(stderr, "Context %p: >>>> All child threads have finished with the blob. Destroying the blob...\n", ctx);
+ caml_stat_free(blob);
+ fprintf(stderr, "Context %p: >>>> Done, still alive after free'ing the blob\n", ctx);
+ caml_gc_compaction_r(ctx, Val_unit); //!!!!!
+ fprintf(stderr, "Context %p: >>>> Done, still alive after a GC\n", ctx);
}
-/* /\* A function with an interface easier to call from OCaml: *\/ */
-/* CAMLp___rim value caml_context_fork_and_run_thunk_r(CAML_R, value thunk){ */
-/* CAMLparam1(thunk); */
-/* printf("OK-PP(a): %p\n", (void*)thunk); */
-/* //caml_gc_minor_r(ctx, Val_unit); */
-/* //int i; for(i = 0; i < 10; i++) caml_gc_minor_r(ctx, Val_unit); */
-/* caml_gc_compaction_r(ctx, Val_unit); */
-/* printf("OK-PP(b): %p\n", (void*)thunk); */
-/* //CAMLlocal1(new_thunk); */
-/* value new_thunk; // It's important *NOT* to GC-protect this: it belongs to the new context!! */
-/* caml_global_context *new_context = caml_split_context(ctx, &new_thunk, &thunk, 1); */
-
-/* /// KLUDGE: BEGIN */
-/* printf("OK-QQ(b): %p\n", (void*)new_thunk); */
-/* //caml_oldify_one_r (new_context, new_thunk, &new_thunk); */
-/* printf("OK-QQ(b): %p\n", (void*)new_thunk); */
-/* //caml_oldify_mopup_r (new_context); */
-/* printf("OK-QQ(b): %p\n", (void*)new_thunk); */
-/* caml_gc_compaction_r(new_context, Val_unit); */
-/* printf("OK-QQ(b): %p\n", (void*)new_thunk); */
-/* /// KLUDGE: END */
-
-/* printf("OK-PP(c): %p\n", (void*)thunk); */
-/* int fork_result = fork(); */
-/* switch(fork_result){ */
-/* case -1: */
-/* caml_failwith_r(ctx, "fork failed"); */
-/* // FIXME: swap the 0: and default: branches again after debugging */
-/* case 0: /\* child process *\/ */
-/* fprintf(stderr, "[Hello from the child process]\n"); */
-/* // FIXME: handle exceptions */
-/* caml_callback_r(new_context, new_thunk, Val_unit); */
-/* fprintf(stderr, "[The child process is about to exit]\n"); */
-/* exit(EXIT_SUCCESS); */
-/* default: /\* parent process *\/ */
-/* fprintf(stderr, "[Hello from the parent process]\n"); */
-/* break; */
-/* } /\* switch *\/ */
-/* CAMLreturn(caml_value_of_context_descriptor(new_context->descriptor)); */
-/* } */
-
-/* A function with an interface easier to call from OCaml: */
-struct caml_thread_args{
- caml_global_context *context;
- value thunk;
-};
-static void caml_thread_routine_with_reasonable_types_r(CAML_R, value thunk, void *buffer_to_free){
- CAMLparam1(thunk);
- caml_set_thread_local_context(ctx); // FIXME: this is horrible
- //fprintf(stderr, "[From the child thread: the child context is %p]\n", ctx);
- //fprintf(stderr, "[From the child thread: [A] the thunk is %p]\n", (void*)thunk);
- caml_gc_compaction_r(ctx, Val_unit); // !
- //fprintf(stderr, "[From the child thread: [B1] the thunk is %p]\n", (void*)thunk);
- caml_gc_compaction_r(ctx, Val_unit); // !
- //fprintf(stderr, "[From the child thread: [B2] the thunk is %p]\n", (void*)thunk);
- //free(buffer_to_free);
- //fprintf(stderr, "[From the child thread: running the OCaml code]\n");
- // FIXME: handle exceptions
- caml_callback_r(ctx, thunk, Val_unit);
+void caml_split_context_r(CAML_R,
+ caml_global_context **split_contexts,
+ value function,
+ size_t how_many)
+{
+ CAMLparam1(function);
+ CAMLlocal1(open_channels);
+ sem_t semaphore;
+ int init_result = sem_init(&semaphore, /*not process-shared*/0, /*initial value*/0);
+ if(init_result != 0)
+ caml_failwith_r(ctx, "sem_init failed");
+
+ /* Make sure that the currently-existing channels stay alive until
+ after deserialization; we can't keep reference counts within the
+ blob, so we pin all alive channels by keeping this list alive: */
+ open_channels = caml_ml_all_channels_list_r(ctx);
+
+ /* Serialize the context in the main thread, then create threads,
+ and in each one of them deserialize it back in parallel: */
+ char *blob = caml_serialize_context(ctx, function);
+ caml_split_and_destroy_blob_r(ctx, blob, split_contexts, how_many, &semaphore);
+
+ sem_destroy(&semaphore);
+ fprintf(stderr, "Context %p: ]]]]] Still alive after splitting and destroying the blob. Good.\n", ctx);
CAMLreturn0;
}
-static void* caml_thread_routine(void *arg_as_void_star){
- struct caml_thread_args *args = arg_as_void_star;
- fprintf(stderr, "[Hello from the child thread]\n");
- caml_thread_routine_with_reasonable_types_r(args->context, args->thunk, args);
- fprintf(stderr, "[The child thread is about to exit]\n");
- return NULL;
-}
-CAMLprim value caml_context_pthread_create_and_run_thunk_r(CAML_R, value thunk){
- CAMLparam1(thunk);
- value new_thunk; /* don't GC-protect this: it belongs to the new context */
- caml_gc_compaction_r(ctx, Val_unit); // !
- caml_global_context *new_context = caml_split_context(ctx, &new_thunk, &thunk, 1);
- //caml_gc_compaction_r(ctx, Val_unit); // !
- pthread_t thread;
- struct caml_thread_args *thread_args =
- caml_stat_alloc(sizeof(struct caml_thread_args));
- thread_args->context = new_context;
- thread_args->thunk = new_thunk;
- /* fprintf(stderr, "the parent context is %p\n", ctx); */
- /* fprintf(stderr, "the parent thunk is %p\n", (void*)thunk); */
- /* fprintf(stderr, "the child context is %p\n", new_context); */
- /* fprintf(stderr, "the child thunk is %p\n", (void*)new_thunk); */
- int pthread_create_result = pthread_create(&thread, NULL, caml_thread_routine, thread_args);
- if(pthread_create_result != 0)
- caml_failwith_r(ctx, "pthread_create failed");
-
- /* fprintf(stderr, "[Hello from the parent thread]\n"); */
- CAMLreturn(caml_value_of_context_descriptor(new_context->descriptor));
+CAMLprim value caml_context_split_r(CAML_R, value function, value thread_no_as_value)
+{
+ CAMLparam1(function);
+ CAMLlocal1(result);
+ int thread_no = Int_val(thread_no_as_value);
+ caml_global_context **new_contexts = caml_stat_alloc(sizeof(caml_global_context*) * thread_no);
+ caml_split_context_r(ctx, new_contexts, function, thread_no);
+ fprintf(stderr, "Context %p: ]]]] Copying the new context (descriptors) into the Caml data structure result\n", ctx);
+ result = caml_alloc_r(ctx, thread_no, 0);
+ int i;
+ for(i = 0; i < thread_no; i ++)
+ caml_initialize_r(ctx, &Field(result, i), caml_value_of_context_descriptor(new_contexts[i]->descriptor));
+ caml_stat_free(new_contexts);
+ fprintf(stderr, "Context %p: ]]]] Destroyed the malloced buffer of pointers new_contexts. Good.\n", ctx);
+ CAMLreturn(result);
}
-CAMLprim value caml_context_exit_r(CAML_R, value unit){
- printf("The [thread? process?] associated to context %p should now exit\n", ctx);
- while(1)
- sleep(10);
- return Val_unit; /* unreachable */
+CAMLprim value caml_context_join_r(CAML_R, value context_as_value){
+ struct caml_global_context_descriptor *descriptor;
+ int pthread_join_result;
+ CAMLparam1(context_as_value);
+ CAMLlocal1(result);
+ descriptor = caml_global_context_descriptor_of_value(context_as_value);
+
+ //fprintf(stderr, "!!!! ABOUT TO JOIN [descriptor %p]\n", descriptor); fflush(stderr);
+ //fprintf(stderr, "!!!! ABOUT TO JOIN [kind %i]\n", descriptor->kind); fflush(stderr);
+ if(descriptor->kind == caml_global_context_main)
+ caml_failwith_r(ctx, "caml_context_join_r: main context");
+ else if(descriptor->kind == caml_global_context_remote)
+ caml_failwith_r(ctx, "caml_context_join_r: remote context");
+ Assert(descriptor->kind == caml_global_context_nonmain_local);
+ //fprintf(stderr, "!!!! JOINING %p\n", (void*)descriptor->content.local_context.context->thread); fflush(stderr);
+ pthread_join_result = pthread_join(descriptor->content.local_context.context->thread, NULL);
+ if(pthread_join_result != 0)
+ caml_failwith_r(ctx, "caml_context_join_r: pthread_join failed");
+ CAMLreturn(Val_unit);
}
View
58 byterun/context_split.h
@@ -4,14 +4,54 @@
#include "context.h"
-/* Clone a given context and the given set of caml values potentially
- referring it; return the new context, and store the cloned values
- potentially referring the new context at the given address.
- Sharing among such values, or between values and global data
- structures, is reproduced. */
-caml_global_context* caml_split_context(caml_global_context *ctx,
- value *to_values,
- value *from_values,
- size_t value_no);
+/* // FIXME: remove this */
+/* /\* Clone a given context and the given set of caml values potentially */
+/* referring it; return the new context, and store the cloned values */
+/* potentially referring the new context at the given address. */
+/* Sharing among such values, or between values and global data */
+/* structures, is reproduced. *\/ */
+/* caml_global_context* caml_split_context(caml_global_context *ctx, */
+/* value *to_values, */
+/* value *from_values, */
+/* size_t value_no); */
+/* // FIXME: remove this */
+
+// FIXME: remove from the header. This should not be public
+typedef struct caml_context_blob* caml_context_blob_t;
+
+// FIXME:
+/* Split the given context into how_many copies. Each one is
+ associated to a different new thread. For each thread the given
+ int -> unit function with an index from 0 to how_many - 1. Store
+ new context pointers into split_contexts. When the function returns,
+ all the new contexts have been initialized. */
+void caml_split_context_r(CAML_R,
+ caml_global_context **split_contexts,
+ value function,
+ size_t how_many);
+
+/* // FIXME: remove from the header. This should not be public */
+/* /\* Given a context and an int -> unit function (from that context) to */
+/* be executed in a new context split from the given one, return a */
+/* serialized blob. The returned blob is allocated with malloc, and */
+/* can be destroyed with free. *\/ */
+/* char* caml_serialize_context_r(CAML_R, value function); */
+
+/* // FIXME: remove from the header. This should not be public */
+/* /\* Given a serialized blob, split its context content into the given */
+/* number of contexts, each in a distinct new thread. Run the */
+/* function from the blob in each context with a zero-based index as a */
+/* parameter. Store pointers to the the created contexts where */
+/* requested. De-allocate the blob on return. *\/ */
+/* void caml_split_serialized_context_r(CAML_R, */
+/* char *blob, */
+/* caml_global_context **split_contexts, */
+/* size_t how_many); */
+
+/* // FIXME: remove from the header. This should not be public */
+/* /\* Deserialize the given blob in the current thread, obtaining a */
+/* context and an int->unit function in that context. Call the */
+/* function with the given index. *\/ */
+/* void caml_deserialize_and_run_in_this_thread(char *blob, int index); */
#endif /* #ifndef CAML_CONTEXT_SPLIT_H */
View
18 byterun/extensible_buffer.c
@@ -12,10 +12,8 @@ static void caml_reallocate_extensible_buffer(struct caml_extensible_buffer *b,
b->array = caml_stat_resize(b->array, new_allocated_size);
b->allocated_size = (long)new_allocated_size;
- /* /\* If we're growing the array, initialize the new part: *\/ */
- /* if(new_allocated_size > old_allocated_size) */
- /* memset(((char*)b->array) + old_allocated_size, initial_value, new_allocated_size - old_allocated_size); */
- //fprintf(stderr, "The extensible buffer at %p has now allocated-size = %i bytes (%i words)\n", b, (int)new_allocated_size, (int)(new_allocated_size / sizeof(void*)));
+ /* We leave the new part, if any, uninitialized. We're going to
+ initialize it when the space is actually used. */
}
static void caml_reallocate_extensible_buffer_if_needed(struct caml_extensible_buffer *b, size_t new_used_size){
@@ -34,8 +32,10 @@ void caml_resize_extensible_buffer(struct caml_extensible_buffer *b,
//fprintf(stderr, "JJ [2]\n");
/* Update the used size and initialize the newly-used part, if any: */
- if(b->used_size < new_used_size)
+ if(new_used_size > b->used_size){
memset(((char*)b->array) + b->used_size, initial_value, new_used_size - b->used_size);
+ //fprintf(stderr, "+++++++++++++Initialized with %i from %i to %i\n", initial_value, b->used_size, new_used_size - 1);
+ }
b->used_size = new_used_size;
}
@@ -49,7 +49,13 @@ size_t caml_allocate_from_extensible_buffer(struct caml_extensible_buffer *b,
//while((beginning_of_this_element + new_element_size) > b->allocated_size)
// caml_reallocate_extensible_buffer(b, b->allocated_size * 2 + 1, initial_value);
- b->used_size += new_element_size;
+ /* Fill the newly-allocated part: */
+ long new_used_size = b->used_size + new_element_size;
+ memset(((char*)b->array) + b->used_size, initial_value, new_used_size - b->used_size);
+ //fprintf(stderr, "+++++++++++++Initialized with %i from %i to %i\n", initial_value, b->used_size, new_used_size - 1);
+
+ b->used_size = new_used_size;
+
//printf("%p->used_size is now %i bytes (%i words)\n", (int)b->used_size, (((int)(b->used_size)) / sizeof(void*)));
return beginning_of_this_element;
}
View
12 byterun/gc_ctrl.c
@@ -444,10 +444,20 @@ CAMLprim value caml_gc_major_slice_r (CAML_R, value v)
CAMLprim value caml_gc_compaction_r(CAML_R, value v)
{ Assert (v == Val_unit);
+// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! EXPERIMENTAL: BEGIN
+ //caml_empty_minor_heap_r (ctx);
+ //caml_finish_major_cycle_r (ctx);
+ //caml_final_do_calls_r (ctx);
+ //caml_empty_minor_heap_r (ctx);
+ //caml_finish_major_cycle_r (ctx);
+ //caml_compact_heap_r (ctx);
+ //caml_final_do_calls_r (ctx);
+ return Val_unit;
+// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! EXPERIMENTAL: END
caml_gc_message (0x10, "Heap compaction requested\n", 0);
caml_empty_minor_heap_r (ctx);
caml_finish_major_cycle_r (ctx);
- caml_final_do_calls_r (ctx); // FIXME: is this a mistake introduced in the new OCaml versions? This call wasn't here in 3.12.0. REENTRANTRUNTIME
+ caml_final_do_calls_r (ctx);
caml_empty_minor_heap_r (ctx);
caml_finish_major_cycle_r (ctx);
caml_compact_heap_r (ctx);
View
125 byterun/io.c
@@ -44,13 +44,33 @@
#define SEEK_END 2
#endif
+// HORRIBLE KLUDGE
+#define fprintf(...)
+#define fflush(...)
+
/* Hooks for locking channels */
+/// Ugly and experimental: BEGIN --Luca Saiu REENTRANTRUNTIME
+static void caml_my_lock_channel(struct channel *currently_unused){
+ //fprintf(stderr, "io.c: [+] Locking %p\n", currently_unused);
+ caml_acquire_global_lock();
+}
+static void caml_my_unlock_channel(struct channel *currently_unused){
+ //fprintf(stderr, "io.c: [-] UNlocking %p\n", currently_unused);
+ caml_release_global_lock();
+}
+/// Ugly and experimental: END --Luca Saiu REENTRANTRUNTIME
+
+
CAMLexport void (*caml_channel_mutex_free) (struct channel *) = NULL;
-CAMLexport void (*caml_channel_mutex_lock) (struct channel *) = NULL;
-CAMLexport void (*caml_channel_mutex_unlock) (struct channel *) = NULL;
+CAMLexport void (*caml_channel_mutex_lock) (struct channel *) = caml_my_lock_channel;//NULL;
+CAMLexport void (*caml_channel_mutex_unlock) (struct channel *) = caml_my_unlock_channel;//NULL;
CAMLexport void (*caml_channel_mutex_unlock_exn) (void) = NULL;
+// FIXME: this should most likely remain global, but I have to
+// actually think about the issues introduced by sharing struct
+// channel pointers among contexts. Are we sure it doesn't screw up
+// anything? --Luca Saiu REENTRANTRUNTIME
/* List of opened channels */
CAMLexport struct channel * caml_all_opened_channels = NULL;
@@ -76,11 +96,14 @@ CAMLexport struct channel * caml_open_descriptor_in_r(CAML_R, int fd)
channel->old_revealed = 0;
channel->refcount = 0;
channel->flags = 0;
+caml_acquire_global_lock();
channel->next = caml_all_opened_channels;
channel->prev = NULL;
+ channel->already_closed = 0;
if (caml_all_opened_channels != NULL)
caml_all_opened_channels->prev = channel;
caml_all_opened_channels = channel;
+caml_release_global_lock();
return channel;
}
@@ -95,6 +118,7 @@ CAMLexport struct channel * caml_open_descriptor_out_r(CAML_R, int fd)
static void unlink_channel(struct channel *channel)
{
+caml_acquire_global_lock();
if (channel->prev == NULL) {
Assert (channel == caml_all_opened_channels);
caml_all_opened_channels = caml_all_opened_channels->next;
@@ -104,6 +128,7 @@ static void unlink_channel(struct channel *channel)
channel->prev->next = channel->next;
if (channel->next != NULL) channel->next->prev = channel->prev;
}
+caml_release_global_lock();
}
CAMLexport void caml_close_channel(struct channel *channel)
@@ -111,9 +136,11 @@ CAMLexport void caml_close_channel(struct channel *channel)
INIT_CAML_R;
int greater_than_zero;
close(channel->fd);
- caml_acquire_global_lock_r(ctx);
+ caml_acquire_global_lock();
greater_than_zero = channel->refcount > 0;
- caml_release_global_lock_r(ctx);
+ fprintf(stderr, "Context %p: Closing the channel with struct channel* %p, fd %i: its refcount is now %i\n", ctx, channel, channel->fd, (int)channel->refcount);
+ channel->already_closed = 1;
+ caml_release_global_lock();
if (greater_than_zero)
return;
if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(channel);
@@ -192,10 +219,19 @@ static int do_write_r(CAML_R, int fd, char *p, int n)
end of the flush, or false if some data remains in the buffer.
*/
+
CAMLexport int caml_flush_partial_r(CAML_R, struct channel *channel)
{
+caml_acquire_global_lock();
int towrite, written;
+ Lock(channel);
+ if(channel->already_closed){
+ Unlock(channel);
+caml_release_global_lock();
+ return 1;
+ }
+ Unlock(channel);
towrite = channel->curr - channel->buff;
if (towrite > 0) {
written = do_write_r(ctx, channel->fd, channel->buff, towrite);
@@ -204,13 +240,21 @@ CAMLexport int caml_flush_partial_r(CAML_R, struct channel *channel)
memmove(channel->buff, channel->buff + written, towrite - written);
channel->curr -= written;
}
- return (channel->curr == channel->buff);
+caml_release_global_lock();
+ int result = (channel->curr == channel->buff);
+ return result;
}
/* Flush completely the buffer. */
CAMLexport void caml_flush_r(CAML_R, struct channel *channel)
{
+ Lock(channel);
+ if(channel->already_closed){
+ Unlock(channel);
+ return;
+ }
+ Unlock(channel);
while (! caml_flush_partial_r(ctx, channel)) /*nothing*/;
}
@@ -435,11 +479,13 @@ CAMLexport void caml_finalize_channel(value vchan)
struct channel * chan = Channel(vchan);
int greater_than_zero;
INIT_CAML_R;
- caml_acquire_global_lock_r(ctx);
+caml_acquire_global_lock();
greater_than_zero = --chan->refcount > 0;
- caml_release_global_lock_r(ctx);
+ fprintf(stderr, "Context %p: finalizing the channel with struct channel* %p, fd %i: its refcount is now %i\n", ctx, chan, chan->fd, chan->refcount);
+caml_release_global_lock();
if (greater_than_zero)
return;
+ fprintf(stderr, "Context %p: destroying the channel with struct channel* %p, fd %i\n", ctx, chan, chan->fd);
if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(chan);
unlink_channel(chan);
caml_stat_free(chan);
@@ -466,10 +512,13 @@ static void cross_context_serialize_channel(value v,
CAMLparam1(v);
/* The channel is used by one more context. Pin it: */
struct channel *pointer = Channel(v);
- caml_acquire_global_lock_r(ctx);
- pointer->refcount ++;
- caml_release_global_lock_r(ctx);
- //fprintf(stderr, "Serializing the channel at %p, which is to say %li\n", pointer, (long)pointer);
+ /* // FIXME: don't leak channels like this: BEGIN --Luca Saiu REENTRANTRUNTIME */
+ /* caml_acquire_global_lock(); */
+ /* pointer->refcount ++; */
+ /* fprintf(stderr, "Cross-context-serializing the channel with struct channel* %p, fd %i: its refcount is now %i\n", pointer, pointer->fd, pointer->refcount); */
+ /* caml_release_global_lock(); */
+ /* // FIXME: don't leak channels like this: END --Luca Saiu REENTRANTRUNTIME */
+ //fprintf(stderr, "Serializing the channel at %p, fd %i, which is to say %li\n", pointer, pointer->fd, (long)pointer);
/* The data part is just the struct channel* pointer. */
*wsize_32 = 4;
@@ -481,7 +530,7 @@ static void cross_context_serialize_channel(value v,
//fprintf(stderr, "Serialized the 4-byte integer %li\n", (long)pointer);
caml_serialize_int_4_r(ctx, (int32)pointer);
#endif // #else // #ifdef ARCH_SIXTYFOUR
- //fprintf(stderr, "Serializing the channel at %p: still alive at the end\n", pointer);
+ //fprintf(stderr, "Serializing the channel at %p, fd %i: still alive at the end\n", pointer, pointer->fd);
CAMLreturn0;
}
static uintnat cross_context_deserialize_channel(void * dst){
@@ -494,21 +543,17 @@ static uintnat cross_context_deserialize_channel(void * dst){
#else
(void*)caml_deserialize_uint_4_r(ctx);
#endif // #else // #ifdef ARCH_SIXTYFOUR
- //fprintf(stderr, "Deserializing the channel at %p\n", pointer);
-
- /* Copy the pointer into the custom object payload, as its only
- word. Notice that we don't unpin the channel structure, since
- this new object we're creating refers it. Of course we are
- assuming that deserialization occurs only once, but that is
- reasonable in the cross-context case. */
+ //fprintf(stderr, "Deserializing the channel at %p, fd %i\n", pointer, pointer->fd);
+
+ /* Copy the pointer into the custom object payload as its only
+ word, and pin it: */
*((struct channel**)dst) = pointer;
-
- /* /\* Now Unpin the channel structure: *\/ */
- /* caml_acquire_global_lock_r(ctx); */
- /* pointer->refcount --; */
- /* caml_release_global_lock_r(ctx); */
-
- //fprintf(stderr, "Deserializing the channel at %p: still alive at the end\n", pointer);
+ caml_acquire_global_lock();
+ pointer->refcount ++;
+ fprintf(stderr, "Cross-context-deserializing the channel with struct channel* %p, fd %i: its refcount is now %i\n", pointer, pointer->fd, pointer->refcount);
+ caml_release_global_lock();
+
+ //fprintf(stderr, "Deserializing the channel at %p, fd %i: still alive at the end\n", pointer, pointer->fd);
//fprintf(stderr, "cross_context_deserialize_channel: FIXME: implement\n");
/* The payload is one word: */
return sizeof(void*);
@@ -529,9 +574,10 @@ struct custom_operations caml_channel_operations = {
CAMLexport value caml_alloc_channel_r(CAML_R, struct channel *chan)
{
value res;
- caml_acquire_global_lock_r(ctx);
+ caml_acquire_global_lock();
chan->refcount++; /* prevent finalization during next alloc */
- caml_release_global_lock_r(ctx);
+ fprintf(stderr, "Context %p: allocating the channel with struct channel* %p, fd %i: its refcount is now %i\n", ctx, chan, chan->fd, chan->refcount);
+ caml_release_global_lock();
res = caml_alloc_custom(&caml_channel_operations, sizeof(struct channel *),
1, 1000);
@@ -551,7 +597,7 @@ CAMLprim value caml_ml_open_descriptor_out_r(CAML_R, value fd)
#define Pair_tag 0
-CAMLprim value caml_ml_out_channels_list_r (CAML_R, value unit)
+static value caml_ml_channels_list_r (CAML_R, const int output_only)
{
CAMLparam0 ();
CAMLlocal3 (res, tail, chan);
@@ -560,19 +606,31 @@ CAMLprim value caml_ml_out_channels_list_r (CAML_R, value unit)
res = Val_emptylist;
for (channel = caml_all_opened_channels;
channel != NULL;
- channel = channel->next)
+ channel = channel->next){
+ //fprintf(stderr, "* caml_ml_out_channels_list_r: channel %p, fd %i, refcount %i, channel->max %p\n", channel, channel->fd, channel->refcount, channel->max);
/* Testing channel->fd >= 0 looks unnecessary, as
caml_ml_close_channel changes max when setting fd to -1. */
- if (channel->max == NULL) {
+ if ((channel->max == NULL) || ! output_only) {
chan = caml_alloc_channel_r (ctx, channel);
tail = res;
res = caml_alloc_small_r (ctx, 2, Pair_tag);
Field (res, 0) = chan;
Field (res, 1) = tail;
}
+ }
CAMLreturn (res);
}
+value caml_ml_all_channels_list_r (CAML_R)
+{
+ return caml_ml_channels_list_r(ctx, 0);
+}
+
+CAMLprim value caml_ml_out_channels_list_r (CAML_R, value unit)
+{
+ return caml_ml_channels_list_r(ctx, 1);
+}
+
CAMLprim value caml_channel_descriptor_r(CAML_R, value vchannel)
{
int fd = Channel(vchannel)->fd;
@@ -590,6 +648,7 @@ CAMLprim value caml_ml_close_channel_r(CAML_R, value vchannel)
struct channel * channel = Channel(vchannel);
if (channel->fd != -1){
fd = channel->fd;
+ fprintf(stderr, "Context %p: closing the channel with struct channel* %p, fd %i [now -1]: its refcount is %i\n", ctx, channel, channel->fd, channel->refcount);
channel->fd = -1;
do_syscall = 1;
}else{
@@ -668,9 +727,13 @@ CAMLprim value caml_ml_flush_r(CAML_R, value vchannel)
struct channel * channel = Channel(vchannel);
if (channel->fd == -1) CAMLreturn(Val_unit);
+ //fprintf(stderr, "caml_ml_flush_r: OK1 from thread %p\n", pthread_self());
Lock(channel);
+ //fprintf(stderr, "caml_ml_flush_r: OK2 from thread %p\n", pthread_self());
caml_flush_r(ctx, channel);
+ //fprintf(stderr, "caml_ml_flush_r: OK3 from thread %p\n", pthread_self());
Unlock(channel);
+ //fprintf(stderr, "caml_ml_flush_r: OK4 from thread %p\n", pthread_self());
CAMLreturn (Val_unit);
}
View
5 byterun/io.h
@@ -49,6 +49,7 @@ struct channel {
int refcount; /* For flush_all and for Cash */
int flags; /* Bitfield */
char buff[IO_BUFFER_SIZE]; /* The buffer itself */
+ int already_closed; /* Horrible kludge, to avoid flushing already-closed buffers at exit time --Luca Saiu REENTRANTRUNTIME */
};
enum {
@@ -125,4 +126,8 @@ CAMLextern file_offset caml_File_offset_val(value v);
#define File_offset_val caml_File_offset_val
#endif
+/* Return a freshly-allocated list holding all existing channels in some order;
+ if output_only is nonzero, only include channels open in output mode. */
+value caml_ml_all_channels_list_r (CAML_R);
+
#endif /* CAML_IO_H */
View
15 byterun/startup.c
@@ -342,7 +342,7 @@ extern void caml_init_ieee_floats (void);
extern void caml_signal_thread(void * lpParam);
#endif
-extern __thread caml_global_context *caml_context; // in context.c
+//extern __thread caml_global_context *caml_context; // in context.c // FIXME: remove: it's now a thread-local static
/* FIXME: refactor: call this from caml_main_rr --Luca Saiu REENTRANTRUNTIME */
caml_global_context* caml_make_empty_context(void)
@@ -350,9 +350,12 @@ caml_global_context* caml_make_empty_context(void)
// FIXME: lock
/* Make a new context in which to unmarshal back the byte array back
into a big data structure, copying whatever's needed: */
- caml_global_context *old_thread_local_context = caml_context;
+ //caml_acquire_global_lock(); // FIXME: is this critical section needed?
+ //caml_global_context *old_thread_local_context = caml_get_thread_local_context();
caml_global_context *ctx = caml_initialize_first_global_context();
- caml_context = old_thread_local_context; // undo caml_initialize_first_global_context's trashing of the __thread variable
+ ctx->descriptor->kind = caml_global_context_nonmain_local;
+ //caml_set_thread_local_context(old_thread_local_context); // undo caml_initialize_first_global_context's trashing of the __thread variable
+ //caml_release_global_lock();
// FIXME: unlock
/* Initialize the abstract machine */
@@ -364,6 +367,10 @@ caml_global_context* caml_make_empty_context(void)
caml_interprete_r(ctx, NULL, 0);
/* Initialize the debugger, if needed */
caml_debugger_init_r(ctx);
+
+ /* Make the new context be the thread-local context for this thread: */
+ caml_set_thread_local_context(ctx);
+
return ctx;
}
@@ -381,6 +388,7 @@ CAMLexport caml_global_context* caml_main_rr(char **argv)
static char proc_self_exe[256];
#endif
+ caml_context_initialize_global_stuff();
CAML_R = caml_initialize_first_global_context();
/* Machine-dependent initialization of the floating-point hardware
@@ -489,6 +497,7 @@ CAMLexport void caml_startup_code(
static char proc_self_exe[256];
#endif
+ caml_context_initialize_global_stuff();
CAML_R = caml_initialize_first_global_context();
caml_init_ieee_floats();
View
2 byterun/startup.h
@@ -19,6 +19,8 @@
#include "mlvalues.h"
#include "exec.h"
+/* Return a new empty context, and make it "the" thread-local current context.
+ Its descriptor says that its kins is non-main local, but that can be changed. */
caml_global_context* caml_make_empty_context(void);
/* CAMLextern void caml_main(char **argv); */
View
1 myocamlbuild_config.ml
@@ -47,7 +47,6 @@ let aspp = "gcc -c";;
let asppprofflags = "-DPROFILING";;
let profiling = "prof";;
let dynlinkopts = " -ldl";;
-(* #OTHERLIBRARIES=unix str num dynlink bigarray systhreads threads graph *)
let otherlibraries = "unix str num dynlink bigarray";;
let debugger = "ocamldebugger";;
let cc_profile = "-pg";;
View
53 stdlib/context.ml
@@ -4,39 +4,19 @@
type t =
int
-(* type fork_result = *)
-(* | NewContext of t *)
-(* | OldContext *)
-
-(* let fork () = failwith "unimplemented" *)
-(* let exit () = failwith "unimplemented" *)
-
external self : unit -> t = "caml_context_self_r" "reentrant"
external is_main : t -> bool = "caml_context_is_main_r" "reentrant"
external is_remote : t -> bool = "caml_context_is_remote_r" "reentrant"
-(* let fork () = *)
-(* let returned_context = fork_low_level () in *)
-(* if returned_context = (self ()) then *)
-(* OldContext *)
-(* else *)
-(* NewContext returned_context *)
-
-(* let rec fork_many n f = *)
-(* if n < 0 then *)
-(* (failwith "fork_many: negative argument"); *)
-(* if n > 0 then *)
-(* match fork () with *)
-(* | NewContext _ -> *)
-(* f (n - 1) *)
-(* | OldContext -> *)
-(* fork_many (n - 1) f *)
-
-(* let fork thunk = *)
-(* failwith "unimplemented" *)
-external fork : (unit -> unit) -> t = "caml_context_fork_and_run_thunk_r" "reentrant"
-external pthread_create : (unit -> unit) -> t = "caml_context_pthread_create_and_run_thunk_r" "reentrant"
+external split_into_array : (int -> unit) -> int -> (t array) = "caml_context_split_r" "reentrant"
+
+let split f how_many =
+ Array.to_list (split_into_array f how_many)
+(* FIXME: remove *)
+(* external pthread_create : (int -> unit) -> t = "caml_context_pthread_create_and_run_thunk_r" "reentrant" *)
+let split1 thunk =
+ List.hd (split (fun i -> thunk ()) 1)
(* (iota n) returns the int list [0, n). The name comes from APL, and
has also been adopted by Guile Scheme. *)
@@ -48,11 +28,11 @@ let rec iota_acc n a =
let iota n =
iota_acc (n - 1) []
-let fork_many n f =
- List.map
- (fun i ->
- fork (fun () -> f i))
- (iota n);;
+(* let fork_many n f = *)
+(* List.map *)
+(* (fun i -> *)
+(* fork (fun () -> f i)) *)
+(* (iota n);; *)
(* let rec apply_functions functions list = *)
(* match list, functions with *)
@@ -73,7 +53,7 @@ let fork_many n f =
(* done; *)
(* !results *)
-external exit : unit -> unit = "caml_context_exit_r" "reentrant"
+(* external exit : unit -> unit = "caml_context_exit_r" "reentrant" *)
let send message receiver_context = failwith "unimplemented"
let receive receiver_context = failwith "unimplemented"
@@ -93,4 +73,7 @@ let rec global_index_from global globals from =
let global_index global =
global_index_from global (globals ()) 0;;
-(* external dump : unit -> int = "caml_context_dump_r" "reentrant" *)
+external join1 : t -> unit = "caml_context_join_r" "reentrant"
+
+let join contexts =
+ List.iter join1 contexts
View
18 stdlib/context.mli
@@ -2,27 +2,21 @@
type t
-(* type fork_result = *)
-(* | NewContext of t *)
-(* | OldContext *)
-
-(* val fork : unit -> fork_result *)
-
-(* (\* Make a new context in which the given function will be exectuted, *)
-(* within a new process. Return the new context. *\) *)
-(* val fork : (unit -> unit) -> t *)
+val split : (int -> unit) -> int -> (t list)
+val join : t list -> unit
(* Make a new context in which the given function will be exectuted,
within a new thread. Return the new context. *)
-val pthread_create : (unit -> unit) -> t
+val split1 : (unit -> unit) -> t
+val join1 : t -> unit
(* (\* Start as many contexts as the given integer, running the given *)
(* function in each one. Each function takes a 0-based index as its *)
(* parameter. Return the new contexts. *\) *)
(* val fork_many : int -> (int -> unit) -> (t list) *)
-(* Exit the process, killing the current context. *)
-val exit : unit -> unit
+(* (\* Exit the process, killing the current context. *\) *)
+(* val exit : unit -> unit *)
val self : unit -> t
val is_main : t -> bool
View
5 stdlib/pervasives.ml
@@ -446,7 +446,10 @@ let at_exit f =
let g = !exit_function in
exit_function := (fun () -> f(); g())
-let do_at_exit () = (!exit_function) ()
+(* (\* Unchanged code: *\) *)
+(* let do_at_exit () = (!exit_function) () *)
+
+let do_at_exit () = prerr_string "do_at_exit: begin\n"; (!exit_function) (); prerr_string "do_at_exit: still alive\n"
let exit retcode =
do_at_exit ();
View
1 tools/myocamlbuild_config.ml
@@ -47,7 +47,6 @@ let aspp = "gcc -c";;
let asppprofflags = "-DPROFILING";;
let profiling = "prof";;
let dynlinkopts = " -ldl";;
-(* #OTHERLIBRARIES=unix str num dynlink bigarray systhreads threads graph *)
let otherlibraries = "unix str num dynlink bigarray";;
let debugger = "ocamldebugger";;
let cc_profile = "-pg";;

0 comments on commit 2a2a02f

Please sign in to comment.
Something went wrong with that request. Please try again.