diff options
Diffstat (limited to 'otherlibs/threads')
| -rw-r--r-- | otherlibs/threads/.depend | 43 | ||||
| -rw-r--r-- | otherlibs/threads/Makefile | 26 | ||||
| -rw-r--r-- | otherlibs/threads/event.ml | 4 | ||||
| -rw-r--r-- | otherlibs/threads/marshal.ml | 30 | ||||
| -rw-r--r-- | otherlibs/threads/pervasives.ml | 217 | ||||
| -rw-r--r-- | otherlibs/threads/threadUnix.ml | 7 | ||||
| -rw-r--r-- | otherlibs/threads/threadUnix.mli | 25 | ||||
| -rw-r--r-- | otherlibs/threads/unix.ml | 42 |
8 files changed, 225 insertions, 169 deletions
diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index 091feb639..3a6c7f02b 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -1,35 +1,32 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/backtrace.h ../../byterun/callback.h \ - ../../byterun/config.h ../../byterun/fail.h ../../byterun/io.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \ - ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ - ../../byterun/sys.h + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/backtrace.h ../../byterun/callback.h \ + ../../byterun/config.h ../../byterun/fail.h ../../byterun/io.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \ + ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ + ../../byterun/sys.h condition.cmi : mutex.cmi event.cmi : -marshal.cmi : mutex.cmi : -pervasives.cmi : -thread.cmi : unix.cmi -threadUnix.cmi : unix.cmi -unix.cmi : +thread.cmi : unix.cmo +threadUnix.cmi : unix.cmo condition.cmo : thread.cmi mutex.cmi condition.cmi condition.cmx : thread.cmx mutex.cmx condition.cmi event.cmo : mutex.cmi condition.cmi event.cmi event.cmx : mutex.cmx condition.cmx event.cmi -marshal.cmo : pervasives.cmi marshal.cmi -marshal.cmx : pervasives.cmx marshal.cmi +marshal.cmo : +marshal.cmx : mutex.cmo : thread.cmi mutex.cmi mutex.cmx : thread.cmx mutex.cmi -pervasives.cmo : unix.cmi pervasives.cmi -pervasives.cmx : unix.cmx pervasives.cmi -thread.cmo : unix.cmi thread.cmi +pervasives.cmo : unix.cmo +pervasives.cmx : unix.cmx +thread.cmo : unix.cmo thread.cmi thread.cmx : unix.cmx thread.cmi -threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi +threadUnix.cmo : unix.cmo thread.cmi threadUnix.cmi threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi -unix.cmo : unix.cmi -unix.cmx : unix.cmi +unix.cmo : +unix.cmx : diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index 3aa6c2acf..1c4434f5b 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -15,9 +15,11 @@ include ../../config/Makefile CC=$(BYTECC) CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g -CAMLC=../../ocamlcomp.sh -I ../unix +ROOTDIR=../.. +CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib \ + -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-w +33..39 -warn-error A -bin-annot +COMPFLAGS=-w +33..39 -warn-error A -bin-annot -safe-string C_OBJS=scheduler.o @@ -25,7 +27,7 @@ CAML_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo LIB=../../stdlib -LIB_OBJS=pervasives.cmo \ +LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo \ $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/string.cmo \ $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo $(LIB)/obj.cmo \ $(LIB)/int32.cmo $(LIB)/int64.cmo $(LIB)/nativeint.cmo \ @@ -95,15 +97,18 @@ clean: partialclean rm -f libvmthreads.a dllvmthreads.so *.o rm -f pervasives.mli marshal.mli unix.mli +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) + install: - if test -f dllvmthreads.so; then cp dllvmthreads.so $(STUBLIBDIR)/.; fi - mkdir -p $(LIBDIR)/vmthreads - cp libvmthreads.a $(LIBDIR)/vmthreads/libvmthreads.a - cd $(LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a + if test -f dllvmthreads.so; then cp dllvmthreads.so $(INSTALL_STUBLIBDIR)/.; fi + mkdir -p $(INSTALL_LIBDIR)/vmthreads + cp libvmthreads.a $(INSTALL_LIBDIR)/vmthreads/libvmthreads.a + cd $(INSTALL_LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi \ - threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads + threads.cma stdlib.cma unix.cma $(INSTALL_LIBDIR)/vmthreads cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli \ - $(LIBDIR)/vmthreads + $(INSTALL_LIBDIR)/vmthreads installopt: @@ -115,9 +120,6 @@ installopt: .ml.cmo: $(CAMLC) -c $(COMPFLAGS) $< -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - depend: gcc -MM $(CFLAGS) *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend diff --git a/otherlibs/threads/event.ml b/otherlibs/threads/event.ml index 1feac525f..68d8a5b45 100644 --- a/otherlibs/threads/event.ml +++ b/otherlibs/threads/event.ml @@ -69,7 +69,7 @@ let do_aborts abort_env genev performed = let basic_sync abort_env genev = let performed = ref (-1) in let condition = Condition.create() in - let bev = Array.create (Array.length genev) + let bev = Array.make (Array.length genev) (fst (genev.(0)) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- (fst genev.(i)) performed condition i @@ -143,7 +143,7 @@ let sync ev = let basic_poll abort_env genev = let performed = ref (-1) in let condition = Condition.create() in - let bev = Array.create(Array.length genev) + let bev = Array.make(Array.length genev) (fst genev.(0) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- fst genev.(i) performed condition i diff --git a/otherlibs/threads/marshal.ml b/otherlibs/threads/marshal.ml index c71ca83d0..005e96437 100644 --- a/otherlibs/threads/marshal.ml +++ b/otherlibs/threads/marshal.ml @@ -16,6 +16,9 @@ type extern_flags = | Closures | Compat_32 +external to_bytes: 'a -> extern_flags list -> bytes + = "caml_output_value_to_string" + external to_string: 'a -> extern_flags list -> string = "caml_output_value_to_string" @@ -23,35 +26,34 @@ 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 + bytes -> int -> int -> 'a -> extern_flags list -> int = "caml_output_value_to_buffer" let to_buffer buff ofs len v flags = - if ofs < 0 || len < 0 || ofs + len > String.length buff + if ofs < 0 || len < 0 || ofs + len > Bytes.length buff then invalid_arg "Marshal.to_buffer: substring out of bounds" else to_buffer_unsafe 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 +external from_channel: in_channel -> 'a = "caml_input_value" +external from_bytes_unsafe: bytes -> int -> 'a = "caml_input_value_from_string" -external data_size_unsafe: string -> int -> int = "caml_marshal_data_size" +external data_size_unsafe: bytes -> int -> int = "caml_marshal_data_size" let header_size = 20 let data_size buff ofs = - if ofs < 0 || ofs > String.length buff - header_size + if ofs < 0 || ofs > Bytes.length buff - header_size then invalid_arg "Marshal.data_size" else data_size_unsafe buff ofs let total_size buff ofs = header_size + data_size buff ofs -let from_string buff ofs = - if ofs < 0 || ofs > String.length buff - header_size - then invalid_arg "Marshal.from_size" +let from_bytes buff ofs = + if ofs < 0 || ofs > Bytes.length buff - header_size + then invalid_arg "Marshal.from_bytes" else begin let len = data_size_unsafe buff ofs in - if ofs > String.length buff - (header_size + len) - then invalid_arg "Marshal.from_string" - else from_string_unsafe buff ofs + if ofs > Bytes.length buff - (header_size + len) + then invalid_arg "Marshal.from_bytes" + else from_bytes_unsafe buff ofs end -let from_channel = Pervasives.input_value +let from_string buff ofs = from_bytes (Bytes.unsafe_of_string buff) ofs diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index 402e01b87..e6f1cc16b 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -27,6 +27,7 @@ let () = register_named_value "Pervasives.array_bound_error" (Invalid_argument "index out of bounds") + external raise : exn -> 'a = "%raise" external raise_notrace : exn -> 'a = "%raise_notrace" @@ -37,68 +38,80 @@ exception Exit (* Composition operators *) -external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply" +external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" +(* Debugging *) + +external __LOC__ : string = "%loc_LOC" +external __FILE__ : string = "%loc_FILE" +external __LINE__ : int = "%loc_LINE" +external __MODULE__ : string = "%loc_MODULE" +external __POS__ : string * int * int * int = "%loc_POS" + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" + (* Comparisons *) -external (=) : 'a -> 'a -> bool = "%equal" -external (<>) : 'a -> 'a -> bool = "%notequal" -external (<) : 'a -> 'a -> bool = "%lessthan" -external (>) : 'a -> 'a -> bool = "%greaterthan" -external (<=) : 'a -> 'a -> bool = "%lessequal" -external (>=) : 'a -> 'a -> bool = "%greaterequal" -external compare: 'a -> 'a -> int = "%compare" +external ( = ) : 'a -> 'a -> bool = "%equal" +external ( <> ) : 'a -> 'a -> bool = "%notequal" +external ( < ) : 'a -> 'a -> bool = "%lessthan" +external ( > ) : 'a -> 'a -> bool = "%greaterthan" +external ( <= ) : 'a -> 'a -> bool = "%lessequal" +external ( >= ) : 'a -> 'a -> bool = "%greaterequal" +external compare : 'a -> 'a -> int = "%compare" let min x y = if x <= y then x else y let max x y = if x >= y then x else y -external (==) : 'a -> 'a -> bool = "%eq" -external (!=) : 'a -> 'a -> bool = "%noteq" +external ( == ) : 'a -> 'a -> bool = "%eq" +external ( != ) : 'a -> 'a -> bool = "%noteq" (* Boolean operations *) external not : bool -> bool = "%boolnot" -external (&) : bool -> bool -> bool = "%sequand" -external (&&) : bool -> bool -> bool = "%sequand" -external (or) : bool -> bool -> bool = "%sequor" -external (||) : bool -> bool -> bool = "%sequor" +external ( & ) : bool -> bool -> bool = "%sequand" +external ( && ) : bool -> bool -> bool = "%sequand" +external ( or ) : bool -> bool -> bool = "%sequor" +external ( || ) : bool -> bool -> bool = "%sequor" (* Integer operations *) -external (~-) : int -> int = "%negint" -external (~+) : int -> int = "%identity" +external ( ~- ) : int -> int = "%negint" +external ( ~+ ) : int -> int = "%identity" external succ : int -> int = "%succint" external pred : int -> int = "%predint" -external (+) : int -> int -> int = "%addint" -external (-) : int -> int -> int = "%subint" +external ( + ) : int -> int -> int = "%addint" +external ( - ) : int -> int -> int = "%subint" external ( * ) : int -> int -> int = "%mulint" -external (/) : int -> int -> int = "%divint" -external (mod) : int -> int -> int = "%modint" +external ( / ) : int -> int -> int = "%divint" +external ( mod ) : int -> int -> int = "%modint" let abs x = if x >= 0 then x else -x -external (land) : int -> int -> int = "%andint" -external (lor) : int -> int -> int = "%orint" -external (lxor) : int -> int -> int = "%xorint" +external ( land ) : int -> int -> int = "%andint" +external ( lor ) : int -> int -> int = "%orint" +external ( lxor ) : int -> int -> int = "%xorint" let lnot x = x lxor (-1) -external (lsl) : int -> int -> int = "%lslint" -external (lsr) : int -> int -> int = "%lsrint" -external (asr) : int -> int -> int = "%asrint" +external ( lsl ) : int -> int -> int = "%lslint" +external ( lsr ) : int -> int -> int = "%lsrint" +external ( asr ) : int -> int -> int = "%asrint" -let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62) -let max_int = min_int - 1 +let max_int = (-1) lsr 1 +let min_int = max_int + 1 (* Floating-point operations *) -external (~-.) : float -> float = "%negfloat" -external (~+.) : float -> float = "%identity" -external (+.) : float -> float -> float = "%addfloat" -external (-.) : float -> float -> float = "%subfloat" +external ( ~-. ) : float -> float = "%negfloat" +external ( ~+. ) : float -> float = "%identity" +external ( +. ) : float -> float -> float = "%addfloat" +external ( -. ) : float -> float -> float = "%subfloat" external ( *. ) : float -> float -> float = "%mulfloat" -external (/.) : float -> float -> float = "%divfloat" +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" @@ -107,7 +120,7 @@ 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" + = "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" @@ -122,7 +135,7 @@ external ceil : float -> float = "caml_ceil_float" "ceil" "float" external floor : float -> float = "caml_floor_float" "floor" "float" external abs_float : float -> float = "%absfloat" external copysign : float -> float -> float - = "caml_copysign_float" "caml_copysign" "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" @@ -151,21 +164,26 @@ type fpclass = | FP_zero | FP_infinite | FP_nan -external classify_float: float -> fpclass = "caml_classify_float" +external classify_float : float -> fpclass = "caml_classify_float" -(* String operations -- more in module String *) +(* String and byte sequence operations -- more in modules String and Bytes *) external string_length : string -> int = "%string_length" -external string_create: int -> string = "caml_create_string" -external string_blit : string -> int -> string -> int -> int -> unit +external bytes_length : bytes -> int = "%string_length" +external bytes_create : int -> bytes = "caml_create_string" +external string_blit : string -> int -> bytes -> int -> int -> unit = "caml_blit_string" "noalloc" +external bytes_blit : bytes -> int -> bytes -> int -> int -> unit + = "caml_blit_string" "noalloc" +external bytes_unsafe_to_string : bytes -> string = "%identity" +external bytes_unsafe_of_string : string -> bytes = "%identity" -let (^) s1 s2 = +let ( ^ ) s1 s2 = let l1 = string_length s1 and l2 = string_length s2 in - let s = string_create (l1 + l2) in + let s = bytes_create (l1 + l2) in string_blit s1 0 s 0 l1; string_blit s2 0 s l1 l2; - s + bytes_unsafe_to_string s (* Character operations -- more in module Char *) @@ -185,17 +203,17 @@ external snd : 'a * 'b -> 'b = "%field1" (* References *) -type 'a ref = { mutable contents: 'a } -external ref: 'a -> 'a ref = "%makemutable" -external (!): 'a ref -> 'a = "%field0" -external (:=): 'a ref -> 'a -> unit = "%setfield0" -external incr: int ref -> unit = "%incr" -external decr: int ref -> unit = "%decr" +type 'a ref = { mutable contents : 'a } +external ref : 'a -> 'a ref = "%makemutable" +external ( ! ) : 'a ref -> 'a = "%field0" +external ( := ) : 'a ref -> 'a -> unit = "%setfield0" +external incr : int ref -> unit = "%incr" +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" +external format_float : string -> float -> string = "caml_format_float" let string_of_bool b = if b then "true" else "false" @@ -208,13 +226,14 @@ let string_of_int n = format_int "%d" n external int_of_string : string -> int = "caml_int_of_string" +external string_get : string -> int -> char = "%string_safe_get" let valid_float_lexem s = let l = string_length s in let rec loop i = if i >= l then s ^ "." else - match s.[i] with - | '0' .. '9' | '-' -> loop (i+1) + match string_get s i with + | '0' .. '9' | '-' -> loop (i + 1) | _ -> s in loop 0 @@ -226,7 +245,7 @@ external float_of_string : string -> float = "caml_float_of_string" (* List operations -- more in module List *) -let rec (@) l1 l2 = +let rec ( @ ) l1 l2 = match l1 with [] -> l2 | hd :: tl -> hd :: (tl @ l2) @@ -236,8 +255,9 @@ let rec (@) l1 l2 = type in_channel type out_channel -external open_descriptor_out: int -> out_channel = "caml_ml_open_descriptor_out" -external open_descriptor_in: int -> in_channel = "caml_ml_open_descriptor_in" +external open_descriptor_out : int -> out_channel + = "caml_ml_open_descriptor_out" +external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in" let stdin = open_descriptor_in 0 let stdout = open_descriptor_out 1 @@ -267,7 +287,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" let open_out_gen mode perm name = open_descriptor_out(open_desc name mode perm) @@ -303,7 +323,7 @@ let flush_all () = iter l in iter (out_channels_list ()) -external unsafe_output_partial : out_channel -> string -> int -> int -> int +external unsafe_output_partial : out_channel -> bytes -> int -> int -> int = "caml_ml_output_partial" let rec unsafe_output oc buf pos len = @@ -327,15 +347,19 @@ let rec output_char oc c = with Sys_blocked_io -> wait_outchan oc 1; output_char oc c +let output_bytes oc s = + unsafe_output oc s 0 (bytes_length s) + let output_string oc s = - unsafe_output oc s 0 (string_length s) + unsafe_output oc (bytes_unsafe_of_string s) 0 (string_length s) let output oc s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len + if ofs < 0 || len < 0 || ofs > bytes_length s - len then invalid_arg "output" else unsafe_output oc s ofs len -let output' oc ~buf ~pos ~len = output oc buf pos len +let output_substring oc s ofs len = + output oc (bytes_unsafe_of_string s) ofs len let rec output_byte oc b = try @@ -389,7 +413,7 @@ let rec input_char ic = with Sys_blocked_io -> wait_inchan ic; input_char ic -external unsafe_input_blocking : in_channel -> string -> int -> int -> int +external unsafe_input_blocking : in_channel -> bytes -> int -> int -> int = "caml_ml_input" let rec unsafe_input ic s ofs len = @@ -399,7 +423,7 @@ let rec unsafe_input ic s ofs len = wait_inchan ic; unsafe_input ic s ofs len let input ic s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len + if ofs < 0 || len < 0 || ofs > bytes_length s - len then invalid_arg "input" else unsafe_input ic s ofs len @@ -408,35 +432,42 @@ let rec unsafe_really_input ic s ofs len = let r = unsafe_input ic s ofs len in if r = 0 then raise End_of_file - else unsafe_really_input ic s (ofs+r) (len-r) + else unsafe_really_input ic s (ofs + r) (len - r) end let really_input ic s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len + if ofs < 0 || len < 0 || ofs > bytes_length s - len then invalid_arg "really_input" else unsafe_really_input ic s ofs len +let really_input_string ic len = + let s = bytes_create len in + really_input ic s 0 len; + bytes_unsafe_to_string s + +external bytes_set : bytes -> int -> char -> unit = "%string_safe_set" + let input_line ic = - let buf = ref (string_create 128) in + let buf = ref (bytes_create 128) in let pos = ref 0 in begin try while true do - if !pos = string_length !buf then begin - let newbuf = string_create (2 * !pos) in - string_blit !buf 0 newbuf 0 !pos; + if !pos = bytes_length !buf then begin + let newbuf = bytes_create (2 * !pos) in + bytes_blit !buf 0 newbuf 0 !pos; buf := newbuf end; let c = input_char ic in if c = '\n' then raise Exit; - !buf.[!pos] <- c; + bytes_set !buf !pos c; incr pos done with Exit -> () | End_of_file -> if !pos = 0 then raise End_of_file end; - let res = string_create !pos in - string_blit !buf 0 res 0 !pos; - res + let res = bytes_create !pos in + bytes_blit !buf 0 res 0 !pos; + bytes_unsafe_to_string res let rec input_byte ic = try @@ -452,15 +483,15 @@ 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 : bytes -> int -> 'a = "caml_input_value_from_string" +external marshal_data_size : bytes -> int -> int = "caml_marshal_data_size" let input_value ic = - let header = string_create 20 in + let header = bytes_create 20 in really_input ic header 0 20; let bsize = marshal_data_size header 0 in - let buffer = string_create (20 + bsize) in - string_blit header 0 buffer 0 20; + let buffer = bytes_create (20 + bsize) in + bytes_blit header 0 buffer 0 20; really_input ic buffer 20 bsize; unmarshal buffer 0 @@ -476,6 +507,7 @@ external set_binary_mode_in : in_channel -> bool -> unit let print_char c = output_char stdout c let print_string s = output_string stdout s +let print_bytes s = output_bytes stdout s let print_int i = output_string stdout (string_of_int i) let print_float f = output_string stdout (string_of_float f) let print_endline s = @@ -486,6 +518,7 @@ let print_newline () = output_char stdout '\n'; flush stdout let prerr_char c = output_char stderr c let prerr_string s = output_string stderr s +let prerr_bytes s = output_bytes stderr s let prerr_int i = output_string stderr (string_of_int i) let prerr_float f = output_string stderr (string_of_float f) let prerr_endline s = @@ -512,33 +545,25 @@ module LargeFile = end (* Formats *) + +type ('a, 'b, 'c, 'd, 'e, 'f) format6 + = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 + = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt + * string + type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 +let string_of_format (Format (fmt, str)) = str + external format_of_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" -external format_to_string : - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" -external string_to_format : - string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" - -let (( ^^ ) : - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - ('f, 'b, 'c, 'e, 'g, 'h) format6 -> - ('a, 'b, 'c, 'd, 'g, 'h) format6) = - fun fmt1 fmt2 -> - string_to_format (format_to_string fmt1 ^ "%," ^ format_to_string fmt2) -;; - -let string_of_format fmt = - let s = format_to_string fmt in - let l = string_length s in - let r = string_create l in - string_blit s 0 r 0 l; - r +let (^^) (Format (fmt1, str1)) (Format (fmt2, str2)) = + Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2, + str1 ^ "%," ^ str2) (* Miscellaneous *) diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml index fe5ef4fdf..c086c1f55 100644 --- a/otherlibs/threads/threadUnix.ml +++ b/otherlibs/threads/threadUnix.ml @@ -22,6 +22,8 @@ let system = Unix.system let read = Unix.read let write = Unix.write let single_write = Unix.single_write +let write_substring = Unix.write_substring +let single_write_substring = Unix.single_write_substring let select = Unix.select let pipe = Unix.pipe let open_process_in = Unix.open_process_in @@ -36,7 +38,9 @@ let connect = Unix.connect let recv = Unix.recv let recvfrom = Unix.recvfrom let send = Unix.send +let send_substring = Unix.send_substring let sendto = Unix.sendto +let sendto_substring = Unix.sendto_substring let open_connection = Unix.open_connection let establish_server = Unix.establish_server @@ -57,3 +61,6 @@ let rec timed_write fd buff ofs len timeout = timed_write fd buff ofs len timeout end else raise (Unix_error(ETIMEDOUT, "timed_write", "")) + +let timed_write_substring fd buff ofs len timeout = + timed_write fd (Bytes.unsafe_of_string buff) ofs len timeout diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli index 4ebe28f4f..52862f98a 100644 --- a/otherlibs/threads/threadUnix.mli +++ b/otherlibs/threads/threadUnix.mli @@ -30,21 +30,27 @@ val system : string -> Unix.process_status (** {6 Basic input/output} *) -val read : Unix.file_descr -> string -> int -> int -> int -val write : Unix.file_descr -> string -> int -> int -> int -val single_write : Unix.file_descr -> string -> int -> int -> int +val read : Unix.file_descr -> bytes -> int -> int -> int +val write : Unix.file_descr -> bytes -> int -> int -> int +val single_write : Unix.file_descr -> bytes -> int -> int -> int +val write_substring : Unix.file_descr -> string -> int -> int -> int +val single_write_substring : Unix.file_descr -> string -> int -> int -> int (** {6 Input/output with timeout} *) -val timed_read : Unix.file_descr -> string -> int -> int -> float -> int +val timed_read : Unix.file_descr -> bytes -> int -> int -> float -> int (** See {!ThreadUnix.timed_write}. *) -val timed_write : Unix.file_descr -> string -> int -> int -> float -> int +val timed_write : Unix.file_descr -> bytes -> int -> int -> float -> int (** Behave as {!ThreadUnix.read} and {!ThreadUnix.write}, except that [Unix_error(ETIMEDOUT,_,_)] is raised if no data is available for reading or ready for writing after [d] seconds. The delay [d] is given in the fifth argument, in seconds. *) +val timed_write_substring : + Unix.file_descr -> string -> int -> int -> float -> int +(** See {!ThreadUnix.timed_write}. *) + (** {6 Polling} *) val select : @@ -74,13 +80,18 @@ val socketpair : val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr val connect : Unix.file_descr -> Unix.sockaddr -> unit val recv : - Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int + Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int val recvfrom : - Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> + Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr val send : + Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int +val send_substring : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int val sendto : + Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> + Unix.sockaddr -> int +val sendto_substring : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int val open_connection : Unix.sockaddr -> in_channel * out_channel diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml index 80ea7aed6..a397ec404 100644 --- a/otherlibs/threads/unix.ml +++ b/otherlibs/threads/unix.ml @@ -205,15 +205,15 @@ external openfile : string -> open_flag list -> file_perm -> file_descr = "unix_open" external close : file_descr -> unit = "unix_close" -external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" -external unsafe_write : file_descr -> string -> int -> int -> int +external unsafe_read : file_descr -> bytes -> int -> int -> int = "unix_read" +external unsafe_write : file_descr -> bytes -> int -> int -> int = "unix_write" -external unsafe_single_write : file_descr -> string -> int -> int -> int +external unsafe_single_write : file_descr -> bytes -> int -> int -> int = "unix_single_write" let rec read fd buf ofs len = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.read" else unsafe_read fd buf ofs len with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> @@ -221,7 +221,7 @@ let rec read fd buf ofs len = let rec write fd buf ofs len = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.write" else unsafe_write fd buf ofs len with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> @@ -229,12 +229,18 @@ let rec write fd buf ofs len = let rec single_write fd buf ofs len = try - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.partial_write" + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len + then invalid_arg "Unix.single_write" else unsafe_single_write fd buf ofs len with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_write fd; single_write fd buf ofs len +let write_substring fd buf ofs len = + write fd (Bytes.unsafe_of_string buf) ofs len + +let single_write_substring fd buf ofs len = + single_write fd (Bytes.unsafe_of_string buf) ofs len + external in_channel_of_descr : file_descr -> in_channel = "caml_ml_open_descriptor_in" external out_channel_of_descr : file_descr -> out_channel @@ -591,21 +597,21 @@ let connect s addr = ignore(getpeername s) external unsafe_recv : - file_descr -> string -> int -> int -> msg_flag list -> int + file_descr -> bytes -> int -> int -> msg_flag list -> int = "unix_recv" external unsafe_recvfrom : - file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr + file_descr -> bytes -> int -> int -> msg_flag list -> int * sockaddr = "unix_recvfrom" external unsafe_send : - file_descr -> string -> int -> int -> msg_flag list -> int + file_descr -> bytes -> int -> int -> msg_flag list -> int = "unix_send" external unsafe_sendto : - file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int + file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int = "unix_sendto" "unix_sendto_native" let rec recv fd buf ofs len flags = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.recv" else unsafe_recv fd buf ofs len flags with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> @@ -613,7 +619,7 @@ let rec recv fd buf ofs len flags = let rec recvfrom fd buf ofs len flags = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.recvfrom" else unsafe_recvfrom fd buf ofs len flags with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> @@ -622,7 +628,7 @@ let rec recvfrom fd buf ofs len flags = let rec send fd buf ofs len flags = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.send" else unsafe_send fd buf ofs len flags with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> @@ -631,13 +637,19 @@ let rec send fd buf ofs len flags = let rec sendto fd buf ofs len flags addr = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.sendto" else unsafe_sendto fd buf ofs len flags addr with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_write fd; sendto fd buf ofs len flags addr +let send_substring fd buf ofs len flags = + send fd (Bytes.unsafe_of_string buf) ofs len flags + +let sendto_substring fd buf ofs len flags addr = + sendto fd (Bytes.unsafe_of_string buf) ofs len flags addr + type socket_bool_option = SO_DEBUG | SO_BROADCAST |