Browse files

Adapted VM threads to multi-context; threads work, now I only have to…

… move a few global variable to the context struct
  • Loading branch information...
1 parent e42ab87 commit 14c9a9ac19df90cc56452168e67df217d26ecbd7 @lucasaiu committed Jul 16, 2013
Showing with 408 additions and 426 deletions.
  1. BIN boot/arg.cmi
  2. BIN boot/array.cmi
  3. BIN boot/arrayLabels.cmi
  4. BIN boot/buffer.cmi
  5. BIN boot/callback.cmi
  6. BIN boot/camlinternalLazy.cmi
  7. BIN boot/camlinternalMod.cmi
  8. BIN boot/camlinternalOO.cmi
  9. BIN boot/char.cmi
  10. BIN boot/complex.cmi
  11. BIN boot/context.cmi
  12. BIN boot/digest.cmi
  13. BIN boot/filename.cmi
  14. BIN boot/format.cmi
  15. BIN boot/gc.cmi
  16. BIN boot/genlex.cmi
  17. BIN boot/hashtbl.cmi
  18. BIN boot/int32.cmi
  19. BIN boot/int64.cmi
  20. BIN boot/lazy.cmi
  21. BIN boot/lexing.cmi
  22. BIN boot/list.cmi
  23. BIN boot/listLabels.cmi
  24. BIN boot/map.cmi
  25. BIN boot/marshal.cmi
  26. BIN boot/moreLabels.cmi
  27. BIN boot/myocamlbuild
  28. BIN boot/nativeint.cmi
  29. BIN boot/obj.cmi
  30. BIN boot/ocamlc
  31. BIN boot/ocamldep
  32. BIN boot/ocamllex
  33. BIN boot/ocamlrun
  34. BIN boot/ocamlyacc
  35. BIN boot/oo.cmi
  36. BIN boot/parsing.cmi
  37. BIN boot/pervasives.cmi
  38. BIN boot/printexc.cmi
  39. BIN boot/printf.cmi
  40. BIN boot/queue.cmi
  41. BIN boot/random.cmi
  42. BIN boot/scanf.cmi
  43. BIN boot/set.cmi
  44. BIN boot/sort.cmi
  45. BIN boot/stack.cmi
  46. BIN boot/stdLabels.cmi
  47. BIN boot/std_exit.cmi
  48. BIN boot/std_exit.cmo
  49. BIN boot/stdlib.cma
  50. BIN boot/stream.cmi
  51. BIN boot/string.cmi
  52. BIN boot/stringLabels.cmi
  53. BIN boot/sys.cmi
  54. BIN boot/weak.cmi
  55. +24 −24 byterun/context_split.c
  56. +9 −9 byterun/io.c
  57. +1 −0 config/s.h
  58. +22 −12 configure
  59. +12 −31 myocamlbuild_config.ml
  60. +3 −1 otherlibs/threads/Makefile
  61. +5 −4 otherlibs/threads/marshal.ml
  62. +61 −60 otherlibs/threads/pervasives.ml
  63. +109 −100 otherlibs/threads/scheduler.c
  64. +18 −18 otherlibs/threads/thread.ml
  65. +132 −132 otherlibs/threads/unix.ml
  66. +0 −2 stdlib/pervasives.ml
  67. +0 −2 stdlib/pervasives.mli
  68. +12 −31 tools/myocamlbuild_config.ml
View
BIN boot/arg.cmi
Binary file not shown.
View
BIN boot/array.cmi
Binary file not shown.
View
BIN boot/arrayLabels.cmi
Binary file not shown.
View
BIN boot/buffer.cmi
Binary file not shown.
View
BIN boot/callback.cmi
Binary file not shown.
View
BIN boot/camlinternalLazy.cmi
Binary file not shown.
View
BIN boot/camlinternalMod.cmi
Binary file not shown.
View
BIN boot/camlinternalOO.cmi
Binary file not shown.
View
BIN boot/char.cmi
Binary file not shown.
View
BIN boot/complex.cmi
Binary file not shown.
View
BIN boot/context.cmi
Binary file not shown.
View
BIN boot/digest.cmi
Binary file not shown.
View
BIN boot/filename.cmi
Binary file not shown.
View
BIN boot/format.cmi
Binary file not shown.
View
BIN boot/gc.cmi
Binary file not shown.
View
BIN boot/genlex.cmi
Binary file not shown.
View
BIN boot/hashtbl.cmi
Binary file not shown.
View
BIN boot/int32.cmi
Binary file not shown.
View
BIN boot/int64.cmi
Binary file not shown.
View
BIN boot/lazy.cmi
Binary file not shown.
View
BIN boot/lexing.cmi
Binary file not shown.
View
BIN boot/list.cmi
Binary file not shown.
View
BIN boot/listLabels.cmi
Binary file not shown.
View
BIN boot/map.cmi
Binary file not shown.
View
BIN boot/marshal.cmi
Binary file not shown.
View
BIN boot/moreLabels.cmi
Binary file not shown.
View
BIN boot/myocamlbuild
Binary file not shown.
View
BIN boot/nativeint.cmi
Binary file not shown.
View
BIN boot/obj.cmi
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/ocamlyacc
Binary file not shown.
View
BIN boot/oo.cmi
Binary file not shown.
View
BIN boot/parsing.cmi
Binary file not shown.
View
BIN boot/pervasives.cmi
Binary file not shown.
View
BIN boot/printexc.cmi
Binary file not shown.
View
BIN boot/printf.cmi
Binary file not shown.
View
BIN boot/queue.cmi
Binary file not shown.
View
BIN boot/random.cmi
Binary file not shown.
View
BIN boot/scanf.cmi
Binary file not shown.
View
BIN boot/set.cmi
Binary file not shown.
View
BIN boot/sort.cmi
Binary file not shown.
View
BIN boot/stack.cmi
Binary file not shown.
View
BIN boot/stdLabels.cmi
Binary file not shown.
View
BIN boot/std_exit.cmi
Binary file not shown.
View
BIN boot/std_exit.cmo
Binary file not shown.
View
BIN boot/stdlib.cma
Binary file not shown.
View
BIN boot/stream.cmi
Binary file not shown.
View
BIN boot/string.cmi
Binary file not shown.
View
BIN boot/stringLabels.cmi
Binary file not shown.
View
BIN boot/sys.cmi
Binary file not shown.
View
BIN boot/weak.cmi
Binary file not shown.
View
48 byterun/context_split.c
@@ -565,24 +565,24 @@ CAMLprim value caml_context_split_r(CAML_R, value thread_no_as_value, value func
/* 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: */
-//if(0){//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- struct channel *channel;
- struct channel **channels;
- int channel_no = 0;
- caml_acquire_global_lock();
- for (channel = caml_all_opened_channels;
- channel != NULL;
- channel = channel->next)
- channel_no ++;
- channels = caml_stat_alloc(sizeof(struct channel*) * channel_no);
- for (i = 0, channel = caml_all_opened_channels;
- channel != NULL;
- i ++, channel = channel->next){
- channels[i] = channel;
- DUMP("split-pinning channel %p, with fd %i, refcount %i->%i", channel, (int)channel->fd, channel->refcount, channel->refcount + 1);
- channel->refcount ++;
- }
- caml_release_global_lock();
+/* //if(0){//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */
+/* struct channel *channel; */
+/* struct channel **channels; */
+/* int channel_no = 0; */
+/* caml_acquire_global_lock(); */
+/* for (channel = caml_all_opened_channels; */
+/* channel != NULL; */
+/* channel = channel->next) */
+/* channel_no ++; */
+/* channels = caml_stat_alloc(sizeof(struct channel*) * channel_no); */
+/* for (i = 0, channel = caml_all_opened_channels; */
+/* channel != NULL; */
+/* i ++, channel = channel->next){ */
+/* channels[i] = channel; */
+/* DUMP("split-pinning channel %p, with fd %i, refcount %i->%i", channel, (int)channel->fd, channel->refcount, channel->refcount + 1); */
+/* channel->refcount ++; */
+/* } */
+/* caml_release_global_lock(); */
//open_channels = caml_ml_all_channels_list_r(ctx); // !!!!!!!!!!!!!!!!!!!! This can occasionally cause crashes related to channel picounts. I certainly messed up something in io.c. //!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
//}//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -647,12 +647,12 @@ CAMLprim value caml_context_split_r(CAML_R, value thread_no_as_value, value func
DUMP("destroyed the malloced buffer of pointers new_contexts");
DUMPROOTS("from parent, after splitting");
- caml_acquire_global_lock();
- for (i = 0; i < channel_no; i ++){
- DUMP("split-unpinning channels[i] %p, with fd %i, refcount %i->%i", channels[i], (int)channels[i]->fd, channels[i]->refcount, channels[i]->refcount - 1);
- channels[i]->refcount --;
- }
- caml_release_global_lock();
+ /* caml_acquire_global_lock(); */
+ /* for (i = 0; i < channel_no; i ++){ */
+ /* DUMP("split-unpinning channels[i] %p, with fd %i, refcount %i->%i", channels[i], (int)channels[i]->fd, channels[i]->refcount, channels[i]->refcount - 1); */
+ /* channels[i]->refcount --; */
+ /* } */
+ /* caml_release_global_lock(); */
CAMLreturn(result);
//CAMLreturn(Val_unit);
View
18 byterun/io.c
@@ -130,20 +130,20 @@ caml_release_global_lock();
CAMLexport void caml_close_channel(struct channel *channel)
{
- int old_fd = (int)channel->fd; // FIXME: remove!!!!!!!
+ int old_fd __attribute__((unused)) = (int)channel->fd; // FIXME: remove!!!!!!!
INIT_CAML_R;
int greater_than_zero;
close(channel->fd);
Lock(channel);
greater_than_zero = channel->refcount > 0;
- if((channel->fd >= 0) && (channel->fd < 3))DUMP("closing the channel with struct channel* %p, fd %i: its refcount is now %i\n", channel, channel->fd, (int)channel->refcount);
+ if((channel->fd >= 0) && (channel->fd < 3))QDUMP("closing the channel with struct channel* %p, fd %i: its refcount is now %i\n", channel, channel->fd, (int)channel->refcount);
//channel->already_closed = 1;
Unlock(channel);
if (greater_than_zero)
return;
if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(channel);
unlink_channel(channel);
- DUMP("Freeing the channel structure at %p (fd %i, refcount %i)", channel, old_fd, (int)channel->refcount);
+ QDUMP("Freeing the channel structure at %p (fd %i, refcount %i)", channel, old_fd, (int)channel->refcount);
caml_stat_free(channel);
}
@@ -476,16 +476,16 @@ CAMLexport void caml_finalize_channel(value vchan)
int greater_than_zero;
INIT_CAML_R;
Lock(chan);
- int old_refcount = chan->refcount, new_refcount = old_refcount - 1; // !!!!!!!!!!!!!!!!!!!!
- //DUMP("SHOULD unpin the channel with struct channel* %p, fd %i, refcount %i->%i", chan, chan->fd, old_refcount, new_refcount);
+ int old_refcount __attribute__((unused)) = chan->refcount, new_refcount __attribute__((unused)) = old_refcount - 1; // !!!!!!!!!!!!!!!!!!!!
+ //QDUMP("SHOULD unpin the channel with struct channel* %p, fd %i, refcount %i->%i", chan, chan->fd, old_refcount, new_refcount);
greater_than_zero = --chan->refcount > 0; // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Unlock(chan);
//return; // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- DUMP("unpinning the channel with struct channel* %p, fd %i, refcount %i->%i", chan, chan->fd, old_refcount, new_refcount);
+ QDUMP("unpinning the channel with struct channel* %p, fd %i, refcount %i->%i", chan, chan->fd, old_refcount, new_refcount);
if (greater_than_zero)
return;
- ///*if(chan->fd == 2)*/{ DUMP("SHOULD destroy the channel with struct channel* %p, fd %i, refcount %i", chan, chan->fd, new_refcount); return; }// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JUST A TEST, OF COURSE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- DUMP("destroying the channel with struct channel* %p, fd %i", chan, chan->fd);
+ ///*if(chan->fd == 2)*/{ QDUMP("SHOULD destroy the channel with struct channel* %p, fd %i, refcount %i", chan, chan->fd, new_refcount); return; }// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! JUST A TEST, OF COURSE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ QDUMP("destroying the channel with struct channel* %p, fd %i", chan, chan->fd);
if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(chan);
unlink_channel(chan);
caml_stat_free(chan);
@@ -542,7 +542,7 @@ static uintnat cross_context_deserialize_channel(void * dst){
word, and pin it: */
*((struct channel**)dst) = pointer;
Lock(pointer);
- pointer->refcount ++; // FIXME: is this needed? !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ pointer->refcount ++;
QDUMP("Cross-context-deserializing the channel with struct channel* %p, fd %i: its refcount is now %i", pointer, pointer->fd, pointer->refcount);
Unlock(pointer);
View
1 config/s.h
@@ -49,5 +49,6 @@
#define HAS_STACK_OVERFLOW_DETECTION
#define HAS_MULTI_CONTEXT
#define HAS_PTHREAD
+#define HAS_PTHREAD
#define HAS_SIGWAIT
#define HAS_LIBBFD
View
34 configure
@@ -1181,10 +1181,19 @@ echo "BNG_ASM_LEVEL=$bng_asm_level" >> Makefile
# Determine if multi-context is supported
+multicontext_support=false
case "$arch,$system" in
amd64,linux)
echo "Multi-context is supported."
- echo "#define HAS_MULTI_CONTEXT" >> s.h;;
+ multicontext_support=true
+ echo "#define HAS_MULTI_CONTEXT" >> s.h
+ # FIXME: all of this should probably be printed only once
+ pthread_link="-lpthread"
+ pthread_caml_link="-cclib -lpthread"
+ bytecccompopts="$bytecccompopts -D_REENTRANT"
+ nativecccompopts="$nativecccompopts -D_REENTRANT"
+ echo "#define HAS_PTHREAD" >> s.h
+ ;;
*)
echo "Multi-context is not supported";;
esac
@@ -1208,8 +1217,10 @@ if test "$pthread_wanted" = "yes"; then
echo "POSIX threads library supported."
systhread_support=true
otherlibraries="$otherlibraries systhreads"
- bytecccompopts="$bytecccompopts -D_REENTRANT"
- nativecccompopts="$nativecccompopts -D_REENTRANT"
+# if test "$multicontext_support" != "1"; then
+ bytecccompopts="$bytecccompopts -D_REENTRANT"
+ nativecccompopts="$nativecccompopts -D_REENTRANT"
+# fi
echo "#define HAS_PTHREAD" >> s.h
case "$host" in
*-*-freebsd*)
@@ -1236,16 +1247,15 @@ echo "PTHREAD_LINK=$pthread_caml_link" >> Makefile
# Determine if the bytecode thread library is supported
-# FIXME: fix and re-enable --Luca Saiu REENTRANTRUNTIME
-# if test "$has_select" = "yes" \
-# && test "$has_setitimer" = "yes" \
-# && test "$has_gettimeofday" = "yes" \
-# && test "$has_wait" = "yes"; then
-# echo "Bytecode threads library supported."
-# otherlibraries="$otherlibraries threads"
-# else
+if test "$has_select" = "yes" \
+&& test "$has_setitimer" = "yes" \
+&& test "$has_gettimeofday" = "yes" \
+&& test "$has_wait" = "yes"; then
+ echo "Bytecode threads library supported."
+ otherlibraries="$otherlibraries threads"
+else
echo "Bytecode threads library not supported (missing system calls)"
-# fi
+fi
# Determine the location of X include files and libraries
View
43 myocamlbuild_config.ml
@@ -1,22 +1,3 @@
-(* #MYCFLAGS = -Wall -Wno-unused-value -Wno-div-by-zero -Werror -Wno-error=unused-but-set-variable -g3 -Og -fstack-check *)
-let mydebugflags = " -g3";;
-(* #MYCFLAGS += -fstack-check *)
-(* #MYCFLAGS = -Wall -Wno-unused-value -Wno-div-by-zero -Werror -Wno-error=unused-but-set-variable -fno-strict-aliasing -g3 -O2 *)
-let mycflags = " -Wall -Wno-unused-value -Wno-div-by-zero -Werror -Wno-error=unused-but-set-variable -fno-strict-aliasing "^mydebugflags^" -O1";;
-(* #MYCFLAGS = -Ofast *)
-
-(* #MYCFLAGS = -Wall -Wno-unused-value -Wno-div-by-zero -Werror -Wno-error=unused-but-set-variable -Wno-error=strict-aliasing -g3 -O1 *)
-(* #MYCC=gcc-4.8 "^mycflags^" *)
-let mycc = "gcc "^mycflags;;
-
-(* # CFLAGS += "^mycflags^" *)
-(* # MYCFLAGS += -g *)
-(* # MYCFLAGS += -O1 *)
-
-(* # This is very likely crap: *)
-(* #MYCFLAGS += -DDEBUG -D_DEBUG *)
-(* #MYCFLAGS += -mthreads *)
-
(* # generated by ./configure --prefix /home/luca/usr-patched-ocaml/ --with-debug-runtime *)
let prefix = "/home/luca/usr-patched-ocaml/";;
let bindir = prefix^"/bin";;
@@ -36,8 +17,8 @@ let x11_link = "not found";;
let tk_defs = "";;
let tk_link = "";;
let libbfd_link = "-lbfd -ldl -liberty -lz";;
-let bytecc = mycc^" "^mycflags;;
-let bytecccompopts = "-fno-defer-pop "^mycflags^" -D_FILE_OFFSET_BITS=64 -D_REENTRANT";;
+let bytecc = "gcc";;
+let bytecccompopts = "-fno-defer-pop -Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT -D_REENTRANT";;
let bytecclinkopts = " -Wl,-E";;
let bytecclibs = " -lm -ldl -lcurses -lpthread";;
let byteccrpath = "-Wl,-rpath,";;
@@ -55,18 +36,18 @@ let mklib out files opts = Printf.sprintf "ar rc %s %s %s; ranlib %s" out opts f
let arch = "amd64";;
let model = "default";;
let system = "linux";;
-let nativecc = mycc^" "^mycflags;;
-let nativecccompopts = mycflags^" -D_FILE_OFFSET_BITS=64 -D_REENTRANT";;
-let nativeccprofopts = mycflags^" -D_FILE_OFFSET_BITS=64 -D_REENTRANT";;
+let nativecc = "gcc";;
+let nativecccompopts = "-Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT -D_REENTRANT";;
+let nativeccprofopts = "-Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT -D_REENTRANT";;
let nativecclinkopts = "";;
let nativeccrpath = "-Wl,-rpath,";;
let nativecclibs = " -lm -ldl -lpthread";;
let asm = "as";;
-let aspp = mycc^" "^mycflags^" -c";;
+let aspp = "gcc -c";;
let asppprofflags = "-DPROFILING";;
let profiling = "prof";;
let dynlinkopts = " -ldl";;
-let otherlibraries = "unix str num dynlink bigarray systhreads";;
+let otherlibraries = "unix str num dynlink bigarray systhreads threads";;
let debugger = "ocamldebugger";;
let cc_profile = "-pg";;
let systhread_support = true;;
@@ -82,14 +63,14 @@ let ext_asm = ".s";;
let ext_lib = ".a";;
let ext_dll = ".so";;
let extralibs = "";;
-let ccomptype = mycc^" "^mycflags;;
-let toolchain = mycc^" "^mycflags;;
+let ccomptype = "cc";;
+let toolchain = "cc";;
let natdynlink = true;;
let cmxs = "cmxs";;
let mkexe = bytecc;;
-let mkexedebugflag = mydebugflags;;
-let mkdll = mycc^" "^mycflags^" -shared";;
-let mkmaindll = mycc^" "^mycflags^" -shared";;
+let mkexedebugflag = "-g";;
+let mkdll = "gcc -shared";;
+let mkmaindll = "gcc -shared";;
let runtimed = "runtimed";;
let camlp4 = "camlp4";;
let asm_cfi_supported = true;;
View
4 otherlibs/threads/Makefile
@@ -40,7 +40,9 @@ LIB_OBJS=pervasives.cmo \
$(LIB)/camlinternalOO.cmo \
$(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/genlex.cmo \
$(LIB)/weak.cmo $(LIB)/filename.cmo \
- $(LIB)/complex.cmo $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo \
+ $(LIB)/complex.cmo \
+ $(LIB)/context.cmo $(LIB)/skeleton.cmo \
+ $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo \
$(LIB)/stringLabels.cmo $(LIB)/stdLabels.cmo $(LIB)/moreLabels.cmo
UNIXLIB=../unix
View
9 otherlibs/threads/marshal.ml
@@ -16,16 +16,17 @@
type extern_flags =
No_sharing
| Closures
+ | Cross_context
external to_string: 'a -> extern_flags list -> string
- = "caml_output_value_to_string"
+ = "caml_output_value_to_string_r" "reentrant"
let to_channel chan v flags =
output_string chan (to_string v flags)
external to_buffer_unsafe:
string -> int -> int -> 'a -> extern_flags list -> int
- = "caml_output_value_to_buffer"
+ = "caml_output_value_to_buffer_r" "reentrant"
let to_buffer buff ofs len v flags =
if ofs < 0 || len < 0 || ofs + len > String.length buff
@@ -35,8 +36,8 @@ let to_buffer buff ofs len v flags =
let to_buffer' ~buf ~pos ~len v ~mode = to_buffer buf pos len v mode
external from_string_unsafe: string -> int -> 'a
- = "caml_input_value_from_string"
-external data_size_unsafe: string -> int -> int = "caml_marshal_data_size"
+ = "caml_input_value_from_string_r" "reentrant"
+external data_size_unsafe: string -> int -> int = "caml_marshal_data_size_r" "reentrant"
let header_size = 20
let data_size buff ofs =
View
121 otherlibs/threads/pervasives.ml
@@ -87,37 +87,38 @@ external (+.) : float -> float -> float = "%addfloat"
external (-.) : float -> float -> float = "%subfloat"
external ( *. ) : float -> float -> float = "%mulfloat"
external (/.) : float -> float -> float = "%divfloat"
-external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float"
-external exp : float -> float = "caml_exp_float" "exp" "float"
-external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float"
-external acos : float -> float = "caml_acos_float" "acos" "float"
-external asin : float -> float = "caml_asin_float" "asin" "float"
-external atan : float -> float = "caml_atan_float" "atan" "float"
-external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
-external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" "float"
-external cos : float -> float = "caml_cos_float" "cos" "float"
-external cosh : float -> float = "caml_cosh_float" "cosh" "float"
-external log : float -> float = "caml_log_float" "log" "float"
-external log10 : float -> float = "caml_log10_float" "log10" "float"
-external log1p : float -> float = "caml_log1p_float" "caml_log1p" "float"
-external sin : float -> float = "caml_sin_float" "sin" "float"
-external sinh : float -> float = "caml_sinh_float" "sinh" "float"
-external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float"
-external tan : float -> float = "caml_tan_float" "tan" "float"
-external tanh : float -> float = "caml_tanh_float" "tanh" "float"
-external ceil : float -> float = "caml_ceil_float" "ceil" "float"
-external floor : float -> float = "caml_floor_float" "floor" "float"
+(* external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float" *)
+external ( ** ) : float -> float -> float = "caml_power_float_r" "reentrant" "pow" "float"
+external exp : float -> float = "caml_exp_float_r" "reentrant" "exp" "float"
+external expm1 : float -> float = "caml_expm1_float_r" "reentrant" "caml_expm1" "float"
+external acos : float -> float = "caml_acos_float_r" "reentrant" "acos" "float"
+external asin : float -> float = "caml_asin_float_r" "reentrant" "asin" "float"
+external atan : float -> float = "caml_atan_float_r" "reentrant" "atan" "float"
+external atan2 : float -> float -> float = "caml_atan2_float_r" "reentrant" "atan2" "float"
+external hypot : float -> float -> float = "caml_hypot_float_r" "reentrant" "caml_hypot" "float"
+external cos : float -> float = "caml_cos_float_r" "reentrant" "cos" "float"
+external cosh : float -> float = "caml_cosh_float_r" "reentrant" "cosh" "float"
+external log : float -> float = "caml_log_float_r" "reentrant" "log" "float"
+external log10 : float -> float = "caml_log10_float_r" "reentrant" "log10" "float"
+external log1p : float -> float = "caml_log1p_float_r" "reentrant" "caml_log1p" "float"
+external sin : float -> float = "caml_sin_float_r" "reentrant" "sin" "float"
+external sinh : float -> float = "caml_sinh_float_r" "reentrant" "sinh" "float"
+external sqrt : float -> float = "caml_sqrt_float_r" "reentrant" "sqrt" "float"
+external tan : float -> float = "caml_tan_float_r" "reentrant" "tan" "float"
+external tanh : float -> float = "caml_tanh_float_r" "reentrant" "tanh" "float"
+external ceil : float -> float = "caml_ceil_float_r" "reentrant" "ceil" "float"
+external floor : float -> float = "caml_floor_float_r" "reentrant" "floor" "float"
external abs_float : float -> float = "%absfloat"
-external copysign : float -> float -> float = "caml_copysign_float" "caml_copysign" "float"
-external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
-external frexp : float -> float * int = "caml_frexp_float"
-external ldexp : float -> int -> float = "caml_ldexp_float"
-external modf : float -> float * float = "caml_modf_float"
+external copysign : float -> float -> float = "caml_copysign_float_r" "reentrant" "caml_copysign" "float"
+external mod_float : float -> float -> float = "caml_fmod_float_r" "reentrant" "fmod" "float"
+external frexp : float -> float * int = "caml_frexp_float_r" "reentrant"
+external ldexp : float -> int -> float = "caml_ldexp_float_r" "reentrant"
+external modf : float -> float * float = "caml_modf_float_r" "reentrant"
external float : int -> float = "%floatofint"
external float_of_int : int -> float = "%floatofint"
external truncate : float -> int = "%intoffloat"
external int_of_float : float -> int = "%intoffloat"
-external float_of_bits : int64 -> float = "caml_int64_float_of_bits"
+external float_of_bits : int64 -> float = "caml_int64_float_of_bits_r" "reentrant"
let infinity =
float_of_bits 0x7F_F0_00_00_00_00_00_00L
let neg_infinity =
@@ -142,7 +143,7 @@ external classify_float: float -> fpclass = "caml_classify_float"
(* String operations -- more in module String *)
external string_length : string -> int = "%string_length"
-external string_create: int -> string = "caml_create_string"
+external string_create: int -> string = "caml_create_string_r" "reentrant"
external string_blit : string -> int -> string -> int -> int -> unit
= "caml_blit_string" "noalloc"
@@ -180,8 +181,8 @@ external decr: int ref -> unit = "%decr"
(* String conversion functions *)
-external format_int: string -> int -> string = "caml_format_int"
-external format_float: string -> float -> string = "caml_format_float"
+external format_int: string -> int -> string = "caml_format_int_r" "reentrant"
+external format_float: string -> float -> string = "caml_format_float_r" "reentrant"
let string_of_bool b =
if b then "true" else "false"
@@ -193,7 +194,7 @@ let bool_of_string = function
let string_of_int n =
format_int "%d" n
-external int_of_string : string -> int = "caml_int_of_string"
+external int_of_string : string -> int = "caml_int_of_string_r" "reentrant"
let valid_float_lexem s =
let l = string_length s in
@@ -208,7 +209,7 @@ let valid_float_lexem s =
let string_of_float f = valid_float_lexem (format_float "%.12g" f);;
-external float_of_string : string -> float = "caml_float_of_string"
+external float_of_string : string -> float = "caml_float_of_string_r" "reentrant"
(* List operations -- more in module List *)
@@ -231,16 +232,16 @@ let stderr = open_descriptor_out 2
(* Non-blocking stuff *)
-external thread_wait_read_prim : Unix.file_descr -> unit = "thread_wait_read"
-external thread_wait_write_prim : Unix.file_descr -> unit = "thread_wait_write"
+external thread_wait_read_prim : Unix.file_descr -> unit = "thread_wait_read_r" "reentrant"
+external thread_wait_write_prim : Unix.file_descr -> unit = "thread_wait_write_r" "reentrant"
let thread_wait_read fd = thread_wait_read_prim fd
let thread_wait_write fd = thread_wait_write_prim fd
external descr_inchan : in_channel -> Unix.file_descr
- = "caml_channel_descriptor"
+ = "caml_channel_descriptor_r" "reentrant"
external descr_outchan : out_channel -> Unix.file_descr
- = "caml_channel_descriptor"
+ = "caml_channel_descriptor_r" "reentrant"
let wait_inchan ic = thread_wait_read (descr_inchan ic)
@@ -253,7 +254,7 @@ type open_flag =
| Open_creat | Open_trunc | Open_excl
| Open_binary | Open_text | Open_nonblock
-external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
+external open_desc: string -> open_flag list -> int -> int = "caml_sys_open_r" "reentrant"
let open_out_gen mode perm name =
open_descriptor_out(open_desc name mode perm)
@@ -264,7 +265,7 @@ let open_out name =
let open_out_bin name =
open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
-external flush_partial : out_channel -> bool = "caml_ml_flush_partial"
+external flush_partial : out_channel -> bool = "caml_ml_flush_partial_r" "reentrant"
let rec flush oc =
let success =
@@ -275,7 +276,7 @@ let rec flush oc =
if success then () else flush oc
external out_channels_list : unit -> out_channel list
- = "caml_ml_out_channels_list"
+ = "caml_ml_out_channels_list_r" "reentrant"
let flush_all () =
let rec iter = function
@@ -290,7 +291,7 @@ let flush_all () =
in iter (out_channels_list ())
external unsafe_output_partial : out_channel -> string -> int -> int -> int
- = "caml_ml_output_partial"
+ = "caml_ml_output_partial_r" "reentrant"
let rec unsafe_output oc buf pos len =
if len > 0 then begin
@@ -303,9 +304,9 @@ let rec unsafe_output oc buf pos len =
end
external output_char_blocking : out_channel -> char -> unit
- = "caml_ml_output_char"
+ = "caml_ml_output_char_r" "reentrant"
external output_byte_blocking : out_channel -> int -> unit
- = "caml_ml_output_char"
+ = "caml_ml_output_char_r" "reentrant"
let rec output_char oc c =
try
@@ -336,17 +337,17 @@ let output_binary_int oc n =
output_byte oc n
external marshal_to_string : 'a -> unit list -> string
- = "caml_output_value_to_string"
+ = "caml_output_value_to_string_r" "reentrant"
let output_value oc v = output_string oc (marshal_to_string v [])
-external seek_out_blocking : out_channel -> int -> unit = "caml_ml_seek_out"
+external seek_out_blocking : out_channel -> int -> unit = "caml_ml_seek_out_r" "reentrant"
let seek_out oc pos = flush oc; seek_out_blocking oc pos
-external pos_out : out_channel -> int = "caml_ml_pos_out"
-external out_channel_length : out_channel -> int = "caml_ml_channel_size"
-external close_out_channel : out_channel -> unit = "caml_ml_close_channel"
+external pos_out : out_channel -> int = "caml_ml_pos_out_r" "reentrant"
+external out_channel_length : out_channel -> int = "caml_ml_channel_size_r" "reentrant"
+external close_out_channel : out_channel -> unit = "caml_ml_close_channel_r" "reentrant"
let close_out oc = (try flush oc with _ -> ()); close_out_channel oc
let close_out_noerr oc =
@@ -438,8 +439,8 @@ let input_binary_int ic =
let b4 = input_byte ic in
(n1 lsl 24) + (b2 lsl 16) + (b3 lsl 8) + b4
-external unmarshal : string -> int -> 'a = "caml_input_value_from_string"
-external marshal_data_size : string -> int -> int = "caml_marshal_data_size"
+external unmarshal : string -> int -> 'a = "caml_input_value_from_string_r" "reentrant"
+external marshal_data_size : string -> int -> int = "caml_marshal_data_size_r" "reentrant"
let input_value ic =
let header = string_create 20 in
@@ -450,10 +451,10 @@ let input_value ic =
really_input ic buffer 20 bsize;
unmarshal buffer 0
-external seek_in : in_channel -> int -> unit = "caml_ml_seek_in"
-external pos_in : in_channel -> int = "caml_ml_pos_in"
-external in_channel_length : in_channel -> int = "caml_ml_channel_size"
-external close_in : in_channel -> unit = "caml_ml_close_channel"
+external seek_in : in_channel -> int -> unit = "caml_ml_seek_in_r" "reentrant"
+external pos_in : in_channel -> int = "caml_ml_pos_in_r" "reentrant"
+external in_channel_length : in_channel -> int = "caml_ml_channel_size_r" "reentrant"
+external close_in : in_channel -> unit = "caml_ml_close_channel_r" "reentrant"
let close_in_noerr ic = (try close_in ic with _ -> ());;
external set_binary_mode_in : in_channel -> bool -> unit
= "caml_ml_set_binary_mode"
@@ -488,13 +489,13 @@ let read_float () = float_of_string(read_line())
module LargeFile =
struct
- external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64"
- external pos_out : out_channel -> int64 = "caml_ml_pos_out_64"
+ external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64_r" "reentrant"
+ external pos_out : out_channel -> int64 = "caml_ml_pos_out_64_r" "reentrant"
external out_channel_length : out_channel -> int64
- = "caml_ml_channel_size_64"
- external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64"
- external pos_in : in_channel -> int64 = "caml_ml_pos_in_64"
- external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64"
+ = "caml_ml_channel_size_64_r" "reentrant"
+ external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64_r" "reentrant"
+ external pos_in : in_channel -> int64 = "caml_ml_pos_in_64_r" "reentrant"
+ external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64_r" "reentrant"
end
(* Formats *)
@@ -528,7 +529,7 @@ let string_of_format fmt =
(* Miscellaneous *)
-external sys_exit : int -> 'a = "caml_sys_exit"
+external sys_exit : int -> 'a = "caml_sys_exit_r" "reentrant"
let exit_function = ref flush_all
@@ -543,6 +544,6 @@ let exit retcode =
sys_exit retcode
external register_named_value : string -> 'a -> unit
- = "caml_register_named_value"
+ = "caml_register_named_value_r" "reentrant"
let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
View
209 otherlibs/threads/scheduler.c
@@ -19,6 +19,14 @@
#include <stdlib.h>
#include <stdio.h>
+#define CAML_CONTEXT_ROOTS
+#define CAML_CONTEXT_STACKS
+#define CAML_CONTEXT_BACKTRACE
+#define CAML_CONTEXT_CALLBACK
+#define CAML_CONTEXT_SIGNALS_BYT
+#include "context.h"
+
+
#include "alloc.h"
#include "backtrace.h"
#include "callback.h"
@@ -126,23 +134,24 @@ static caml_thread_t curr_thread = NULL;
/* Identifier for next thread creation */
static value next_ident = Val_int(0);
-#define Assign(dst,src) modify((value *)&(dst), (value)(src))
+#define Assign(dst,src) caml_modify_r(ctx, (value *)&(dst), (value)(src))
/* Scan the stacks of the other threads */
static void (*prev_scan_roots_hook) (scanning_action);
static void thread_scan_roots(scanning_action action)
{
+ INIT_CAML_R;
caml_thread_t th, start;
/* Scan all active descriptors */
start = curr_thread;
- (*action)((value) curr_thread, (value *) &curr_thread);
+ (*action)(ctx, (value) curr_thread, (value *) &curr_thread);
/* Don't scan curr_thread->sp, this has already been done.
Don't scan local roots either, for the same reason. */
for (th = start->next; th != start; th = th->next) {
- do_local_roots(action, th->sp, th->stack_high, NULL);
+ caml_do_local_roots_r(ctx, action, th->sp, th->stack_high, NULL);
}
/* Hook */
if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action);
@@ -155,26 +164,25 @@ static void thread_restore_std_descr(void);
/* Initialize the thread machinery */
-value thread_initialize(value unit) /* ML */
+value thread_initialize_r(CAML_R, value unit) /* ML */
{
/* Protect against repeated initialization (PR#1325) */
if (curr_thread != NULL) return Val_unit;
/* Create a descriptor for the current thread */
curr_thread =
- (caml_thread_t) alloc_shr(sizeof(struct caml_thread_struct)
- / sizeof(value), 0);
+ (caml_thread_t) caml_alloc_shr_r(ctx, sizeof(struct caml_thread_struct) / sizeof(value), 0);
curr_thread->ident = next_ident;
next_ident = Val_int(Int_val(next_ident) + 1);
curr_thread->next = curr_thread;
curr_thread->prev = curr_thread;
- curr_thread->stack_low = stack_low;
- curr_thread->stack_high = stack_high;
- curr_thread->stack_threshold = stack_threshold;
- curr_thread->sp = extern_sp;
- curr_thread->trapsp = trapsp;
- curr_thread->backtrace_pos = Val_int(backtrace_pos);
- curr_thread->backtrace_buffer = backtrace_buffer;
- caml_initialize (&curr_thread->backtrace_last_exn, backtrace_last_exn);
+ curr_thread->stack_low = caml_stack_low;
+ curr_thread->stack_high = caml_stack_high;
+ curr_thread->stack_threshold = caml_stack_threshold;
+ curr_thread->sp = caml_extern_sp;
+ curr_thread->trapsp = caml_trapsp;
+ curr_thread->backtrace_pos = Val_int(caml_backtrace_pos);
+ curr_thread->backtrace_buffer = caml_backtrace_buffer;
+ caml_initialize_r(ctx, &curr_thread->backtrace_last_exn, caml_backtrace_last_exn);
curr_thread->status = RUNNABLE;
curr_thread->fd = Val_int(0);
curr_thread->readfds = NO_FDS;
@@ -204,7 +212,7 @@ value thread_initialize(value unit) /* ML */
/* Initialize the interval timer used for preemption */
-value thread_initialize_preemption(value unit) /* ML */
+value thread_initialize_preemption_r(CAML_R, value unit) /* ML */
{
struct itimerval timer;
@@ -217,12 +225,12 @@ value thread_initialize_preemption(value unit) /* ML */
/* Create a thread */
-value thread_new(value clos) /* ML */
+value thread_new_r(CAML_R, value clos) /* ML */
{
caml_thread_t th;
/* Allocate the thread and its stack */
Begin_root(clos);
- th = (caml_thread_t) alloc_shr(sizeof(struct caml_thread_struct)
+ th = (caml_thread_t) caml_alloc_shr_r(ctx, sizeof(struct caml_thread_struct)
/ sizeof(value), 0);
End_roots();
th->ident = next_ident;
@@ -287,13 +295,13 @@ static double timeofday(void)
#define FOREACH_THREAD(x) x = curr_thread; do { x = x->next;
#define END_FOREACH(x) } while (x != curr_thread)
-static value alloc_process_status(int pid, int status);
+static value alloc_process_status_r(CAML_R, int pid, int status);
static void add_fdlist_to_set(value fdl, fd_set *set);
-static value inter_fdlist_set(value fdl, fd_set *set, int *count);
+static value inter_fdlist_set_r(CAML_R, value fdl, fd_set *set, int *count);
static void find_bad_fd(int fd, fd_set *set);
static void find_bad_fds(value fdl, fd_set *set);
-static value schedule_thread(void)
+static value schedule_thread_r(CAML_R)
{
caml_thread_t run_thread, th;
fd_set readfds, writefds, exceptfds;
@@ -304,14 +312,14 @@ static value schedule_thread(void)
if (callback_depth > 1) return curr_thread->retval;
/* Save the status of the current thread */
- curr_thread->stack_low = stack_low;
- curr_thread->stack_high = stack_high;
- curr_thread->stack_threshold = stack_threshold;
- curr_thread->sp = extern_sp;
- curr_thread->trapsp = trapsp;
- curr_thread->backtrace_pos = Val_int(backtrace_pos);
- curr_thread->backtrace_buffer = backtrace_buffer;
- caml_modify (&curr_thread->backtrace_last_exn, backtrace_last_exn);
+ curr_thread->stack_low = caml_stack_low;
+ curr_thread->stack_high = caml_stack_high;
+ curr_thread->stack_threshold = caml_stack_threshold;
+ curr_thread->sp = caml_extern_sp;
+ curr_thread->trapsp = caml_trapsp;
+ curr_thread->backtrace_pos = Val_int(caml_backtrace_pos);
+ curr_thread->backtrace_buffer = caml_backtrace_buffer;
+ caml_modify_r (ctx, &curr_thread->backtrace_last_exn, caml_backtrace_last_exn);
try_again:
/* Find if a thread is runnable.
@@ -365,7 +373,7 @@ static value schedule_thread(void)
pid = waitpid(Int_val(th->waitpid), &status, WNOHANG);
if (pid > 0) {
th->status = RUNNABLE;
- Assign(th->retval, alloc_process_status(pid, status));
+ Assign(th->retval, alloc_process_status_r(ctx, pid, status));
} else {
need_wait = 1;
}
@@ -401,9 +409,9 @@ static value schedule_thread(void)
else {
delay_ptr = NULL;
}
- enter_blocking_section();
+ caml_enter_blocking_section_r(ctx);
retcode = select(FD_SETSIZE, &readfds, &writefds, &exceptfds, delay_ptr);
- leave_blocking_section();
+ caml_leave_blocking_section_r(ctx);
if (retcode == -1)
switch (errno) {
case EINTR:
@@ -428,7 +436,7 @@ static value schedule_thread(void)
retcode = FD_SETSIZE;
break;
default:
- sys_error(NO_ARG);
+ caml_sys_error_r(ctx, NO_ARG);
}
if (retcode > 0) {
/* Some descriptors are ready.
@@ -456,11 +464,11 @@ static value schedule_thread(void)
if (th->status & (BLOCKED_SELECT - 1)) {
value r = Val_unit, w = Val_unit, e = Val_unit;
Begin_roots3(r,w,e)
- r = inter_fdlist_set(th->readfds, &readfds, &retcode);
- w = inter_fdlist_set(th->writefds, &writefds, &retcode);
- e = inter_fdlist_set(th->exceptfds, &exceptfds, &retcode);
+ r = inter_fdlist_set_r(ctx, th->readfds, &readfds, &retcode);
+ w = inter_fdlist_set_r(ctx, th->writefds, &writefds, &retcode);
+ e = inter_fdlist_set_r(ctx, th->exceptfds, &exceptfds, &retcode);
if (r != NO_FDS || w != NO_FDS || e != NO_FDS) {
- value retval = alloc_small(3, TAG_RESUMED_SELECT);
+ value retval = caml_alloc_small_r(ctx, 3, TAG_RESUMED_SELECT);
Field(retval, 0) = r;
Field(retval, 1) = w;
Field(retval, 2) = e;
@@ -485,7 +493,7 @@ static value schedule_thread(void)
}
/* If we haven't something to run at that point, we're in big trouble. */
- if (run_thread == NULL) invalid_argument("Thread: deadlock");
+ if (run_thread == NULL) caml_invalid_argument_r(ctx, "Thread: deadlock");
/* Free everything the thread was waiting on */
Assign(run_thread->readfds, NO_FDS);
@@ -497,39 +505,40 @@ static value schedule_thread(void)
/* Activate the thread */
curr_thread = run_thread;
- stack_low = curr_thread->stack_low;
- stack_high = curr_thread->stack_high;
- stack_threshold = curr_thread->stack_threshold;
- extern_sp = curr_thread->sp;
- trapsp = curr_thread->trapsp;
- backtrace_pos = Int_val(curr_thread->backtrace_pos);
- backtrace_buffer = curr_thread->backtrace_buffer;
- backtrace_last_exn = curr_thread->backtrace_last_exn;
+ caml_stack_low = curr_thread->stack_low;
+ caml_stack_high = curr_thread->stack_high;
+ caml_stack_threshold = curr_thread->stack_threshold;
+ caml_extern_sp = curr_thread->sp;
+ caml_trapsp = curr_thread->trapsp;
+ caml_backtrace_pos = Int_val(curr_thread->backtrace_pos);
+ caml_backtrace_buffer = curr_thread->backtrace_buffer;
+ caml_backtrace_last_exn = curr_thread->backtrace_last_exn;
return curr_thread->retval;
}
/* Since context switching is not allowed in callbacks, a thread that
blocks during a callback is a deadlock. */
-static void check_callback(void)
+static void check_callback_r(CAML_R)
{
- if (callback_depth > 1)
+ if (caml_callback_depth > 1)
caml_fatal_error("Thread: deadlock during callback");
}
/* Reschedule without suspending the current thread */
-value thread_yield(value unit) /* ML */
+value thread_yield_r(CAML_R, value unit) /* ML */
{
Assert(curr_thread != NULL);
Assign(curr_thread->retval, Val_unit);
- return schedule_thread();
+ return schedule_thread_r(ctx);
}
/* Honor an asynchronous request for re-scheduling */
-static void thread_reschedule(void)
+static void thread_reschedule(void) /* Don't change the prototype: this is used as a hook --Luca Saiu REENTRANTRUNTIME */
{
+ INIT_CAML_R;
value accu;
Assert(curr_thread != NULL);
@@ -538,41 +547,41 @@ static void thread_reschedule(void)
accu = *extern_sp++;
/* Reschedule */
Assign(curr_thread->retval, accu);
- accu = schedule_thread();
+ accu = schedule_thread_r(ctx);
/* Push accu below C_CALL frame so that it looks like an event frame */
*--extern_sp = accu;
}
/* Request a re-scheduling as soon as possible */
-value thread_request_reschedule(value unit) /* ML */
+value thread_request_reschedule_r(CAML_R, value unit) /* ML */
{
- async_action_hook = thread_reschedule;
- something_to_do = 1;
+ caml_async_action_hook = thread_reschedule;
+ caml_something_to_do = 1;
return Val_unit;
}
/* Suspend the current thread */
-value thread_sleep(value unit) /* ML */
+value thread_sleep_r(CAML_R, value unit) /* ML */
{
Assert(curr_thread != NULL);
- check_callback();
+ check_callback_r(ctx);
curr_thread->status = SUSPENDED;
- return schedule_thread();
+ return schedule_thread_r(ctx);
}
/* Suspend the current thread on a read() or write() request */
-static value thread_wait_rw(int kind, value fd)
+static value thread_wait_rw_r(CAML_R, int kind, value fd)
{
/* Don't do an error if we're not initialized yet
(we can be called from thread-safe Pervasives before initialization),
just return immediately. */
if (curr_thread == NULL) return RESUMED_WAKEUP;
/* As a special case, if we're in a callback, don't fail but block
the whole process till I/O is possible */
- if (callback_depth > 1) {
+ if (caml_callback_depth > 1) {
fd_set fds;
FD_ZERO(&fds);
FD_SET(Int_val(fd), &fds);
@@ -584,62 +593,62 @@ static value thread_wait_rw(int kind, value fd)
} else {
curr_thread->fd = fd;
curr_thread->status = kind;
- return schedule_thread();
+ return schedule_thread_r(ctx);
}
}
-value thread_wait_read(value fd)
+value thread_wait_read_r(CAML_R, value fd) /* ML */
{
- return thread_wait_rw(BLOCKED_READ, fd);
+ return thread_wait_rw_r(ctx, BLOCKED_READ, fd);
}
-value thread_wait_write(value fd)
+value thread_wait_write_r(CAML_R, value fd) /* ML */
{
- return thread_wait_rw(BLOCKED_WRITE, fd);
+ return thread_wait_rw_r(ctx, BLOCKED_WRITE, fd);
}
/* Suspend the current thread on a read() or write() request with timeout */
-static value thread_wait_timed_rw(int kind, value arg)
+static value thread_wait_timed_rw_r(CAML_R, int kind, value arg)
{
double date;
- check_callback();
+ check_callback_r(ctx);
curr_thread->fd = Field(arg, 0);
date = timeofday() + Double_val(Field(arg, 1));
- Assign(curr_thread->delay, copy_double(date));
+ Assign(curr_thread->delay, caml_copy_double_r(ctx, date));
curr_thread->status = kind | BLOCKED_DELAY;
- return schedule_thread();
+ return schedule_thread_r(ctx);
}
-value thread_wait_timed_read(value arg)
+value thread_wait_timed_read_r(CAML_R, value arg) /* ML */
{
- return thread_wait_timed_rw(BLOCKED_READ, arg);
+ return thread_wait_timed_rw_r(ctx, BLOCKED_READ, arg);
}
-value thread_wait_timed_write(value arg)
+value thread_wait_timed_write_r(CAML_R, value arg) /* ML */
{
- return thread_wait_timed_rw(BLOCKED_WRITE, arg);
+ return thread_wait_timed_rw_r(ctx, BLOCKED_WRITE, arg);
}
/* Suspend the current thread on a select() request */
-value thread_select(value arg) /* ML */
+value thread_select_r(CAML_R, value arg) /* ML */
{
double date;
- check_callback();
+ check_callback_r(ctx);
Assign(curr_thread->readfds, Field(arg, 0));
Assign(curr_thread->writefds, Field(arg, 1));
Assign(curr_thread->exceptfds, Field(arg, 2));
date = Double_val(Field(arg, 3));
if (date >= 0.0) {
date += timeofday();
- Assign(curr_thread->delay, copy_double(date));
+ Assign(curr_thread->delay, caml_copy_double_r(ctx, date));
curr_thread->status = BLOCKED_SELECT | BLOCKED_DELAY;
} else {
curr_thread->status = BLOCKED_SELECT;
}
- return schedule_thread();
+ return schedule_thread_r(ctx);
}
/* Primitives to implement suspension on buffered channels */
@@ -668,42 +677,42 @@ value thread_outchan_ready(value vchan, value vsize) /* ML */
/* Suspend the current thread for some time */
-value thread_delay(value time) /* ML */
+value thread_delay_r(CAML_R, value time) /* ML */
{
double date = timeofday() + Double_val(time);
Assert(curr_thread != NULL);
- check_callback();
+ check_callback_r(ctx);
curr_thread->status = BLOCKED_DELAY;
- Assign(curr_thread->delay, copy_double(date));
- return schedule_thread();
+ Assign(curr_thread->delay, caml_copy_double_r(ctx, date));
+ return schedule_thread_r(ctx);
}
/* Suspend the current thread until another thread terminates */
-value thread_join(value th) /* ML */
+value thread_join_r(CAML_R, value th) /* ML */
{
- check_callback();
+ check_callback_r(ctx);
Assert(curr_thread != NULL);
if (((caml_thread_t)th)->status == KILLED) return Val_unit;
curr_thread->status = BLOCKED_JOIN;
Assign(curr_thread->joining, th);
- return schedule_thread();
+ return schedule_thread_r(ctx);
}
/* Suspend the current thread until a Unix process exits */
-value thread_wait_pid(value pid) /* ML */
+value thread_wait_pid_r(CAML_R, value pid) /* ML */
{
Assert(curr_thread != NULL);
- check_callback();
+ check_callback_r(ctx);
curr_thread->status = BLOCKED_WAIT;
curr_thread->waitpid = pid;
- return schedule_thread();
+ return schedule_thread_r(ctx);
}
/* Reactivate another thread */
-value thread_wakeup(value thread) /* ML */
+value thread_wakeup_r(CAML_R, value thread) /* ML */
{
caml_thread_t th = (caml_thread_t) thread;
switch (th->status) {
@@ -721,15 +730,15 @@ value thread_wakeup(value thread) /* ML */
/* Return the current thread */
-value thread_self(value unit) /* ML */
+value thread_self_r(CAML_R, value unit) /* ML */
{
Assert(curr_thread != NULL);
return (value) curr_thread;
}
/* Kill a thread */
-value thread_kill(value thread) /* ML */
+value thread_kill_r(CAML_R, value thread) /* ML */
{
value retval = Val_unit;
caml_thread_t th = (caml_thread_t) thread;
@@ -741,7 +750,7 @@ value thread_kill(value thread) /* ML */
/* If this is the current thread, activate another one */
if (th == curr_thread) {
Begin_root(thread);
- retval = schedule_thread();
+ retval = schedule_thread_r(ctx);
th = (caml_thread_t) thread;
End_roots();
}
@@ -764,13 +773,13 @@ value thread_kill(value thread) /* ML */
/* Print uncaught exception and backtrace */
-value thread_uncaught_exception(value exn) /* ML */
+value thread_uncaught_exception_r(CAML_R, value exn) /* ML */
{
- char * msg = format_caml_exception(exn);
+ char * msg = caml_format_exception_r(ctx, exn);
fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
Int_val(curr_thread->ident), msg);
free(msg);
- if (backtrace_active) print_exception_backtrace();
+ if (backtrace_active) caml_print_exception_backtrace_r(ctx);
fflush(stderr);
return Val_unit;
}
@@ -789,7 +798,7 @@ static void add_fdlist_to_set(value fdl, fd_set *set)
/* Build the intersection of a list and a fdset (the list of file descriptors
which are both in the list and in the fdset). */
-static value inter_fdlist_set(value fdl, fd_set *set, int *count)
+static value inter_fdlist_set_r(CAML_R, value fdl, fd_set *set, int *count)
{
value res = Val_unit;
value cons;
@@ -798,7 +807,7 @@ static value inter_fdlist_set(value fdl, fd_set *set, int *count)
for (res = NO_FDS; fdl != NO_FDS; fdl = Field(fdl, 1)) {
int fd = Int_val(Field(fdl, 0));
if (FD_ISSET(fd, set)) {
- cons = alloc_small(2, 0);
+ cons = caml_alloc_small_r(ctx, 2, 0);
Field(cons, 0) = Val_int(fd);
Field(cons, 1) = res;
res = cons;
@@ -842,24 +851,24 @@ static void find_bad_fds(value fdl, fd_set *set)
#define TAG_WSIGNALED 1
#define TAG_WSTOPPED 2
-static value alloc_process_status(int pid, int status)
+static value alloc_process_status_r(CAML_R, int pid, int status)
{
value st, res;
if (WIFEXITED(status)) {
- st = alloc_small(1, TAG_WEXITED);
+ st = caml_alloc_small_r(ctx, 1, TAG_WEXITED);
Field(st, 0) = Val_int(WEXITSTATUS(status));
}
else if (WIFSTOPPED(status)) {
- st = alloc_small(1, TAG_WSTOPPED);
+ st = caml_alloc_small_r(ctx, 1, TAG_WSTOPPED);
Field(st, 0) = Val_int(WSTOPSIG(status));
}
else {
- st = alloc_small(1, TAG_WSIGNALED);
+ st = caml_alloc_small_r(ctx, 1, TAG_WSIGNALED);
Field(st, 0) = Val_int(WTERMSIG(status));
}
Begin_root(st);
- res = alloc_small(2, TAG_RESUMED_WAIT);
+ res = caml_alloc_small_r(ctx, 2, TAG_RESUMED_WAIT);
Field(res, 0) = Val_int(pid);
Field(res, 1) = st;
End_roots();
View
36 otherlibs/threads/thread.ml
@@ -43,31 +43,31 @@ let _ = [Resumed_wakeup; Resumed_delay; Resumed_join;
frame size, which means that both the primitives and their ML wrappers
must take exactly one argument. *)
-external thread_initialize : unit -> unit = "thread_initialize"
-external thread_initialize_preemption : unit -> unit = "thread_initialize_preemption"
-external thread_new : (unit -> unit) -> t = "thread_new"
-external thread_yield : unit -> unit = "thread_yield"
-external thread_request_reschedule : unit -> unit = "thread_request_reschedule"
-external thread_sleep : unit -> unit = "thread_sleep"
-external thread_wait_read : Unix.file_descr -> unit = "thread_wait_read"
-external thread_wait_write : Unix.file_descr -> unit = "thread_wait_write"
+external thread_initialize : unit -> unit = "thread_initialize_r" "reentrant"
+external thread_initialize_preemption : unit -> unit = "thread_initialize_preemption_r" "reentrant"
+external thread_new : (unit -> unit) -> t = "thread_new_r" "reentrant"
+external thread_yield : unit -> unit = "thread_yield_r" "reentrant"
+external thread_request_reschedule : unit -> unit = "thread_request_reschedule_r" "reentrant"
+external thread_sleep : unit -> unit = "thread_sleep_r" "reentrant"
+external thread_wait_read : Unix.file_descr -> unit = "thread_wait_read_r" "reentrant"
+external thread_wait_write : Unix.file_descr -> unit = "thread_wait_write_r" "reentrant"
external thread_wait_timed_read :
Unix.file_descr * float -> resumption_status (* remember: 1 arg *)
- = "thread_wait_timed_read"
+ = "thread_wait_timed_read_r" "reentrant"
external thread_wait_timed_write :
Unix.file_descr * float -> resumption_status (* remember: 1 arg *)
- = "thread_wait_timed_write"
+ = "thread_wait_timed_write_r" "reentrant"
external thread_select :
Unix.file_descr list * Unix.file_descr list * (* remember: 1 arg *)
Unix.file_descr list * float -> resumption_status
- = "thread_select"
-external thread_join : t -> unit = "thread_join"
-external thread_delay : float -> unit = "thread_delay"
-external thread_wait_pid : int -> resumption_status = "thread_wait_pid"
-external thread_wakeup : t -> unit = "thread_wakeup"
-external thread_self : unit -> t = "thread_self"
-external thread_kill : t -> unit = "thread_kill"
-external thread_uncaught_exception : exn -> unit = "thread_uncaught_exception"
+ = "thread_select_r" "reentrant"
+external thread_join : t -> unit = "thread_join_r" "reentrant"
+external thread_delay : float -> unit = "thread_delay_r" "reentrant"
+external thread_wait_pid : int -> resumption_status = "thread_wait_pid_r" "reentrant"
+external thread_wakeup : t -> unit = "thread_wakeup_r" "reentrant"
+external thread_self : unit -> t = "thread_self_r" "reentrant"
+external thread_kill : t -> unit = "thread_kill_r" "reentrant"
+external thread_uncaught_exception : exn -> unit = "thread_uncaught_exception_r" "reentrant"
external id : t -> int = "thread_id"
View
264 otherlibs/threads/unix.ml
@@ -41,15 +41,15 @@ let _ = [Resumed_wakeup; Resumed_delay; Resumed_join;
Resumed_io; Resumed_select ([], [], []);
Resumed_wait (0, WEXITED 0)]
-external thread_initialize : unit -> unit = "thread_initialize"
-external thread_wait_read : file_descr -> unit = "thread_wait_read"
-external thread_wait_write : file_descr -> unit = "thread_wait_write"
+external thread_initialize : unit -> unit = "thread_initialize_r" "reentrant"
+external thread_wait_read : file_descr -> unit = "thread_wait_read_r" "reentrant"
+external thread_wait_write : file_descr -> unit = "thread_wait_write_r" "reentrant"
external thread_select :
file_descr list * file_descr list * file_descr list * float
-> resumption_status
- = "thread_select"
-external thread_wait_pid : int -> resumption_status = "thread_wait_pid"
-external thread_delay : float -> unit = "thread_delay"
+ = "thread_select_r" "reentrant"
+external thread_wait_pid : int -> resumption_status = "thread_wait_pid_r" "reentrant"
+external thread_delay : float -> unit = "thread_delay_r" "reentrant"
let wait_read fd = thread_wait_read fd
let wait_write fd = thread_wait_write fd
@@ -139,7 +139,7 @@ exception Unix_error of error * string * string
let _ = Callback.register_exception "Unix.Unix_error"
(Unix_error(E2BIG, "", ""))
-external error_message : error -> string = "unix_error_message"
+external error_message : error -> string = "unix_error_message_r" "reentrant"
let handle_unix_error f arg =
try
@@ -158,9 +158,9 @@ let handle_unix_error f arg =
prerr_endline (error_message err);
exit 2
-external environment : unit -> string array = "unix_environment"
-external getenv: string -> string = "caml_sys_getenv"
-external putenv: string -> string -> unit = "unix_putenv"
+external environment : unit -> string array = "unix_environment_r" "reentrant"
+external getenv: string -> string = "caml_sys_getenv_r" "reentrant"
+external putenv: string -> string -> unit = "unix_putenv_r" "reentrant"
type interval_timer =
ITIMER_REAL
@@ -171,10 +171,10 @@ type interval_timer_status =
{ it_interval: float; (* Period *)
it_value: float } (* Current value of the timer *)
-external getitimer: interval_timer -> interval_timer_status = "unix_getitimer"
+external getitimer: interval_timer -> interval_timer_status = "unix_getitimer_r" "reentrant"
external setitimer:
interval_timer -> interval_timer_status -> interval_timer_status
- = "unix_setitimer"
+ = "unix_setitimer_r" "reentrant"
type wait_flag =
WNOHANG
@@ -203,14 +203,14 @@ type file_perm = int
external openfile : string -> open_flag list -> file_perm -> file_descr
- = "unix_open"
+ = "unix_open_r" "reentrant"
-external close : file_descr -> unit = "unix_close"
-external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read"
+external close : file_descr -> unit = "unix_close_r" "reentrant"
+external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read_r" "reentrant"
external unsafe_write : file_descr -> string -> int -> int -> int
- = "unix_write"
+ = "unix_write_r" "reentrant"
external unsafe_single_write : file_descr -> string -> int -> int -> int
- = "unix_single_write"
+ = "unix_single_write_r" "reentrant"
let rec read fd buf ofs len =
try
@@ -239,20 +239,20 @@ let rec single_write fd buf ofs len =
external in_channel_of_descr : file_descr -> in_channel
= "caml_ml_open_descriptor_in_r" "reentrant"
external out_channel_of_descr : file_descr -> out_channel
- = "caml_ml_open_descriptor_out"
+ = "caml_ml_open_descriptor_out_r" "reentrant"
external descr_of_in_channel : in_channel -> file_descr
- = "caml_channel_descriptor"
+ = "caml_channel_descriptor_r" "reentrant"
external descr_of_out_channel : out_channel -> file_descr
- = "caml_channel_descriptor"
+ = "caml_channel_descriptor_r" "reentrant"
type seek_command =
SEEK_SET
| SEEK_CUR
| SEEK_END
-external lseek : file_descr -> int -> seek_command -> int = "unix_lseek"
-external truncate : string -> int -> unit = "unix_truncate"
-external ftruncate : file_descr -> int -> unit = "unix_ftruncate"
+external lseek : file_descr -> int -> seek_command -> int = "unix_lseek_r" "reentrant"
+external truncate : string -> int -> unit = "unix_truncate_r" "reentrant"
+external ftruncate : file_descr -> int -> unit = "unix_ftruncate_r" "reentrant"
type file_kind =
S_REG
@@ -277,20 +277,20 @@ type stats =
st_mtime : float;
st_ctime : float }
-external stat : string -> stats = "unix_stat"
-external lstat : string -> stats = "unix_lstat"
-external fstat : file_descr -> stats = "unix_fstat"
-external isatty : file_descr -> bool = "unix_isatty"
-external unlink : string -> unit = "unix_unlink"
-external rename : string -> string -> unit = "unix_rename"
-external link : string -> string -> unit = "unix_link"
+external stat : string -> stats = "unix_stat_r" "reentrant"
+external lstat : string -> stats = "unix_lstat_r" "reentrant"
+external fstat : file_descr -> stats = "unix_fstat_r" "reentrant"
+external isatty : file_descr -> bool = "unix_isatty_r" "reentrant"
+external unlink : string -> unit = "unix_unlink_r" "reentrant"
+external rename : string -> string -> unit = "unix_rename_r" "reentrant"
+external link : string -> string -> unit = "unix_link_r" "reentrant"
module LargeFile =
struct
external lseek : file_descr -> int64 -> seek_command -> int64
- = "unix_lseek_64"
- external truncate : string -> int64 -> unit = "unix_truncate_64"
- external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64"
+ = "unix_lseek_64_r" "reentrant"
+ external truncate : string -> int64 -> unit = "unix_truncate_64_r" "reentrant"
+ external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64_r" "reentrant"
type stats =
{ st_dev : int;
st_ino : int;
@@ -305,9 +305,9 @@ module LargeFile =
st_mtime : float;
st_ctime : float;
}
- external stat : string -> stats = "unix_stat_64"
- external lstat : string -> stats = "unix_lstat_64"
- external fstat : file_descr -> stats = "unix_fstat_64"
+ external stat : string -> stats = "unix_stat_64_r" "reentrant"
+ external lstat : string -> stats = "unix_lstat_64_r" "reentrant"
+ external fstat : file_descr -> stats = "unix_fstat_64_r" "reentrant"
end
type access_permission =
@@ -316,44 +316,44 @@ type access_permission =
| X_OK
| F_OK
-external chmod : string -> file_perm -> unit = "unix_chmod"
-external fchmod : file_descr -> file_perm -> unit = "unix_fchmod"
-external chown : string -> int -> int -> unit = "unix_chown"
-external fchown : file_descr -> int -> int -> unit = "unix_fchown"
-external umask : int -> int = "unix_umask"
-external access : string -> access_permission list -> unit = "unix_access"
-
-external dup : file_descr -> file_descr = "unix_dup"
-external dup2 : file_descr -> file_descr -> unit = "unix_dup2"
-external set_nonblock : file_descr -> unit = "unix_set_nonblock"
-external clear_nonblock : file_descr -> unit = "unix_clear_nonblock"
-external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec"
-external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec"
-
-external mkdir : string -> file_perm -> unit = "unix_mkdir"
-external rmdir : string -> unit = "unix_rmdir"
-external chdir : string -> unit = "unix_chdir"
-external getcwd : unit -> string = "unix_getcwd"
-external chroot : string -> unit = "unix_chroot"
+external chmod : string -> file_perm -> unit = "unix_chmod_r" "reentrant"
+external fchmod : file_descr -> file_perm -> unit = "unix_fchmod_r" "reentrant"
+external chown : string -> int -> int -> unit = "unix_chown_r" "reentrant"
+external fchown : file_descr -> int -> int -> unit = "unix_fchown_r" "reentrant"
+external umask : int -> int = "unix_umask_r" "reentrant"
+external access : string -> access_permission list -> unit = "unix_access_r" "reentrant"
+
+external dup : file_descr -> file_descr = "unix_dup_r" "reentrant"
+external dup2 : file_descr -> file_descr -> unit = "unix_dup2_r" "reentrant"
+external set_nonblock : file_descr -> unit = "unix_set_nonblock_r" "reentrant"
+external clear_nonblock : file_descr -> unit = "unix_clear_nonblock_r" "reentrant"
+external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec_r" "reentrant"
+external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec_r" "reentrant"
+
+external mkdir : string -> file_perm -> unit = "unix_mkdir_r" "reentrant"
+external rmdir : string -> unit = "unix_rmdir_r" "reentrant"
+external chdir : string -> unit = "unix_chdir_r" "reentrant"
+external getcwd : unit -> string = "unix_getcwd_r" "reentrant"
+external chroot : string -> unit = "unix_chroot_r" "reentrant"
type dir_handle
-external opendir : string -> dir_handle = "unix_opendir"
-external readdir : dir_handle -> string = "unix_readdir"
-external rewinddir : dir_handle -> unit = "unix_rewinddir"
-external closedir : dir_handle -> unit = "unix_closedir"
+external opendir : string -> dir_handle = "unix_opendir_r" "reentrant"
+external readdir : dir_handle -> string = "unix_readdir_r" "reentrant"
+external rewinddir : dir_handle -> unit = "unix_rewinddir_r" "reentrant"
+external closedir : dir_handle -> unit = "unix_closedir_r" "reentrant"
-external _pipe : unit -> file_descr * file_descr = "unix_pipe"
+external _pipe : unit -> file_descr * file_descr = "unix_pipe_r" "reentrant"
let pipe() =
let (out_fd, in_fd as fd_pair) = _pipe() in
set_nonblock in_fd;
set_nonblock out_fd;
fd_pair
-external symlink : string -> string -> unit = "unix_symlink"
-external readlink : string -> string = "unix_readlink"
-external mkfifo : string -> file_perm -> unit = "unix_mkfifo"
+external symlink : string -> string -> unit = "unix_symlink_r" "reentrant"
+external readlink : string -> string = "unix_readlink_r" "reentrant"
+external mkfifo : string -> file_perm -> unit = "unix_mkfifo_r" "reentrant"
let select readfds writefds exceptfds delay =
match select_aux (readfds, writefds, exceptfds, delay) with
@@ -368,13 +368,13 @@ type lock_command =
| F_RLOCK
| F_TRLOCK
-external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf"
+external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf_r" "reentrant"
-external _execv : string -> string array -> 'a = "unix_execv"
-external _execve : string -> string array -> string array -> 'a = "unix_execve"
-external _execvp : string -> string array -> 'a = "unix_execvp"
+external _execv : string -> string array -> 'a = "unix_execv_r" "reentrant"
+external _execve : string -> string array -> string array -> 'a = "unix_execve_r" "reentrant"
+external _execvp : string -> string array -> 'a = "unix_execvp_r" "reentrant"
external _execvpe : string -> string array -> string array -> 'a
- = "unix_execvpe"
+ = "unix_execvpe_r" "reentrant"
(* Disable the timer interrupt before doing exec, because some OS
keep sending timer interrupts to the exec'ed code.
@@ -413,9 +413,9 @@ let execvp proc args =
let execvpe proc args =
do_exec (fun () -> _execvpe proc args)
-external fork : unit -> int = "unix_fork"
+external fork : unit -> int = "unix_fork_r" "reentrant"
external _waitpid : wait_flag list -> int -> int * process_status
- = "unix_waitpid"
+ = "unix_waitpid_r" "reentrant"
let wait_pid pid =
match wait_pid_aux pid with
@@ -429,16 +429,16 @@ let waitpid flags pid =
then _waitpid flags pid
else wait_pid pid
-external getpid : unit -> int = "unix_getpid"
-external getppid : unit -> int = "unix_getppid"
-external nice : int -> int = "unix_nice"
+external getpid : unit -> int = "unix_getpid_r" "reentrant"
+external getppid : unit -> int = "unix_getppid_r" "reentrant"
+external nice : int -> int = "unix_nice_r" "reentrant"
-external kill : int -> int -> unit = "unix_kill"
+external kill : int -> int -> unit = "unix_kill_r" "reentrant"
type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK
external sigprocmask: sigprocmask_command -> int list -> int list
- = "unix_sigprocmask"
-external sigpending: unit -> int list = "unix_sigpending"
-external sigsuspend: int list -> unit = "unix_sigsuspend"
+ = "unix_sigprocmask_r" "reentrant"
+external sigpending: unit -> int list = "unix_sigpending_r" "reentrant"
+external sigsuspend: int list -> unit = "unix_sigsuspend_r" "reentrant"
let pause() =
let sigs = sigprocmask SIG_BLOCK [] in sigsuspend sigs
@@ -460,27 +460,27 @@ type tm =
tm_yday : int;
tm_isdst : bool }
-external time : unit -> float = "unix_time"
-external gettimeofday : unit -> float = "unix_gettimeofday"
-external gmtime : float -> tm = "unix_gmtime"
-external localtime : float -> tm = "unix_localtime"
-external mktime : tm -> float * tm = "unix_mktime"
-external alarm : int -> int = "unix_alarm"
+external time : unit -> float = "unix_time_r" "reentrant"
+external gettimeofday : unit -> float = "unix_gettimeofday_r" "reentrant"
+external gmtime : float -> tm = "unix_gmtime_r" "reentrant"
+external localtime : float -> tm = "unix_localtime_r" "reentrant"
+external mktime : tm -> float * tm = "unix_mktime_r" "reentrant"
+external alarm : int -> int = "unix_alarm_r" "reentrant"
let sleep secs = delay (float secs)
-external times : unit -> process_times = "unix_times"
-external utimes : string -> float -> float -> unit = "unix_utimes"
+external times : unit -> process_times = "unix_times_r" "reentrant"
+external utimes : string -> float -> float -> unit = "unix_utimes_r" "reentrant"
-external getuid : unit -> int = "unix_getuid"
-external geteuid : unit -> int = "unix_geteuid"
-external setuid : int -> unit = "unix_setuid"
-external getgid : unit -> int = "unix_getgid"
-external getegid : unit -> int = "unix_getegid"
-external setgid : int -> unit = "unix_setgid"
-external getgroups : unit -> int array = "unix_getgroups"
-external setgroups : int array -> unit = "unix_setgroups"
-external initgroups : string -> int -> unit = "unix_initgroups"
+external getuid : unit -> int = "unix_getuid_r" "reentrant"
+external geteuid : unit -> int = "unix_geteuid_r" "reentrant"
+external setuid : int -> unit = "unix_setuid_r" "reentrant"
+external getgid : unit -> int = "unix_getgid_r" "reentrant"
+external getegid : unit -> int = "unix_getegid_r" "reentrant"
+external setgid : int -> unit = "unix_setgid_r" "reentrant"
+external getgroups : unit -> int array = "unix_getgroups_r" "reentrant"
+external setgroups : int array -> unit = "unix_setgroups_r" "reentrant"
+external initgroups : string -> int -> unit = "unix_initgroups_r" "reentrant"
type passwd_entry =
{ pw_name : string;
@@ -498,18 +498,18 @@ type group_entry =
gr_mem : string array }
-external getlogin : unit -> string = "unix_getlogin"
-external getpwnam : string -> passwd_entry = "unix_getpwnam"
-external getgrnam : string -> group_entry = "unix_getgrnam"
-external getpwuid : int -> passwd_entry = "unix_getpwuid"
-external getgrgid : int -> group_entry = "unix_getgrgid"
+external getlogin : unit -> string = "unix_getlogin_r" "reentrant"
+external getpwnam : string -> passwd_entry = "unix_getpwnam_r" "reentrant"
+external getgrnam : string -> group_entry = "unix_getgrnam_r" "reentrant"
+external getpwuid : int -> passwd_entry = "unix_getpwuid_r" "reentrant"
+external getgrgid : int -> group_entry = "unix_getgrgid_r" "reentrant"
type inet_addr = string
external inet_addr_of_string : string -> inet_addr
- = "unix_inet_addr_of_string"
+ = "unix_inet_addr_of_string_r" "reentrant"
external string_of_inet_addr : inet_addr -> string
- = "unix_string_of_inet_addr"
+ = "unix_string_of_inet_addr_r" "reentrant"
let inet_addr_any = inet_addr_of_string "0.0.0.0"
let inet_addr_loopback = inet_addr_of_string "127.0.0.1"
@@ -550,10 +550,10 @@ type msg_flag =
| MSG_PEEK
external _socket : socket_domain -> socket_type -> int -> file_descr
- = "unix_socket"
+ = "unix_socket_r" "reentrant"