[Unison-hackers] [unison-svn] r339 - trunk/src
vouillon@seas.upenn.edu
vouillon at seas.upenn.edu
Tue May 26 09:43:00 EDT 2009
Author: vouillon
Date: 2009-05-26 09:42:55 -0400 (Tue, 26 May 2009)
New Revision: 339
Added:
trunk/src/bytearray.ml
trunk/src/bytearray.mli
trunk/src/bytearray_stubs.c
Modified:
trunk/src/.depend
trunk/src/Makefile.OCaml
trunk/src/RECENTNEWS
trunk/src/copy.ml
trunk/src/mkProjectInfo.ml
trunk/src/remote.ml
trunk/src/remote.mli
trunk/src/transfer.ml
trunk/src/transfer.mli
Log:
* Got rid of the 16MiB marshalling limit by marshalling to a bigarray
Modified: trunk/src/.depend
===================================================================
--- trunk/src/.depend 2009-05-26 09:42:42 UTC (rev 338)
+++ trunk/src/.depend 2009-05-26 13:42:55 UTC (rev 339)
@@ -1,4 +1,5 @@
abort.cmi: uutil.cmi
+bytearray.cmi:
case.cmi: ubase/prefs.cmi
checksum.cmi:
clroot.cmi:
@@ -23,14 +24,15 @@
pred.cmi:
props.cmi: uutil.cmi ubase/prefs.cmi path.cmi osx.cmi fspath.cmi
recon.cmi: path.cmi common.cmi
-remote.cmi: ubase/prefs.cmi lwt/lwt.cmi fspath.cmi common.cmi clroot.cmi
+remote.cmi: ubase/prefs.cmi lwt/lwt.cmi fspath.cmi common.cmi clroot.cmi \
+ bytearray.cmi
sortri.cmi: common.cmi
stasher.cmi: ubase/prefs.cmi path.cmi os.cmi fspath.cmi
strings.cmi:
system.cmi: system/system_intf.cmo
terminal.cmi:
test.cmi:
-transfer.cmi: uutil.cmi lwt/lwt.cmi
+transfer.cmi: uutil.cmi lwt/lwt.cmi bytearray.cmi
transport.cmi: uutil.cmi lwt/lwt.cmi common.cmi
tree.cmi:
uicommon.cmi: uutil.cmi ubase/prefs.cmi path.cmi lwt/lwt.cmi common.cmi
@@ -47,6 +49,8 @@
abort.cmi
abort.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx ubase/safelist.cmx \
abort.cmi
+bytearray.cmo: bytearray.cmi
+bytearray.cmx: bytearray.cmi
case.cmo: ubase/util.cmi unicode.cmi ubase/prefs.cmi case.cmi
case.cmx: ubase/util.cmx unicode.cmx ubase/prefs.cmx case.cmi
checksum.cmo: checksum.cmi
@@ -60,11 +64,13 @@
copy.cmo: xferhint.cmi uutil.cmi ubase/util.cmi transfer.cmi ubase/trace.cmi \
ubase/safelist.cmi remote.cmi props.cmi ubase/prefs.cmi path.cmi osx.cmi \
os.cmi lwt/lwt_util.cmi lwt/lwt.cmi globals.cmi fspath.cmi fs.cmi \
- fileinfo.cmi external.cmi common.cmi clroot.cmi abort.cmi copy.cmi
+ fileinfo.cmi external.cmi common.cmi clroot.cmi bytearray.cmi abort.cmi \
+ copy.cmi
copy.cmx: xferhint.cmx uutil.cmx ubase/util.cmx transfer.cmx ubase/trace.cmx \
ubase/safelist.cmx remote.cmx props.cmx ubase/prefs.cmx path.cmx osx.cmx \
os.cmx lwt/lwt_util.cmx lwt/lwt.cmx globals.cmx fspath.cmx fs.cmx \
- fileinfo.cmx external.cmx common.cmx clroot.cmx abort.cmx copy.cmi
+ fileinfo.cmx external.cmx common.cmx clroot.cmx bytearray.cmx abort.cmx \
+ copy.cmi
external.cmo: ubase/util.cmi system.cmi ubase/safelist.cmi lwt/lwt_util.cmi \
lwt/lwt_unix.cmi lwt/lwt.cmi external.cmi
external.cmx: ubase/util.cmx system.cmx ubase/safelist.cmx lwt/lwt_util.cmx \
@@ -149,10 +155,10 @@
globals.cmx fileinfo.cmx common.cmx recon.cmi
remote.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi terminal.cmi system.cmi \
ubase/safelist.cmi ubase/prefs.cmi os.cmi lwt/lwt_unix.cmi lwt/lwt.cmi \
- fspath.cmi fs.cmi common.cmi clroot.cmi case.cmi remote.cmi
+ fspath.cmi fs.cmi common.cmi clroot.cmi case.cmi bytearray.cmi remote.cmi
remote.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx terminal.cmx system.cmx \
ubase/safelist.cmx ubase/prefs.cmx os.cmx lwt/lwt_unix.cmx lwt/lwt.cmx \
- fspath.cmx fs.cmx common.cmx clroot.cmx case.cmx remote.cmi
+ fspath.cmx fs.cmx common.cmx clroot.cmx case.cmx bytearray.cmx remote.cmi
sortri.cmo: ubase/util.cmi ubase/safelist.cmi ubase/prefs.cmi pred.cmi \
path.cmi common.cmi sortri.cmi
sortri.cmx: ubase/util.cmx ubase/safelist.cmx ubase/prefs.cmx pred.cmx \
@@ -184,9 +190,9 @@
lwt/lwt.cmx globals.cmx fspath.cmx fs.cmx fingerprint.cmx common.cmx \
test.cmi
transfer.cmo: uutil.cmi ubase/util.cmi ubase/trace.cmi ubase/safelist.cmi \
- lwt/lwt.cmi checksum.cmi transfer.cmi
+ lwt/lwt.cmi checksum.cmi bytearray.cmi transfer.cmi
transfer.cmx: uutil.cmx ubase/util.cmx ubase/trace.cmx ubase/safelist.cmx \
- lwt/lwt.cmx checksum.cmx transfer.cmi
+ lwt/lwt.cmx checksum.cmx bytearray.cmx transfer.cmi
transport.cmo: uutil.cmi ubase/util.cmi update.cmi ubase/trace.cmi \
stasher.cmi remote.cmi props.cmi ubase/prefs.cmi path.cmi osx.cmi \
lwt/lwt_util.cmi lwt/lwt.cmi globals.cmi files.cmi common.cmi abort.cmi \
Modified: trunk/src/Makefile.OCaml
===================================================================
--- trunk/src/Makefile.OCaml 2009-05-26 09:42:42 UTC (rev 338)
+++ trunk/src/Makefile.OCaml 2009-05-26 13:42:55 UTC (rev 339)
@@ -187,7 +187,7 @@
OCAMLOBJS += \
ubase/rx.cmo \
\
- unicode_tables.cmo unicode.cmo \
+ unicode_tables.cmo unicode.cmo bytearray.cmo \
$(WINOBJS) system/system_generic.cmo \
system/$(SYSTEM)/system_impl.cmo \
system.cmo \
@@ -206,15 +206,15 @@
transfer.cmo xferhint.cmo remote.cmo globals.cmo copy.cmo \
stasher.cmo update.cmo \
files.cmo sortri.cmo recon.cmo transport.cmo \
- strings.cmo uicommon.cmo uitext.cmo test.cmo
+ strings.cmo uicommon.cmo uitext.cmo test.cmo
OCAMLOBJS+=main.cmo
# OCaml libraries for the bytecode version
# File extensions will be substituted for the native code version
-OCAMLLIBS+=unix.cma str.cma
+OCAMLLIBS+=unix.cma str.cma bigarray.cma
-COBJS+=osxsupport$(OBJ_EXT) pty$(OBJ_EXT)
+COBJS+=osxsupport$(OBJ_EXT) pty$(OBJ_EXT) bytearray_stubs$(OBJ_EXT)
########################################################################
### User Interface setup
Modified: trunk/src/RECENTNEWS
===================================================================
--- trunk/src/RECENTNEWS 2009-05-26 09:42:42 UTC (rev 338)
+++ trunk/src/RECENTNEWS 2009-05-26 13:42:55 UTC (rev 339)
@@ -1,5 +1,10 @@
CHANGES FROM VERSION 2.34.0
+* Got rid of the 16MiB marshalling limit by marshalling to a bigarray
+
+-------------------------------
+CHANGES FROM VERSION 2.34.0
+
* Use system dependant API for spawning processes.
(Unicode API under Windows.)
* Fixed the bug with ssh not working when running unison from a cygwin
Added: trunk/src/bytearray.ml
===================================================================
--- trunk/src/bytearray.ml (rev 0)
+++ trunk/src/bytearray.ml 2009-05-26 13:42:55 UTC (rev 339)
@@ -0,0 +1,94 @@
+(* Unison file synchronizer: src/bytearray.ml *)
+(* Copyright 1999-2009, Benjamin C. Pierce
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+*)
+
+open Bigarray
+
+type t = (char, int8_unsigned_elt, c_layout) Array1.t
+
+let length = Bigarray.Array1.dim
+
+let create l = Bigarray.Array1.create Bigarray.char Bigarray.c_layout l
+
+(*
+let unsafe_blit_from_string s i a j l =
+ for k = 0 to l - 1 do
+ a.{j + k} <- s.[i + k]
+ done
+
+let unsafe_blit_to_string a i s j l =
+ for k = 0 to l - 1 do
+ s.[j + k] <- a.{i + k}
+ done
+*)
+
+external unsafe_blit_from_string : string -> int -> t -> int -> int -> unit
+ = "ml_blit_string_to_bigarray" "noalloc"
+
+external unsafe_blit_to_string : t -> int -> string -> int -> int -> unit
+ = "ml_blit_bigarray_to_string" "noalloc"
+
+let to_string a =
+ let l = length a in
+ if l > Sys.max_string_length then invalid_arg "Bytearray.to_string" else
+ let s = String.create l in
+ unsafe_blit_to_string a 0 s 0 l;
+ s
+
+let of_string s =
+ let l = String.length s in
+ let a = create l in
+ unsafe_blit_from_string s 0 a 0 l;
+ a
+
+let sub a ofs len =
+ if
+ ofs < 0 || len < 0 || ofs > length a - len || len > Sys.max_string_length
+ then
+ invalid_arg "Bytearray.sub"
+ else begin
+ let s = String.create len in
+ unsafe_blit_to_string a ofs s 0 len;
+ s
+ end
+
+let rec prefix_rec a i a' i' l =
+ l = 0 ||
+ (a.{i} = a'.{i'} && prefix_rec a (i + 1) a' (i' + 1) (l - 1))
+
+let prefix a a' i =
+ let l = length a in
+ let l' = length a' in
+ i <= l' - l &&
+ prefix_rec a 0 a' i l
+
+let blit_from_string s i a j l =
+ if l < 0 || i < 0 || i > String.length s - l
+ || j < 0 || j > length a - l
+ then invalid_arg "Bytearray.blit_from_string"
+ else unsafe_blit_from_string s i a j l
+
+let blit_to_string a i s j l =
+ if l < 0 || i < 0 || i > length a - l
+ || j < 0 || j > String.length s - l
+ then invalid_arg "Bytearray.blit_to_string"
+ else unsafe_blit_to_string a i s j l
+
+external marshal : 'a -> Marshal.extern_flags list -> t
+ = "ml_marshal_to_bigarray"
+
+external unmarshal : t -> int -> 'a
+ = "ml_unmarshal_from_bigarray"
Added: trunk/src/bytearray.mli
===================================================================
--- trunk/src/bytearray.mli (rev 0)
+++ trunk/src/bytearray.mli 2009-05-26 13:42:55 UTC (rev 339)
@@ -0,0 +1,25 @@
+(* Unison file synchronizer: src/bytearray.mli *)
+(* Copyright 1999-2009, Benjamin C. Pierce (see COPYING for details) *)
+
+type t =
+ (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
+
+val create : int -> t
+
+val length : t -> int
+
+val to_string : t -> string
+
+val of_string : string -> t
+
+val sub : t -> int -> int -> string
+
+val blit_from_string : string -> int -> t -> int -> int -> unit
+
+val blit_to_string : t -> int -> string -> int -> int -> unit
+
+val prefix : t -> t -> int -> bool
+
+val marshal : 'a -> Marshal.extern_flags list -> t
+
+val unmarshal : t -> int -> 'a
Added: trunk/src/bytearray_stubs.c
===================================================================
--- trunk/src/bytearray_stubs.c (rev 0)
+++ trunk/src/bytearray_stubs.c 2009-05-26 13:42:55 UTC (rev 339)
@@ -0,0 +1,45 @@
+/* Unison file synchronizer: src/bytearray_stubs.c */
+/* Copyright 1999-2009 (see COPYING for details) */
+
+#include <string.h>
+
+#include "caml/intext.h"
+#include "caml/bigarray.h"
+
+CAMLprim value ml_marshal_to_bigarray(value v, value flags)
+{
+ char *buf;
+ long len;
+ output_value_to_malloc(v, flags, &buf, &len);
+ return alloc_bigarray(BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT | BIGARRAY_MANAGED,
+ 1, buf, &len);
+}
+
+
+#define Array_data(a, i) (((char *) a->data) + Long_val(i))
+
+
+CAMLprim value ml_unmarshal_from_bigarray(value b, value ofs)
+{
+ struct caml_bigarray *b_arr = Bigarray_val(b);
+ return input_value_from_block (Array_data (b_arr, ofs),
+ b_arr->dim[0] - Long_val(ofs));
+}
+
+CAMLprim value ml_blit_string_to_bigarray
+(value s, value i, value a, value j, value l)
+{
+ char *src = String_val(s) + Int_val(i);
+ char *dest = Array_data(Bigarray_val(a), j);
+ memcpy(dest, src, Long_val(l));
+ return Val_unit;
+}
+
+CAMLprim value ml_blit_bigarray_to_string
+(value a, value i, value s, value j, value l)
+{
+ char *src = Array_data(Bigarray_val(a), i);
+ char *dest = String_val(s) + Long_val(j);
+ memcpy(dest, src, Long_val(l));
+ return Val_unit;
+}
Modified: trunk/src/copy.ml
===================================================================
--- trunk/src/copy.ml 2009-05-26 09:42:42 UTC (rev 338)
+++ trunk/src/copy.ml 2009-05-26 13:42:55 UTC (rev 339)
@@ -211,8 +211,8 @@
(fun (file_id, (data, pos, len)) rem ->
((Remote.encodeInt file_id, 0, 4) :: (data, pos, len) :: rem, len + 4)),
(fun buf pos ->
- let len = String.length buf - pos - 4 in
- (Remote.decodeInt (String.sub buf pos 4), (buf, pos + 4, len)))
+ let len = Bytearray.length buf - pos - 4 in
+ (Remote.decodeInt buf pos, (buf, pos + 4, len)))
let processTransferInstructionRemotely =
Remote.registerSpecialServerCmd
Modified: trunk/src/mkProjectInfo.ml
===================================================================
--- trunk/src/mkProjectInfo.ml 2009-05-26 09:42:42 UTC (rev 338)
+++ trunk/src/mkProjectInfo.ml 2009-05-26 13:42:55 UTC (rev 339)
@@ -152,3 +152,4 @@
+
Modified: trunk/src/remote.ml
===================================================================
--- trunk/src/remote.ml 2009-05-26 09:42:42 UTC (rev 338)
+++ trunk/src/remote.ml 2009-05-26 13:42:55 UTC (rev 339)
@@ -33,18 +33,18 @@
(****)
let encodeInt m =
- let int_buf = String.create 4 in
- String.set int_buf 0 (Char.chr ( m land 0xff));
- String.set int_buf 1 (Char.chr ((m lsr 8) land 0xff));
- String.set int_buf 2 (Char.chr ((m lsr 16) land 0xff));
- String.set int_buf 3 (Char.chr ((m lsr 24) land 0xff));
+ let int_buf = Bytearray.create 4 in
+ int_buf.{0} <- Char.chr ( m land 0xff);
+ int_buf.{1} <- Char.chr ((m lsr 8) land 0xff);
+ int_buf.{2} <- Char.chr ((m lsr 16) land 0xff);
+ int_buf.{3} <- Char.chr ((m lsr 24) land 0xff);
int_buf
-let decodeInt int_buf =
- let b0 = Char.code (String.get int_buf 0) in
- let b1 = Char.code (String.get int_buf 1) in
- let b2 = Char.code (String.get int_buf 2) in
- let b3 = Char.code (String.get int_buf 3) in
+let decodeInt int_buf i =
+ let b0 = Char.code (int_buf.{i + 0}) in
+ let b1 = Char.code (int_buf.{i + 1}) in
+ let b2 = Char.code (int_buf.{i + 2}) in
+ let b3 = Char.code (int_buf.{i + 3}) in
((b3 lsl 24) lor (b2 lsl 16) lor (b1 lsl 8) lor b0)
(*************************************************************************)
@@ -76,7 +76,7 @@
outputChannel : Unix.file_descr;
outputBuffer : string;
mutable outputLength : int;
- outputQueue : (string * int * int) list Queue.t;
+ outputQueue : (Bytearray.t * int * int) list Queue.t;
mutable pendingOutput : bool;
mutable flowControl : bool;
mutable canWrite : bool;
@@ -114,7 +114,7 @@
grab_rec conn s pos len)
end else begin
let l = min (len - pos) conn.inputLength in
- String.blit conn.inputBuffer 0 s pos l;
+ Bytearray.blit_from_string conn.inputBuffer 0 s pos l;
conn.inputLength <- conn.inputLength - l;
if conn.inputLength > 0 then
String.blit conn.inputBuffer l conn.inputBuffer 0 conn.inputLength;
@@ -126,7 +126,7 @@
let grab conn s len =
assert (len > 0);
- assert (String.length s <= len);
+ assert (Bytearray.length s <= len);
grab_rec conn s 0 len
let peek_without_blocking conn =
@@ -158,7 +158,7 @@
fill_buffer_2 conn s pos len)
else begin
let l = min (len - pos) (outputBuffer_size - conn.outputLength) in
- String.blit s pos conn.outputBuffer conn.outputLength l;
+ Bytearray.blit_to_string s pos conn.outputBuffer conn.outputLength l;
conn.outputLength <- conn.outputLength + l;
if pos + l < len then
fill_buffer_2 conn s (pos + l) len
@@ -171,7 +171,7 @@
(s, pos, len) :: rem ->
assert (pos >= 0);
assert (len >= 0);
- assert (pos + len <= String.length s);
+ assert (pos <= Bytearray.length s - len);
fill_buffer_2 conn s pos len >>= (fun () ->
fill_buffer conn rem)
| [] ->
@@ -331,11 +331,11 @@
(* MARSHALING *)
(*****************************************************************************)
-type tag = string
+type tag = Bytearray.t
type 'a marshalFunction =
- 'a -> (string * int * int) list -> (string * int * int) list
-type 'a unmarshalFunction = string -> 'a
+ 'a -> (Bytearray.t * int * int) list -> (Bytearray.t * int * int) list
+type 'a unmarshalFunction = Bytearray.t -> 'a
type 'a marshalingFunctions = 'a marshalFunction * 'a unmarshalFunction
let registeredSet = ref Util.StringSet.empty
@@ -346,9 +346,9 @@
""
| (s, p, l) :: rem ->
if l < len then
- String.sub s p l ^ first_chars (len - l) rem
+ Bytearray.sub s p l ^ first_chars (len - l) rem
else
- String.sub s p len
+ Bytearray.sub s p len
(* An integer just a little smaller than the maximum representable in 30 bits *)
let hugeint = 1000000000
@@ -359,50 +359,47 @@
let start = first_chars (min length 10) rem' in
let start = if length > 10 then start ^ "..." else start in
let start = String.escaped start in
- Util.msg "Fatal error in safeMarshal: sending too many (%d) bytes with tag %s and contents [%s]\n" length tag start;
+ Util.msg "Fatal error in safeMarshal: sending too many (%d) bytes with tag %s and contents [%s]\n" length (Bytearray.to_string tag) start;
raise (Util.Fatal ((Printf.sprintf
- "Message payload too large (%d, %s, [%s]). \n" length tag start)
+ "Message payload too large (%d, %s, [%s]). \n"
+ length (Bytearray.to_string tag) start)
^ "This is a bug in Unison; if it happens to you in a repeatable way, \n"
^ "please post a report on the unison-users mailing list."))
end;
- let l = String.length tag in
+ let l = Bytearray.length tag in
debugE (fun() ->
let start = first_chars (min length 10) rem' in
let start = if length > 10 then start ^ "..." else start in
let start = String.escaped start in
- Util.msg "send [%s] '%s' %d bytes\n" tag start length);
+ Util.msg "send [%s] '%s' %d bytes\n"
+ (Bytearray.to_string tag) start length);
((encodeInt (l + length), 0, 4) :: (tag, 0, l) :: rem')
let safeUnmarshal unmarshalPayload tag buf =
- let taglength = String.length tag in
- let identifier = String.sub buf 0 (min taglength (String.length buf)) in
- if identifier = tag then
+ let taglength = Bytearray.length tag in
+ if Bytearray.prefix tag buf 0 then
unmarshalPayload buf taglength
else
+ let identifier =
+ String.escaped
+ (Bytearray.sub buf 0 (min taglength (Bytearray.length buf))) in
raise (Util.Fatal
- (Printf.sprintf "[safeUnmarshal] expected %s but got %s"
- tag identifier))
+ (Printf.sprintf "[safeUnmarshal] expected '%s' but got '%s'"
+ (String.escaped (Bytearray.to_string tag)) identifier))
let registerTag string =
if Util.StringSet.mem string !registeredSet then
raise (Util.Fatal (Printf.sprintf "tag %s is already registered" string))
else
registeredSet := Util.StringSet.add string !registeredSet;
- string
+ Bytearray.of_string string
let defaultMarshalingFunctions =
(fun data rem ->
- try
- let s = Marshal.to_string data [Marshal.No_sharing] in
- let l = String.length s in
- ((s, 0, String.length s) :: rem, l)
- with Out_of_memory ->
- raise (Util.Fatal
- "Trying to transfer too much data in one go.\n\
- If this happens during update detection, try to\n\
- synchronize smaller pieces of the replica first\n\
- using the \"path\" directive.")),
- (fun buf pos -> Marshal.from_string buf pos)
+ let s = Bytearray.marshal data [Marshal.No_sharing] in
+ let l = Bytearray.length s in
+ ((s, 0, l) :: rem, l)),
+ (fun buf pos -> Bytearray.unmarshal buf pos)
let makeMarshalingFunctions payloadMarshalingFunctions string =
let (marshalPayload, unmarshalPayload) = payloadMarshalingFunctions in
@@ -529,24 +526,24 @@
let receivePacket conn =
(* Get the length of the packet *)
- let int_buf = String.create 4 in
+ let int_buf = Bytearray.create 4 in
grab conn int_buf 4 >>= (fun () ->
- let length = decodeInt int_buf in
+ let length = decodeInt int_buf 0 in
assert (length >= 0);
(* Get packet *)
- let buf = String.create length in
+ let buf = Bytearray.create length in
grab conn buf length >>= (fun () ->
(debugE (fun () ->
let start =
- if length > 10 then (String.sub buf 0 10) ^ "..."
- else String.sub buf 0 length in
+ if length > 10 then (Bytearray.sub buf 0 10) ^ "..."
+ else Bytearray.sub buf 0 length in
let start = String.escaped start in
Util.msg "receive '%s' %d bytes\n" start length);
Lwt.return buf)))
type servercmd =
- connection -> string ->
- ((string * int * int) list -> (string * int * int) list) Lwt.t
+ connection -> Bytearray.t ->
+ ((Bytearray.t * int * int) list -> (Bytearray.t * int * int) list) Lwt.t
let serverCmds = ref (Util.StringMap.empty : servercmd Util.StringMap.t)
type header =
@@ -565,16 +562,16 @@
in
Lwt.try_bind (fun () -> cmd conn buf)
(fun marshal ->
- debugE (fun () -> Util.msg "Sending result (id: %d)\n" (decodeInt id));
+ debugE (fun () -> Util.msg "Sending result (id: %d)\n" (decodeInt id 0));
dump conn ((id, 0, 4) :: marshalHeader NormalResult (marshal [])))
(function
Util.Transient s ->
debugE (fun () ->
- Util.msg "Sending transient exception (id: %d)\n" (decodeInt id));
+ Util.msg "Sending transient exception (id: %d)\n" (decodeInt id 0));
dump conn ((id, 0, 4) :: marshalHeader (TransientExn s) [])
| Util.Fatal s ->
debugE (fun () ->
- Util.msg "Sending fatal exception (id: %d)\n" (decodeInt id));
+ Util.msg "Sending fatal exception (id: %d)\n" (decodeInt id 0));
dump conn ((id, 0, 4) :: marshalHeader (FatalExn s) [])
| e ->
Lwt.fail e)
@@ -605,9 +602,9 @@
Lwt.return ()) >>= (fun () ->
debugE (fun () -> Util.msg "Waiting for next message\n");
(* Get the message ID *)
- let id = String.create 4 in
+ let id = Bytearray.create 4 in
grab conn id 4 >>= (fun () ->
- let num_id = decodeInt id in
+ let num_id = decodeInt id 0 in
if num_id = 0 then begin
debugE (fun () -> Util.msg "Received the write permission\n");
allowWrites conn;
@@ -752,12 +749,14 @@
let connectionHeader = "Unison " ^ Uutil.myMajorVersion ^ "\n"
-let rec checkHeader conn prefix buffer pos len =
+let rec checkHeader conn buffer pos len =
if pos = len then
Lwt.return ()
else begin
(grab conn buffer 1 >>= (fun () ->
- if buffer.[0] <> connectionHeader.[pos] then
+ if buffer.{0} <> connectionHeader.[pos] then
+ let prefix =
+ String.sub connectionHeader 0 pos ^ Bytearray.to_string buffer in
let rest = peek_without_blocking conn in
Lwt.fail
(Util.Fatal
@@ -765,15 +764,15 @@
expected \""
^ String.escaped (* (String.sub connectionHeader 0 (pos + 1)) *)
connectionHeader
- ^ "\" but received \"" ^ String.escaped (prefix ^ buffer ^ rest) ^ "\", \n"
- ^ "which differs at \"" ^ String.escaped (prefix ^ buffer) ^ "\".\n"
+ ^ "\" but received \"" ^ String.escaped (prefix ^ rest) ^ "\", \n"
+ ^ "which differs at \"" ^ String.escaped prefix ^ "\".\n"
^ "This can happen because you have different versions of Unison\n"
^ "installed on the client and server machines, or because\n"
^ "your connection is failing and somebody is printing an error\n"
^ "message, or because your remote login shell is printing\n"
^ "something itself before starting Unison."))
else
- checkHeader conn (prefix ^ buffer) buffer (pos + 1) len))
+ checkHeader conn buffer (pos + 1) len))
end
(****)
@@ -808,7 +807,8 @@
ignore(Sys.set_signal Sys.sigpipe Sys.Signal_ignore);
let conn = setupIO in_ch out_ch in
conn.canWrite <- false;
- checkHeader conn "" " " 0 (String.length connectionHeader) >>= (fun () ->
+ checkHeader
+ conn (Bytearray.create 1) 0 (String.length connectionHeader) >>= (fun () ->
Lwt.ignore_result (receive conn);
negociateFlowControl conn >>= (fun () ->
Lwt.return conn))
@@ -1144,7 +1144,8 @@
let conn = setupIO in_ch out_ch in
try
Lwt_unix.run
- (dump conn [(connectionHeader, 0, String.length connectionHeader)]
+ (dump conn [(Bytearray.of_string connectionHeader, 0,
+ String.length connectionHeader)]
>>= (fun () ->
(* Set the local warning printer to make an RPC to the client and
show the warning there; ditto for the message printer *)
Modified: trunk/src/remote.mli
===================================================================
--- trunk/src/remote.mli 2009-05-26 09:42:42 UTC (rev 338)
+++ trunk/src/remote.mli 2009-05-26 13:42:55 UTC (rev 339)
@@ -83,16 +83,19 @@
string -> (connection -> 'a -> 'b Lwt.t) -> connection -> 'a -> 'b Lwt.t
val registerSpecialServerCmd :
string ->
- ('a -> (string * int * int) list -> (string * int * int) list * int) *
- (string -> int -> 'a) ->
- ('b -> (string * int * int) list -> (string * int * int) list * int) *
- (string -> int -> 'b) ->
+ ('a ->
+ (Bytearray.t * int * int) list -> (Bytearray.t * int * int) list * int) *
+ (Bytearray.t -> int -> 'a) ->
+ ('b ->
+ (Bytearray.t * int * int) list -> (Bytearray.t * int * int) list * int) *
+ (Bytearray.t -> int -> 'b) ->
(connection -> 'a -> 'b Lwt.t) -> connection -> 'a -> 'b Lwt.t
val defaultMarshalingFunctions :
- ('a -> (string * int * int) list -> (string * int * int) list * int) *
- (string -> int -> 'b)
-val encodeInt : int -> string
-val decodeInt : string -> int
+ ('a ->
+ (Bytearray.t * int * int) list -> (Bytearray.t * int * int) list * int) *
+ (Bytearray.t -> int -> 'b)
+val encodeInt : int -> Bytearray.t
+val decodeInt : Bytearray.t -> int -> int
val registerRootCmdWithConnection :
string (* command name *)
-> (connection -> 'a -> 'b Lwt.t) (* local command *)
Modified: trunk/src/transfer.ml
===================================================================
--- trunk/src/transfer.ml 2009-05-26 09:42:42 UTC (rev 338)
+++ trunk/src/transfer.ml 2009-05-26 13:42:55 UTC (rev 339)
@@ -56,7 +56,7 @@
open Lwt
-type transfer_instruction = string * int * int
+type transfer_instruction = Bytearray.t * int * int
type transmitter = transfer_instruction -> unit Lwt.t
@@ -100,7 +100,7 @@
let maxQueueSize = 65500
let maxQueueSizeFS = Uutil.Filesize.ofInt maxQueueSize
type tokenQueue =
- { mutable data : string; (* the queued tokens *)
+ { mutable data : Bytearray.t; (* the queued tokens *)
mutable previous : [`Str of int | `Block of int | `None];
(* some informations about the
previous token *)
@@ -117,29 +117,29 @@
let encodeInt3 s pos i =
assert (i >= 0 && i < 256 * 256 * 256);
- s.[pos + 0] <- Char.chr ((i lsr 0) land 0xff);
- s.[pos + 1] <- Char.chr ((i lsr 8) land 0xff);
- s.[pos + 2] <- Char.chr ((i lsr 16) land 0xff)
+ s.{pos + 0} <- Char.chr ((i lsr 0) land 0xff);
+ s.{pos + 1} <- Char.chr ((i lsr 8) land 0xff);
+ s.{pos + 2} <- Char.chr ((i lsr 16) land 0xff)
let decodeInt3 s pos =
- (Char.code s.[pos + 0] lsl 0) lor
- (Char.code s.[pos + 1] lsl 8) lor
- (Char.code s.[pos + 2] lsl 16)
+ (Char.code s.{pos + 0} lsl 0) lor
+ (Char.code s.{pos + 1} lsl 8) lor
+ (Char.code s.{pos + 2} lsl 16)
let encodeInt2 s pos i =
assert (i >= 0 && i < 65536);
- s.[pos + 0] <- Char.chr ((i lsr 0) land 0xff);
- s.[pos + 1] <- Char.chr ((i lsr 8) land 0xff)
+ s.{pos + 0} <- Char.chr ((i lsr 0) land 0xff);
+ s.{pos + 1} <- Char.chr ((i lsr 8) land 0xff)
let decodeInt2 s pos =
- (Char.code s.[pos + 0] lsl 0) lor (Char.code s.[pos + 1] lsl 8)
+ (Char.code s.{pos + 0} lsl 0) lor (Char.code s.{pos + 1} lsl 8)
let encodeInt1 s pos i =
assert (i >= 0 && i < 256);
- s.[pos + 0] <- Char.chr i
+ s.{pos + 0} <- Char.chr i
let decodeInt1 s pos =
- Char.code s.[pos + 0]
+ Char.code s.{pos + 0}
(* Transmit the contents of the tokenQueue *)
let flushQueue q showProgress transmit cond =
@@ -154,34 +154,34 @@
let pushEOF q showProgress transmit =
flushQueue q showProgress transmit
- (q.pos + 1 > String.length q.data) >>= (fun () ->
- q.data.[q.pos] <- 'E';
+ (q.pos + 1 > Bytearray.length q.data) >>= (fun () ->
+ q.data.{q.pos} <- 'E';
q.pos <- q.pos + 1;
q.previous <- `None;
return ())
let pushString q id transmit s pos len =
- flushQueue q id transmit (q.pos + len + 3 > String.length q.data)
+ flushQueue q id transmit (q.pos + len + 3 > Bytearray.length q.data)
>>= (fun () ->
- if q.pos + 3 + len > String.length q.data then begin
+ if q.pos + 3 + len > Bytearray.length q.data then begin
(* The file is longer than expected, so the string does not fit in
the buffer *)
assert (q.pos = 0);
- q.data <- String.create maxQueueSize
+ q.data <- Bytearray.create maxQueueSize
end;
- q.data.[q.pos] <- 'S';
+ q.data.{q.pos} <- 'S';
encodeInt2 q.data (q.pos + 1) len;
- assert (q.pos + 3 + len <= String.length q.data);
- String.blit s pos q.data (q.pos + 3) len;
+ assert (q.pos + 3 + len <= Bytearray.length q.data);
+ Bytearray.blit_from_string s pos q.data (q.pos + 3) len;
q.pos <- q.pos + len + 3;
q.prog <- q.prog + len;
q.previous <- `Str len;
return ())
let rec growString q id transmit len' s pos len =
- let l = min (String.length q.data - q.pos) len in
- String.blit s pos q.data q.pos l;
- assert (q.data.[q.pos - len' - 3] = 'S');
+ let l = min (Bytearray.length q.data - q.pos) len in
+ Bytearray.blit_from_string s pos q.data q.pos l;
+ assert (q.data.{q.pos - len' - 3} = 'S');
assert (decodeInt2 q.data (q.pos - len' - 2) = len');
let len'' = len' + l in
encodeInt2 q.data (q.pos - len' - 2) len'';
@@ -194,8 +194,8 @@
return ()
let pushBlock q id transmit pos =
- flushQueue q id transmit (q.pos + 5 > String.length q.data) >>= (fun () ->
- q.data.[q.pos] <- 'B';
+ flushQueue q id transmit (q.pos + 5 > Bytearray.length q.data) >>= (fun () ->
+ q.data.{q.pos} <- 'B';
encodeInt3 q.data (q.pos + 1) pos;
encodeInt1 q.data (q.pos + 4) 1;
q.pos <- q.pos + 5;
@@ -205,7 +205,7 @@
let growBlock q id transmit pos =
let count = decodeInt1 q.data (q.pos - 1) in
- assert (q.data.[q.pos - 5] = 'B');
+ assert (q.data.{q.pos - 5} = 'B');
assert (decodeInt3 q.data (q.pos - 4) + count = pos);
assert (count < 255);
encodeInt1 q.data (q.pos - 1) (count + 1);
@@ -234,7 +234,7 @@
(* We need to make sure here that the size of the queue is not
larger than 65538
(1 byte: header, 2 bytes: string size, 65535 bytes: string) *)
- String.create
+ Bytearray.create
(if length > maxQueueSizeFS then maxQueueSize else
Uutil.Filesize.toInt length + 10);
pos = 0; previous = `None; prog = 0 }
@@ -272,12 +272,12 @@
let rec receiveRec outfd showProgress data pos maxPos =
if pos = maxPos then false else
- match data.[pos] with
+ match data.{pos} with
'S' ->
let length = decodeInt2 data (pos + 1) in
if Trace.enabled "generic" then debug (fun() -> Util.msg
"receiving %d bytes\n" length);
- reallyWrite outfd data (pos + 3) length;
+ reallyWrite outfd (Bytearray.sub data (pos + 3) length) 0 length;
showProgress length;
receiveRec outfd showProgress data (pos + length + 3) maxPos
| 'E' ->
@@ -403,13 +403,13 @@
let maxPos = pos + len in
let rec decode pos =
if pos = maxPos then false else
- match data.[pos] with
+ match data.{pos} with
'S' ->
let length = decodeInt2 data (pos + 1) in
if Trace.enabled "rsynctoken" then
debugToken (fun() ->
Util.msg "decompressing string (%d bytes)\n" length);
- reallyWrite outfd data (pos + 3) length;
+ reallyWrite outfd (Bytearray.sub data (pos + 3) length) 0 length;
progress := !progress + length;
decode (pos + length + 3)
| 'B' ->
Modified: trunk/src/transfer.mli
===================================================================
--- trunk/src/transfer.mli 2009-05-26 09:42:42 UTC (rev 338)
+++ trunk/src/transfer.mli 2009-05-26 13:42:55 UTC (rev 339)
@@ -37,7 +37,7 @@
(* Transfer instruction giving data to build a file incrementally *)
-type transfer_instruction = string * int * int
+type transfer_instruction = Bytearray.t * int * int
type transmitter = transfer_instruction -> unit Lwt.t
More information about the Unison-hackers
mailing list