Adaptation pour ocamlopt. Verrouillage des channels maintenant fait en C, et plus en ML

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@1692 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

otherlibs/threads/Tests/Makefile

@@ -2,6 +2,8 @@ PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \
   test7.byt test8.byt test9.byt testA.byt sieve.byt \
   testio.byt testsocket.byt testwait.byt testsignal.byt
 
+CAMLC=../../../boot/ocamlrun ../../../ocamlc -I .. -I ../../../stdlib -I ../../unix
+
 include ../../../config/Makefile
 
 all: $(PROGS)
@@ -10,11 +12,11 @@ clean:
 	rm -f *.cm* *.byt
 
 sorts.byt: sorts.ml
-	ocamlc -custom -o sorts.byt -I .. -I ../../graph threads.cma graphics.cma sorts.ml ../libthreads.a ../../graph/libgraphics.a $(X11_LINK)
+	$(CAMLC) -custom -o sorts.byt -I ../../graph threads.cma graphics.cma sorts.ml ../libthreads.a ../../graph/libgraphics.a $(X11_LINK)
 
 .SUFFIXES: .ml .byt
 
 .ml.byt:
-	ocamlc -custom -o $*.byt -I .. -I ../../unix unix.cma threads.cma $*.ml ../libthreads.a ../../unix/libunix.a
+	$(CAMLC) -custom -o $*.byt unix.cma threads.cma $*.ml ../libthreads.a ../../unix/libunix.a
 
 $(PROGS): ../threads.cma ../libthreads.a

otherlibs/threads/Tests/testio.ml

@@ -5,8 +5,8 @@ let test msg producer consumer src dst =
   let ic = open_in_bin src in
   let oc = open_out_bin dst in
   let (in_fd, out_fd) = ThreadUnix.pipe() in
-  let ipipe = ThreadUnix.in_channel_of_descr in_fd in
+  let ipipe = Unix.in_channel_of_descr in_fd in
-  let opipe = ThreadUnix.out_channel_of_descr out_fd in
+  let opipe = Unix.out_channel_of_descr out_fd in
   let prod = Thread.create producer (ic, opipe) in
   let cons = Thread.create consumer (ipipe, oc) in
   Thread.join prod;

otherlibs/threads/pervasives.ml

@@ -158,8 +158,8 @@ let rec (@) l1 l2 =
 type in_channel
 type out_channel
 
-external open_descriptor_out: int -> out_channel = "open_descriptor"
+external open_descriptor_out: int -> out_channel = "caml_open_descriptor"
-external open_descriptor_in: int -> in_channel = "open_descriptor"
+external open_descriptor_in: int -> in_channel = "caml_open_descriptor"
 
 let stdin = open_descriptor_in 0
 let stdout = open_descriptor_out 1
@@ -205,14 +205,14 @@ 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 = "flush_partial"
+external flush_partial : out_channel -> bool = "caml_flush_partial"
 
 let rec flush oc =
   wait_outchan oc (-1);
   if flush_partial oc then () else flush oc
 
 external unsafe_output_partial : out_channel -> string -> int -> int -> int
-                        = "output_partial"
+                        = "caml_output_partial"
 
 let rec unsafe_output oc buf pos len =
   if len > 0 then begin
@@ -221,8 +221,9 @@ let rec unsafe_output oc buf pos len =
     unsafe_output oc buf (pos + written) (len - written)
   end
 
-external output_char_blocking : out_channel -> char -> unit = "output_char"
+external output_char_blocking : out_channel -> char -> unit 
-external output_byte_blocking : out_channel -> int -> unit = "output_char"
+                              = "caml_output_char"
+external output_byte_blocking : out_channel -> int -> unit = "caml_output_char"
 
 let output_char oc c = wait_outchan oc 1; output_char_blocking oc c
 
@@ -242,16 +243,18 @@ let output_binary_int oc n =
   output_byte oc (n asr 8);
   output_byte oc n
 
-external marshal_to_string : 'a -> unit list -> string = "output_value_to_string"
+external marshal_to_string : 'a -> unit list -> string 
+                           = "output_value_to_string"
+
 let output_value oc v = output_string oc (marshal_to_string v [])
 
-external seek_out_blocking : out_channel -> int -> unit = "seek_out"
+external seek_out_blocking : out_channel -> int -> unit = "caml_seek_out"
 
 let seek_out oc pos = flush oc; seek_out_blocking oc pos
 
-external pos_out : out_channel -> int = "pos_out"
+external pos_out : out_channel -> int = "caml_pos_out"
-external out_channel_length : out_channel -> int = "channel_size"
+external out_channel_length : out_channel -> int = "caml_channel_size"
-external close_out_channel : out_channel -> unit = "close_channel"
+external close_out_channel : out_channel -> unit = "caml_close_channel"
 
 let close_out oc = flush oc; close_out_channel oc
 
@@ -266,13 +269,13 @@ let open_in name =
 let open_in_bin name =
   open_in_gen [Open_rdonly; Open_binary] 0 name
 
-external input_char_blocking : in_channel -> char = "input_char"
+external input_char_blocking : in_channel -> char = "caml_input_char"
-external input_byte_blocking : in_channel -> int = "input_char"
+external input_byte_blocking : in_channel -> int = "caml_input_char"
 
 let input_char ic = wait_inchan ic; input_char_blocking ic
 
 external unsafe_input_blocking : in_channel -> string -> int -> int -> int
-                               = "input"
+                               = "caml_input"
 
 let unsafe_input ic s ofs len =
   wait_inchan ic; unsafe_input_blocking ic s ofs len
@@ -336,10 +339,10 @@ let input_value ic =
   really_input ic buffer 20 bsize;
   unmarshal buffer 0
 
-external seek_in : in_channel -> int -> unit = "seek_in"
+external seek_in : in_channel -> int -> unit = "caml_seek_in"
-external pos_in : in_channel -> int = "pos_in"
+external pos_in : in_channel -> int = "caml_pos_in"
-external in_channel_length : in_channel -> int = "channel_size"
+external in_channel_length : in_channel -> int = "caml_channel_size"
-external close_in : in_channel -> unit = "close_channel"
+external close_in : in_channel -> unit = "caml_close_channel"
 
 (* Output functions on standard output *)
 

otherlibs/threads/scheduler.c

@@ -124,15 +124,14 @@ static void thread_scan_roots(action)
      scanning_action action;
 {
   thread_t th;
-  register value * sp;
+
   /* Scan all active descriptors */
   (*action)((value) curr_thread, (value *) &curr_thread);
-  /* Don't scan curr_thread->sp, this has already been done */
+  /* Don't scan curr_thread->sp, this has already been done.
+     Don't scan local roots either, for the same reason. */
   for (th = curr_thread->next; th != curr_thread; th = th->next) {
     (*action)((value) th, (value *) &th);
-    for (sp = th->sp; sp < th->stack_high; sp++) {
+    do_local_roots(action, th->sp, th->stack_high, NULL);
-      (*action)(*sp, sp);
-    }
   }
   /* Hook */
   if (prev_scan_roots_hook != NULL) (*prev_scan_roots_hook)(action);
@@ -456,16 +455,17 @@ value thread_select(arg)        /* ML */
 
 /* Primitives to implement suspension on buffered channels */
 
-value thread_inchan_ready(chan) /* ML */
+value thread_inchan_ready(vchan) /* ML */
-     struct channel * chan;
+     value vchan;
 {
+  struct channel * chan = Channel(vchan);
   return Val_bool(chan->curr < chan->max);
 }
 
-value thread_outchan_ready(chan, vsize) /* ML */
+value thread_outchan_ready(vchan, vsize) /* ML */
-     struct channel * chan;
+     value vchan, vsize;
-     value vsize;
 {
+  struct channel * chan = Channel(vchan);
   long size = Long_val(vsize);
   /* Negative size means we want to flush the buffer entirely */
   if (size < 0) {

otherlibs/threads/threadUnix.ml

@@ -70,13 +70,6 @@ let timed_write fd buff ofs len timeout =
 
 let select = Thread.select
 
-(*** Interfacing with the standard input/output library *)
-
-external in_channel_of_descr : Unix.file_descr -> in_channel
-                             = "open_descriptor"
-external out_channel_of_descr : Unix.file_descr -> out_channel
-                              = "open_descriptor"
-
 (*** Pipes *)
 
 let pipe() =

otherlibs/threads/threadUnix.mli

@@ -49,13 +49,6 @@ val select :
   Unix.file_descr list -> float ->
         Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
 
-(*** Interfacing with the standard input/output library *)
-
-external in_channel_of_descr : Unix.file_descr -> in_channel
-                             = "open_descriptor"
-external out_channel_of_descr : Unix.file_descr -> out_channel
-                              = "open_descriptor"
-
 (*** Pipes and redirections *)
 
 val pipe : unit -> Unix.file_descr * Unix.file_descr