Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Important fixes: the multi-context support now works on the bytecode …

…interpeter
  • Loading branch information...
commit 24414000b794d88100fbefead92947ae5f4d7996 1 parent e9dcb68
Luca Saiu authored
Showing with 220 additions and 68 deletions.
  1. +2 −0  README.md
  2. BIN  boot/arg.cmi
  3. BIN  boot/array.cmi
  4. BIN  boot/arrayLabels.cmi
  5. BIN  boot/buffer.cmi
  6. BIN  boot/callback.cmi
  7. BIN  boot/camlinternalLazy.cmi
  8. BIN  boot/camlinternalMod.cmi
  9. BIN  boot/camlinternalOO.cmi
  10. BIN  boot/char.cmi
  11. BIN  boot/complex.cmi
  12. BIN  boot/context.cmi
  13. BIN  boot/digest.cmi
  14. BIN  boot/filename.cmi
  15. BIN  boot/format.cmi
  16. BIN  boot/gc.cmi
  17. BIN  boot/genlex.cmi
  18. BIN  boot/hashtbl.cmi
  19. BIN  boot/int32.cmi
  20. BIN  boot/int64.cmi
  21. BIN  boot/lazy.cmi
  22. BIN  boot/lexing.cmi
  23. BIN  boot/list.cmi
  24. BIN  boot/listLabels.cmi
  25. BIN  boot/map.cmi
  26. BIN  boot/marshal.cmi
  27. BIN  boot/moreLabels.cmi
  28. BIN  boot/myocamlbuild
  29. BIN  boot/nativeint.cmi
  30. BIN  boot/obj.cmi
  31. BIN  boot/ocamlrun
  32. BIN  boot/oo.cmi
  33. BIN  boot/parsing.cmi
  34. BIN  boot/pervasives.cmi
  35. BIN  boot/printexc.cmi
  36. BIN  boot/printf.cmi
  37. BIN  boot/queue.cmi
  38. BIN  boot/random.cmi
  39. BIN  boot/scanf.cmi
  40. BIN  boot/set.cmi
  41. BIN  boot/sort.cmi
  42. BIN  boot/stack.cmi
  43. BIN  boot/stdLabels.cmi
  44. BIN  boot/std_exit.cmi
  45. BIN  boot/std_exit.cmo
  46. BIN  boot/stdlib.cma
  47. BIN  boot/stream.cmi
  48. BIN  boot/string.cmi
  49. BIN  boot/stringLabels.cmi
  50. BIN  boot/sys.cmi
  51. BIN  boot/weak.cmi
  52. +2 −4 byterun/context.c
  53. +7 −1 byterun/context.h
  54. +94 −40 byterun/context_split.c
  55. +28 −7 byterun/extern.c
  56. +1 −0  byterun/fix_code.c
  57. +22 −1 byterun/intern.c
  58. +19 −0 byterun/interp.c
  59. +4 −0 byterun/major_gc.c
  60. +2 −0  byterun/memory.c
  61. +4 −0 byterun/minor_gc.c
  62. +2 −2 byterun/startup.c
  63. +11 −7 otherlibs/systhreads/st_stubs.c
  64. +5 −4 stdlib/context.ml
  65. +13 −2 stdlib/context.mli
  66. +2 −0  stdlib/pervasives.ml
  67. +2 −0  stdlib/pervasives.mli
2  README.md
View
@@ -27,6 +27,8 @@ Status
the context as first parameter.
* The AMD64 backend of ocamlopt has been updated to use the runtime context and
provide it to reentrant external functions.
+* The bytecode interpreter now also uses the context data structure, and can be used
+ for parallel programming.
* C functions in unix, str, bigarray have been updated, static variables have been moved
into library specific contexts.
* Globals generated by ocamlopt are now local to each runtime
BIN  boot/arg.cmi
View
Binary file not shown
BIN  boot/array.cmi
View
Binary file not shown
BIN  boot/arrayLabels.cmi
View
Binary file not shown
BIN  boot/buffer.cmi
View
Binary file not shown
BIN  boot/callback.cmi
View
Binary file not shown
BIN  boot/camlinternalLazy.cmi
View
Binary file not shown
BIN  boot/camlinternalMod.cmi
View
Binary file not shown
BIN  boot/camlinternalOO.cmi
View
Binary file not shown
BIN  boot/char.cmi
View
Binary file not shown
BIN  boot/complex.cmi
View
Binary file not shown
BIN  boot/context.cmi
View
Binary file not shown
BIN  boot/digest.cmi
View
Binary file not shown
BIN  boot/filename.cmi
View
Binary file not shown
BIN  boot/format.cmi
View
Binary file not shown
BIN  boot/gc.cmi
View
Binary file not shown
BIN  boot/genlex.cmi
View
Binary file not shown
BIN  boot/hashtbl.cmi
View
Binary file not shown
BIN  boot/int32.cmi
View
Binary file not shown
BIN  boot/int64.cmi
View
Binary file not shown
BIN  boot/lazy.cmi
View
Binary file not shown
BIN  boot/lexing.cmi
View
Binary file not shown
BIN  boot/list.cmi
View
Binary file not shown
BIN  boot/listLabels.cmi
View
Binary file not shown
BIN  boot/map.cmi
View
Binary file not shown
BIN  boot/marshal.cmi
View
Binary file not shown
BIN  boot/moreLabels.cmi
View
Binary file not shown
BIN  boot/myocamlbuild
View
Binary file not shown
BIN  boot/nativeint.cmi
View
Binary file not shown
BIN  boot/obj.cmi
View
Binary file not shown
BIN  boot/ocamlrun
View
Binary file not shown
BIN  boot/oo.cmi
View
Binary file not shown
BIN  boot/parsing.cmi
View
Binary file not shown
BIN  boot/pervasives.cmi
View
Binary file not shown
BIN  boot/printexc.cmi
View
Binary file not shown
BIN  boot/printf.cmi
View
Binary file not shown
BIN  boot/queue.cmi
View
Binary file not shown
BIN  boot/random.cmi
View
Binary file not shown
BIN  boot/scanf.cmi
View
Binary file not shown
BIN  boot/set.cmi
View
Binary file not shown
BIN  boot/sort.cmi
View
Binary file not shown
BIN  boot/stack.cmi
View
Binary file not shown
BIN  boot/stdLabels.cmi
View
Binary file not shown
BIN  boot/std_exit.cmi
View
Binary file not shown
BIN  boot/std_exit.cmo
View
Binary file not shown
BIN  boot/stdlib.cma
View
Binary file not shown
BIN  boot/stream.cmi
View
Binary file not shown
BIN  boot/string.cmi
View
Binary file not shown
BIN  boot/stringLabels.cmi
View
Binary file not shown
BIN  boot/sys.cmi
View
Binary file not shown
BIN  boot/weak.cmi
View
Binary file not shown
6 byterun/context.c
View
@@ -801,9 +801,8 @@ void caml_acquire_global_lock(void){
//int old_owner = caml_global_mutex.__data.__owner;
int result __attribute__((unused));
INIT_CAML_R;
- //caml_enter_blocking_section_r(ctx);
+ //DUMP("lock");
result = pthread_mutex_lock(&caml_global_mutex);
- //caml_leave_blocking_section_r(ctx);
/////BEGIN
if(result){
DUMP("thread_mutex_lock failed");
@@ -817,9 +816,8 @@ 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);
+ //DUMP("unlock");
Assert(result == 0);
/////BEGIN
if(result){
8 byterun/context.h
View
@@ -1059,7 +1059,7 @@ void caml_finalize_semaphore(sem_t *semaphore);
#define DUMP(FORMAT, ...) \
do{ \
fprintf(stderr, \
- "%s:%i(" RED "%s" NOATTR ") C%p T" CYAN "%p "/* "AP" PURPLE"%p"NOATTR"/"PURPLE"%p" */NOATTR" ", \
+ "%s:%i(" RED "%s" NOATTR ") C%p T" CYAN "%p"/* " AP" PURPLE"%p"NOATTR"/"PURPLE"%p" */NOATTR" ", \
__FILE__, __LINE__, __FUNCTION__, ctx, \
(void*)pthread_self()); \
fflush(stderr); \
@@ -1127,6 +1127,12 @@ extern __thread int caml_indentation_level;
#define QR(FORMAT, ...) /* nothing */
#define QBR(FORMAT, ...) /* nothing */
+#define DUMPUNLESSMAIN(FORMAT, ...) \
+ do{ \
+ if(ctx->descriptor->kind != caml_global_context_main) \
+ DUMP(FORMAT, ##__VA_ARGS__); \
+ } while(0)
+
/* int caml_get_thread_no_r(CAML_R); */
/* void caml_set_caml_get_thread_no_r(CAML_R, int (*f)(CAML_R)); */
134 byterun/context_split.c
View
@@ -16,6 +16,7 @@
#include "callback.h" // for caml_callback_r and friends
#include "alloc.h"
#include "intext.h"
+#include "fix_code.h"
#include "printexc.h" // FIXME: remove after debugging, if possible
#include "gc_ctrl.h" // FIXME: remove after debugging, if possible
@@ -103,17 +104,16 @@ static value caml_pair_r(CAML_R, value left, value right)
CAMLreturn(result);
}
-/* Return a Caml tuple containing all the globals of the given context. The
- result should not be modified as it may share structure with the context
- globals. */
-value caml_global_tuple_r(CAML_R)
+/* Return a Caml tuple/array containing all the globals of the given
+ context. The result should not be modified as it may share
+ structure with the context globals. The result may be invalidated
+ by loading more caml compilation units. */
+CAMLprim value caml_global_array_r(CAML_R, value unit)
{
CAMLparam0();
- CAMLlocal1(globals);
#ifdef NATIVE_CODE
+ CAMLlocal1(globals);
const int global_no = ctx->caml_globals.used_size / sizeof(value);
- /* This is the only allocation, and no Caml locals are alive at this
- point: no need fot GC protection: */
globals = caml_alloc_tuple_r(ctx, global_no);
int i;
for(i = 0; i < global_no; i ++){
@@ -129,7 +129,7 @@ value caml_global_tuple_r(CAML_R)
#else /* bytecode */
/* No need for GC-protection: there is no allocation here. */
// FIXME: for debugging only. Remove: BEGIN
- globals = ctx->caml_global_data;
+ //globals = ctx->caml_global_data;
//int element_no = Wosize_val(globals);
//fprintf(stderr, "[bytecode] The tuple has %i elements\n", (int)element_no);
// FIXME: for debugging only. Remove: END
@@ -138,11 +138,6 @@ value caml_global_tuple_r(CAML_R)
#endif /* #else, #ifdef NATIVE_CODE */
}
-CAMLprim value caml_global_array_r(CAML_R, value unit)
-{
- return caml_global_tuple_r(ctx);
-}
-
/* Replace the globals of the given context with the elements of the given tuple: */
void caml_set_globals_r(CAML_R, value global_tuple){
/* No need to GC-protect anything here: we do not allocate anything
@@ -173,13 +168,13 @@ static value caml_globals_and_data_r(CAML_R, value *data, size_t element_no)
{
CAMLparam0();
CAMLlocal2(globals, values_to_clone);
- /* The GC can move the objects pointed by data at this time: no problem. */
- globals = caml_global_tuple_r(ctx);
+ globals = caml_global_array_r(ctx, Val_unit);
values_to_clone = caml_tuple_of_c_array_r(ctx, data, element_no);
CAMLreturn(caml_pair_r(ctx, globals, values_to_clone));
}
/* Return a pointer to a malloc'ed buffer: */
+//static long QQQ_length;
char* caml_serialize_into_blob_r(CAML_R, value caml_value){
CAMLparam1(caml_value);
CAMLlocal1(flags);
@@ -189,9 +184,7 @@ char* caml_serialize_into_blob_r(CAML_R, value caml_value){
flags = /* Marshal.Closures :: Marshal.Cross_context :: [] */
//caml_pair_r(ctx, Val_int(0), /* Marshal.No_sharing, 1st constructor */
caml_pair_r(ctx,
- ///////// FIXME: replace with Val_int(2) for testing (only)
Val_int(1), /* Marshal.Closures, 2nd constructor */
- ///////// FIXME: replace with Val_int(2) for testing (only)
caml_pair_r(ctx,
Val_int(2), /* Marshal.Cross_context, 3rd constructor */
Val_emptylist))
@@ -202,15 +195,21 @@ char* caml_serialize_into_blob_r(CAML_R, value caml_value){
caml_acquire_global_lock(); // FIXME: I should be able to remove this RIGHT NOW: do it when the thing is stable
caml_output_value_to_malloc_r(ctx, caml_value, flags, &blob, &blob_length);
caml_release_global_lock(); // FIXME: I should be able to remove this RIGHT NOW: do it when the thing is stable
- //fprintf(stderr, "Ok-Q 100: ...serialized a structure into the blob at %p (length %.2fMB).\n", blob, blob_length / 1024. / 1024.); fflush(stderr);
+//fprintf(stderr, "Ok-Q 100: ...serialized a structure into the blob at %p (length %.2fMB).\n", blob, blob_length / 1024. / 1024.); fflush(stderr);
+//DUMP("Made a %fMB blob at %p", blob_length / 1024. / 1024., blob);
+// QQQ_length = blob_length;
CAMLreturnT(char*, blob);
}
+value caml_input_value_from_string_r(CAML_R, value, value);
+
value caml_deserialize_blob_r(CAML_R, char *blob){
CAMLparam0();
- CAMLlocal1(result);
+ //CAMLlocal1(result);
+ CAMLlocal2(result, blob_as_caml_string);
caml_acquire_global_lock(); // FIXME: I should be able to remove this RIGHT NOW: do it when the thing is stable
+//DUMP("Deserializing the blob at %p", blob);
result = caml_input_value_from_block_r(ctx,
blob,
/* FIXME: this third parameter is useless in practice: ask the OCaml people to
@@ -218,6 +217,11 @@ caml_acquire_global_lock(); // FIXME: I should be able to remove this RIGHT NOW:
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);
+ //blob_as_caml_string = caml_alloc_string_r(ctx, QQQ_length);
+ //memmove(String_val(blob_as_caml_string), blob, QQQ_length);
+ //result = caml_input_value_from_string_r(ctx, blob_as_caml_string, Val_int(0));
+
+ //DUMP("Deserialized with success");
caml_release_global_lock(); // FIXME: I should be able to remove this RIGHT NOW: do it when the thing is stable
CAMLreturn(result);
}
@@ -229,11 +233,9 @@ static char* caml_globals_and_data_as_c_byte_array_r(CAML_R, value *data, size_t
}
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
- caml_input_value_from_malloc_r. After that call we don't
- allocate anything in this function. */
- value globals_and_data, global_tuple, data_tuple;
+ CAMLparam0();
+ CAMLlocal3(globals_and_data, global_tuple, data_tuple);
+ //value globals_and_data, global_tuple, data_tuple;
size_t to_value_no __attribute__((unused));
//fprintf(stderr, "Ok-A 100\n");
@@ -252,13 +254,14 @@ static void caml_install_globals_and_data_as_c_byte_array_r(CAML_R, value *to_va
caml_set_globals_r(ctx, global_tuple);
//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: */
+ /* Copy deserialized data from the tuple to the given address; the
+ tuple will be GC'd: */
caml_copy_tuple_elements_r(ctx,
to_values, &to_value_no,
data_tuple);
//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);
+ CAMLreturn0;
}
/* Implement the interface specified in the header file. */
@@ -316,7 +319,9 @@ static int caml_run_function_this_thread_r(CAML_R, value function, int index)
/* It's important that Extract_exception be used before the next
collection, because result_or_exception is an invalid value in
case of exception: */
+ DUMP("running caml code in the new context");
result_or_exception = caml_callback_exn_r(ctx, function, Val_int(index));
+ DUMP("back from the caml code in the new context");
/* If we decide to actually do something with result_or_exception,
then it becomes important that we call Extract_exception on it
(when it's an exception) before the next Caml allocation: in case
@@ -333,29 +338,56 @@ static int caml_run_function_this_thread_r(CAML_R, value function, int index)
}
/* Return 0 on success and non-zero on failure. */
-static int caml_deserialize_and_run_in_this_thread(char *blob, int index, sem_t *semaphore, /*out*/caml_global_context **to_context)
+static int caml_deserialize_and_run_in_this_thread(caml_global_context *parent_context, char *blob, int index, sem_t *semaphore, /*out*/caml_global_context **to_context)
{
/* Make a new empty context, and use it to deserialize the blob
- into. We don't want to GC-protect local variables here, since we
- will destroy the context at exit. This is ok: the only Caml
- allocations are in
- caml_install_globals_and_data_as_c_byte_array_r and in the function
- itself, which correctly GC-protect their own locals. */
+ into. */
CAML_R = caml_make_empty_context(); // ctx also becomes the thread-local context
- caml_initialize_context_thread_support(ctx);
CAMLparam0();
CAMLlocal1(function);
int did_we_fail;
+
+ caml_initialize_context_thread_support(ctx);
+ // !!!!!! NEW STUFF ADDED: BEGIN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ctx->caml_start_code = parent_context->caml_start_code;
+ ctx->caml_code_size = parent_context->caml_code_size;
+ ctx->caml_saved_code = parent_context->caml_saved_code;
+#ifdef THREADED_CODE
+ ctx->caml_instr_table = parent_context->caml_instr_table;
+ ctx->caml_instr_base = parent_context->caml_instr_base;
+#endif // #ifdef THREADED_CODE
+
+#ifndef NATIVE_CODE
+ DUMP();
+ caml_init_code_fragments_r(ctx); // this is needed for caml_install_globals_and_data_as_c_byte_array_r
+ DUMP();
+ ctx->caml_prim_table = parent_context->caml_prim_table;
+ ctx->caml_prim_name_table = parent_context->caml_prim_name_table;
+#endif // #ifdef THREADED_CODE
+
*to_context = ctx;
caml_install_globals_and_data_as_c_byte_array_r(ctx, &function, blob);
/* We're done with the blob: unpin it via the semaphore, so that it
can be destroyed when all split 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();
- fprintf(stderr, "caml_deserialize_and_run_in_this_thread [context %p] [thread %p] (index %i). About to V the semaphore.\n", ctx, (void*)(pthread_self()), index); fflush(stderr);
+ DUMP("About to V the semaphore. index=%i\n", index);
sem_post(semaphore);
+#ifndef NATIVE_CODE
+ DUMP();
+ caml_init_exceptions_r(ctx);
+ DUMP();
+ //caml_debugger_r(ctx, PROGRAM_START);
+#endif // #ifndef NATIVE_CODE
+ DUMP();
+ ctx->caml_exe_name = parent_context->caml_exe_name;
+ ctx->caml_main_argv = parent_context->caml_main_argv;
+ DUMP();
+ // !!!!!! NEW STUFF ADDED: END !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
/* Now do the actual work, in a function which correctly GC-protects its locals: */
+ DUMP();
did_we_fail = caml_run_function_this_thread_r(ctx, function, index);
if(did_we_fail){
fprintf(stderr, "caml_deserialize_and_run_in_this_thread [context %p] [thread %p] (index %i). FAILED.\n", ctx, (void*)(pthread_self()), index); fflush(stderr);
@@ -368,6 +400,7 @@ static int caml_deserialize_and_run_in_this_thread(char *blob, int index, sem_t
}
struct caml_thread_arguments{
+ caml_global_context *parent_context;
char *blob;
sem_t *semaphore;
caml_global_context **split_contexts;
@@ -377,7 +410,7 @@ struct caml_thread_arguments{
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;
- int did_we_fail = caml_deserialize_and_run_in_this_thread(args->blob, args->index, args->semaphore, args->split_contexts + args->index);
+ int did_we_fail = caml_deserialize_and_run_in_this_thread(args->parent_context, args->blob, args->index, args->semaphore, args->split_contexts + args->index);
//fprintf(stderr, "caml_deserialize_and_run_in_this_thread_as_thread_function (index %i) [about to free args]. Did we fail? %i\n", args->index, did_we_fail); fflush(stderr);
caml_stat_free(args);
return (void*)(long)did_we_fail;
@@ -399,29 +432,48 @@ static void caml_split_and_wait_r(CAML_R, char *blob, caml_global_context **spli
pthread_t thread;
struct caml_thread_arguments *args = caml_stat_alloc(sizeof(struct caml_thread_arguments));
int pthread_create_result;
+ args->parent_context = ctx;
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: */
+ /* Wait for the last thread to use the blob: */
//DUMP("waiting for every thread to deserialize");
for(i = 0; i < how_many; i ++){
- //DUMP("about to P");
+ DUMP("about to P");
sem_wait(semaphore);
- //DUMP("one child finished; waiting for %i more", (int)(how_many - i - 1));
+ DUMP("one child finished; waiting for %i more", (int)(how_many - i - 1));
}
- //DUMP("every thread has deserialized");
+ DUMP("every thread has deserialized");
+ // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ #define MAXK 0
+ int k; for(k = MAXK; k > 0; k --) { sleep(1); DUMP("countdown: %i", k); DUMP("GC'ing"); caml_gc_compaction_r(ctx, Val_unit); DUMP("GC'd"); }
+ DUMP("the countdown is over"); DUMP("GC'ing"); caml_gc_compaction_r(ctx, Val_unit); DUMP("GC'd");
+ DUMP("and now we're screwed. Aren't we?");
+ // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
}
CAMLprim value caml_context_split_r(CAML_R, value thread_no_as_value, value function)
{
CAMLparam1(function);
CAMLlocal2(result, open_channels);
+
+ /* DUMP("running caml code in the new context (so to speak)"); */
+ /* int i; */
+ /* for(i = 0; i < Int_val(thread_no_as_value); i ++) */
+ /* caml_callback_exn_r(ctx, function, Val_int(i)); */
+ /* DUMP("Done running caml code in the new context (so to speak)"); */
+ /* CAMLreturn(Val_unit); */
+ /* if(0){ */
+ /* caml_serialize_context(ctx, function); */
+ /* caml_split_and_wait_r(NULL, NULL, NULL, 10, NULL); */
+ /* } */
value *exception_closure = caml_named_value_r(ctx, "CannotSplit");
int can_split = caml_can_split_r(ctx);
//DUMP("************************** can_split is %i", can_split);
@@ -447,7 +499,9 @@ CAMLprim value caml_context_split_r(CAML_R, value thread_no_as_value, value func
/* Now we're done with the blob: */
// DUMP("child threads have finished with the blob: destroying it");
- caml_stat_free(blob);
+ //memset(blob, 0xcc, 100000); // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ //???????
+ caml_stat_free(blob); // !!!!!!!!!!!!!!!!!!!!!!!!!!! This is needed !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
// DUMP();
caml_gc_compaction_r(ctx, Val_unit); //!!!!!@@@@@@@@@@@@@
// DUMP();
35 byterun/extern.c
View
@@ -35,6 +35,18 @@
#include "mlvalues.h"
#include "reverse.h"
+// !!!!!!!!!!!!!!!
+void dump_digest(unsigned char *digest){
+ char msg[256];
+ sprintf(msg, "%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X",
+ digest[0], digest[1], digest[2], digest[3],
+ digest[4], digest[5], digest[6], digest[7],
+ digest[8], digest[9], digest[10], digest[11],
+ digest[12], digest[13], digest[14], digest[15]);
+ INIT_CAML_R;
+ DUMP("dumping %s", msg);
+}
+
/* Forward declarations */
@@ -325,6 +337,7 @@ static void extern_rec_r(CAML_R, value v)
sp = extern_stack;
while(1) {
+ //?????DUMP("QQQ 0x%lx, or %li ", v, v);
if (Is_long(v)) {
intnat n = Long_val(v);
if (n >= 0 && n < 0x40) {
@@ -345,7 +358,7 @@ static void extern_rec_r(CAML_R, value v)
header_t hd = Hd_val(v);
tag_t tag = Tag_hd(hd);
mlsize_t sz = Wosize_hd(hd);
-
+ //DUMP("dumping %p, tag %i, size %i", (void*)v, (int)tag, (int)sz); // !!!!!!!!!!!!!!!
if (tag == Forward_tag) {
value f = Forward_val (v);
if (Is_block (f)
@@ -495,19 +508,27 @@ static void extern_rec_r(CAML_R, value v)
}
}
else if ((cf = extern_find_code_r(ctx, (char *) v)) != NULL) {
- if (!extern_closures)
- //extern_invalid_argument_r(ctx, "output_value: functional value"); // FIXME: this is the correct version. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- {DUMP("output_value: functional value"); {volatile int a = 1; a /= 0;}}
+ if (!extern_closures){
+ extern_invalid_argument_r(ctx, "output_value: functional value"); // FIXME: this is the correct version. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ //DUMP("output_value: functional value"); {volatile int a = 1; a /= 0;}
+ }
//fprintf(stderr, "ZZZZ dumping a code pointer: BEGIN\n");
+ //DUMP("dumping a code pointer 0x%lx, or %li; code start is at %p", v, v, cf->code_start);
writecode32_r(ctx, CODE_CODEPOINTER, (char *) v - cf->code_start);
writeblock_r(ctx, (char *) cf->digest, 16);
+ //dump_digest(cf->digest);
//fprintf(stderr, "ZZZZ dumping a code pointer: END\n");
} else {
if(extern_cross_context){
- fprintf(stderr, "ZZZZ Copying an external pointer: %p, which is to say %li [cf is %p]\n", (void*)v, (long)v, cf);
- fprintf(stderr, "ZZZZ I'm doing a horrible, horrible thing: serializing the pointer as a tagged 0.\n");
+ //fprintf(stderr, "ZZZZ Copying an external pointer: %p, which is to say %li [cf is %p]\n", (void*)v, (long)v, cf);
+ //fprintf(stderr, "ZZZZ I'm doing a horrible, horrible thing: serializing the pointer as a tagged 0.\n");
+ DUMP("about to crash in the strange case I'm debugging");
+ /* DUMP("the object is 0x%lx, or %li ", v, v); */
+ /* DUMP("probably crashing now"); */
+ /* DUMP("tag is %i", (int)Tag_val(v)); */
+ /* DUMP("size is %i", (int)Wosize_val(v)); */
volatile int a = 1; a /= 0;
- extern_rec_r(ctx, Val_int(0));
+ //extern_rec_r(ctx, Val_int(0));
/* fprintf(stderr, "ZZZZ [This is probably wrong: I'm marshalling an out-of-heap pointer as an int64]\n"); */
/* writecode64_r(ctx, CODE_INT64, (v << 1) | 1); */
//extern_invalid_argument_r(ctx, "output_value: abstract value (outside heap) [FIXME: implement]");
1  byterun/fix_code.c
View
@@ -19,6 +19,7 @@
#define CAML_CONTEXT_EXTERN
#define CAML_CONTEXT_FIX_CODE
+#include <stdio.h> // !! remove if not needed in the end
#include "config.h"
#ifdef HAS_UNISTD
23 byterun/intern.c
View
@@ -411,9 +411,21 @@ static void intern_rec_r(CAML_R, value *dest)
len = read32u();
goto read_double_array;
case CODE_CODEPOINTER:
+ /* DUMP("unmarshalling codepointer: begin"); */
ofs = read32u();
+ /* DUMP("* ofs is %p or %i", (void*)(long)ofs, (int)ofs); */
readblock(digest, 16);
+ /* // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */
+ /* char readable_digest[256]; */
+ /* sprintf(readable_digest, "%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X", */
+ /* digest[0], digest[1], digest[2], digest[3], */
+ /* digest[4], digest[5], digest[6], digest[7], */
+ /* digest[8], digest[9], digest[10], digest[11], */
+ /* digest[12], digest[13], digest[14], digest[15]); */
+ /* DUMP("digest is %s", readable_digest); */
+ /* // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */
codeptr = intern_resolve_code_pointer_r(ctx, digest, ofs);
+ /* DUMP("* codeptr is %p", codeptr); */
if (codeptr != NULL) {
v = (value) codeptr;
} else {
@@ -423,9 +435,11 @@ static void intern_rec_r(CAML_R, value *dest)
v = *function_placeholder;
} else {
intern_cleanup_r(ctx);
+ /* DUMP("about to call intern_bad_code_pointer_r on the NULL code pointer"); */
intern_bad_code_pointer_r(ctx, digest);
}
}
+ /* DUMP("unmarshalling codepointer: end"); */
break;
case CODE_INFIXPOINTER:
ofs = read32u();
@@ -704,27 +718,34 @@ CAMLprim value caml_marshal_data_size_r(CAML_R, value buff, value ofs)
static char * intern_resolve_code_pointer_r(CAML_R, unsigned char digest[16],
asize_t offset)
{
+caml_acquire_global_lock(); // FIXME: remove !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
int i;
+ /* DUMP("caml_code_fragments_table.size=%i", (int)caml_code_fragments_table.size); */
for (i = caml_code_fragments_table.size - 1; i >= 0; i--) {
+ /* DUMP("i=%i", i); */
struct code_fragment * cf = caml_code_fragments_table.contents[i];
+ /* DUMP("cf=%p", cf); */
if (! cf->digest_computed) {
+ /* DUMP("cf=%p: computing MD5", cf); */
caml_md5_block(cf->digest, cf->code_start, cf->code_end - cf->code_start);
cf->digest_computed = 1;
}
if (memcmp(digest, cf->digest, 16) == 0) {
+caml_release_global_lock(); // FIXME: remove !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
if (cf->code_start + offset < cf->code_end)
return cf->code_start + offset;
else
return NULL;
}
}
+caml_release_global_lock(); // FIXME: remove !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
return NULL;
}
static void intern_bad_code_pointer_r(CAML_R, unsigned char digest[16])
{
char msg[256];
- sprintf(msg, "input_value: unknown code module %02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X",
+ sprintf(msg, "input_value: unknown code module %02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X (or bad code pointer)",
digest[0], digest[1], digest[2], digest[3],
digest[4], digest[5], digest[6], digest[7],
digest[8], digest[9], digest[10], digest[11],
19 byterun/interp.c
View
@@ -75,6 +75,25 @@ sp is a local copy of the global variable caml_extern_sp. */
# define Next break
#endif
+// FIXME: this is the correct version without my debugging crap. Restore. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+/* #ifdef THREADED_CODE */
+/* # define Instruct(name) lbl_##name */
+/* # if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) */
+/* # define Jumptbl_base ((char *) &&lbl_ACC0) */
+/* # else */
+/* # define Jumptbl_base ((char *) 0) */
+/* # define jumptbl_base ((char *) 0) */
+/* # endif */
+/* # ifdef DEBUG */
+/* # define Next goto next_instr */
+/* # else */
+/* # define Next goto *(void *)(jumptbl_base + *pc++) */
+/* # endif */
+/* #else */
+/* # define Instruct(name) case name */
+/* # define Next break */
+/* #endif */
+
/* GC interface */
#define Setup_for_gc \
4 byterun/major_gc.c
View
@@ -307,6 +307,10 @@ static void sweep_slice_r (CAML_R, intnat work)
Hd_hp (hp) = Whitehd_hd (hd);
break;
}
+ /////////////////////////// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ if(caml_gc_sweep_hp > mark_limit)
+ DUMP("caml_gc_sweep_hp = %p, mark_limit = %p", caml_gc_sweep_hp, mark_limit);
+ /////////////////////////// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Assert (caml_gc_sweep_hp <= mark_limit);
}else{
mark_chunk = Chunk_next (mark_chunk);
2  byterun/memory.c
View
@@ -19,6 +19,7 @@
#define CAML_CONTEXT_FREELIST
#define CAML_CONTEXT_GC_CTRL
+#include <stdio.h> // FIXME: remove in the end unless still needed
#include <stdlib.h>
#include <string.h>
#include "fail.h"
@@ -409,6 +410,7 @@ CAMLexport value caml_alloc_shr_r (CAML_R, mlsize_t wosize, tag_t tag)
new_block = expand_heap_r (ctx, wosize);
if (new_block == NULL) {
if (caml_in_minor_collection){
+ DUMP("trying to allocate %i words with tag %i", (int)wosize, (int)tag);
volatile int a = 1; a /= 0; // FIXME: remove this kludge
caml_fatal_error ("Fatal error: out of memory.\n");
}
4 byterun/minor_gc.c
View
@@ -112,6 +112,10 @@ void caml_oldify_one_r (CAML_R, value v, value *p)
tail_call:
if (Is_block (v) && Is_young (v)){
+ // !!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ if(Hp_val (v) < caml_young_ptr)
+ DUMP("Hp_val (v) = %p, caml_young_ptr = %p", Hp_val (v), caml_young_ptr);
+ // !!!!!!!!!!!!!!!!!!!!!!!!!!!!
Assert (Hp_val (v) >= caml_young_ptr);
hd = Hd_val (v);
if (hd == 0){ /* If already forwarded */
4 byterun/startup.c
View
@@ -350,12 +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_acquire_global_lock(); // FIXME: is this critical section needed?
+ 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();
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();
+ caml_release_global_lock();
// FIXME: unlock
/* Initialize the abstract machine */
18 otherlibs/systhreads/st_stubs.c
View
@@ -338,8 +338,10 @@ static caml_thread_t caml_thread_new_info(void)
th = (caml_thread_t) malloc(sizeof(struct caml_thread_struct));
if (th == NULL) return NULL;
//memset(th, 0, sizeof(struct caml_thread_struct)); // This was for debugging only --Luca Saiu REENTRANTRUNTIME
- INIT_CAML_R; DUMP("memset'ting the new caml_thread_struct with 0xbb");
- memset(th, 0xbb, sizeof(struct caml_thread_struct)); // This was for debugging only --Luca Saiu REENTRANTRUNTIME
+ //INIT_CAML_R; DUMP("memset'ting the new caml_thread_struct with 0xbb");
+ //memset(th, 0xbb, sizeof(struct caml_thread_struct)); // This was for debugging only --Luca Saiu REENTRANTRUNTIME
+ INIT_CAML_R; DUMP("memset'ting the new caml_thread_struct with 0x0 in [%p, %p)", th, ((char*)th) + sizeof(struct caml_thread_struct));
+ memset(th, 0x0, sizeof(struct caml_thread_struct)); // This was for debugging only --Luca Saiu REENTRANTRUNTIME
/* //memset(th, 42, sizeof(struct caml_thread_struct)); // This was for debugging only --Luca Saiu REENTRANTRUNTIME */
/* memset(th, -1, sizeof(struct caml_thread_struct)); // This was for debugging only --Luca Saiu REENTRANTRUNTIME */
/* {int i; */
@@ -527,9 +529,10 @@ static void caml_thread_initialize_for_current_context_r(CAML_R){
/* Set up a thread info block for the current thread */
curr_thread =
(caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
- DUMP("memset'ting the main caml_thread_struct with 0xaa");
- memset(curr_thread, 0xaa, sizeof(struct caml_thread_struct)); // !!!!!!!!! FIXME: remove. This is for debugging only
- //memset(curr_thread, 0x00, sizeof(struct caml_thread_struct)); // !!!!!!!!! FIXME: remove. This is for debugging only. [FIXME: is it? I strongly suspect that gc_regs or some other fields used for GC must be a valid NULL pointer for this to work *in all circumstances*; stat_alloc used malloc, which in the GNU implementation *in practice* zeros small allocted buffers.]
+ //DUMP("memset'ting the main caml_thread_struct with 0xaa");
+ //memset(curr_thread, 0xaa, sizeof(struct caml_thread_struct)); // !!!!!!!!! FIXME: remove. This is for debugging only
+ DUMP("memset'ting the main caml_thread_struct with 0x0 in [%p, %p)", curr_thread, ((char*)curr_thread) + sizeof(struct caml_thread_struct));
+ memset(curr_thread, 0x0, sizeof(struct caml_thread_struct)); // !!!!!!!!! FIXME: remove. This is for debugging only. [FIXME: is it? I strongly suspect that gc_regs or some other fields used for GC must be a valid NULL pointer for this to work *in all circumstances*; stat_alloc used malloc, which in the GNU implementation *in practice* zeros small allocted buffers.]
curr_thread->descr = caml_thread_new_descriptor_r(ctx, Val_unit);
curr_thread->next = curr_thread;
curr_thread->prev = curr_thread;
@@ -690,8 +693,9 @@ static ST_THREAD_FUNCTION caml_thread_start(void * arg)
Begin_root (clos);
caml_modify_r(ctx, &(Start_closure(th->descr)), Val_unit);
DUMP("calling the caml code");
- //caml_callback_exn_r(ctx, clos, Val_unit); // !!!!!!!!!!!!!!!!!!!!!!!!!!!! This is the right version
- caml_callback_r(ctx, clos, Val_unit); // Just for testing: I want to see the exception !!!!!!!!!!!!!!!!!!!!!!!!
+ //DUMP("stack is [%p, ~%p]", caml_bottom_of_stack, &tos);
+ caml_callback_exn_r(ctx, clos, Val_unit); // !!!!!!!!!!!!!!!!!!!!!!!!!!!! This is the right version
+ //caml_callback_r(ctx, clos, Val_unit); // Just for testing: I want to see the exception !!!!!!!!!!!!!!!!!!!!!!!!
QR("exiting the native-code thread");
End_roots();
caml_thread_stop_r(ctx);
9 stdlib/context.ml
View
@@ -54,16 +54,17 @@ let to_string context =
let sself () = to_string (self ())
-external globals : unit -> 'a = "caml_global_array_r" "reentrant"
-(* external globals_and_datum : 'a -> ('b * 'a) = "caml_global_tuple_and_datum_r" "reentrant" *)
+external globals_function : unit -> 'a = "caml_global_array_r" "reentrant"
+
+let globals = globals_function ()
let rec global_index_from global globals from =
- if globals.(from) == global then
+ if globals.(from) = (* == *) global then
from
else
global_index_from global globals (from + 1);;
let global_index global =
- global_index_from global (globals ()) 0;;
+ global_index_from global globals 0;;
external actually_join_context : t -> unit = "caml_context_join_r" "reentrant"
let join_context =
15 stdlib/context.mli
View
@@ -31,9 +31,15 @@ val split1 : (mailbox -> unit) -> (*new context mailbox*)mailbox
val split : int -> (int -> mailbox -> unit) -> (*mailboxes to new contexts*)(mailbox list)
val split_into_array : int -> (int -> mailbox -> unit) -> (*mailboxes to new contexts*)(mailbox array)
+(* FIXME: do I need to expose these? *)
+val split_into_context_array : int -> (int -> unit) -> (t array)
+val split_into_context_list : int -> (int -> unit) -> (t list)
+val split_into_context : (unit -> unit) -> t
+
val send : mailbox -> 'a -> unit
val receive : mailbox -> 'a (* raises ForeignMailbox if the mailbox is foreign *)
+
(* Wait until the context local to the given mailbox or mailboxes terminates: *)
(* FIXME: fix the multi-thread case [FIXME: is it already fixed?]*)
val join_context : t -> unit
@@ -65,8 +71,13 @@ val sself : unit -> string
(* FIXME: these are for debugging only, and global_index in particular
is not exactly type-safe :-) *)
-val globals : unit -> 'a
-(* val globals_and_datum : 'a -> ('b * 'a) *)
+
+(* A Caml tuple/array containing all the globals of the given context.
+ The result should not be modified as it may share structure with
+ the context globals. The result may be invalidated by loading caml
+ compilation units at run time (via dynlink, I suppose -- not yet
+ supported). *)
+val globals : Obj.t array
(* Return the index for the given global value (compared by identity)
within the array of all globals. Raise an exception or crash
2  stdlib/pervasives.ml
View
@@ -11,6 +11,8 @@
(* *)
(***********************************************************************)
+let qqq = 53
+
(* $Id$ *)
(* type 'a option = None | Some of 'a *)
2  stdlib/pervasives.mli
View
@@ -27,6 +27,8 @@
(** {6 Exceptions} *)
+val qqq : int
+
external raise : exn -> 'a = "%raise"
(** Raise the given exception value *)
Please sign in to comment.
Something went wrong with that request. Please try again.