From: Goswin von Brederlow <goswin-v-b@web.de>
Date: Wed, 17 Mar 2010 05:56:56 +0200
Subject: [PATCH] Rewrite digest module

---
 md5.c |   46 ++++++++++++++++++++++++++++++++++++++++++++++
 md5.h |    4 ++++
 2 files changed, 50 insertions(+)

Index: ocaml-3.11.2.new/byterun/md5.c
===================================================================
--- ocaml-3.11.2.new.orig/byterun/md5.c	2010-03-18 12:08:19.000000000 +0100
+++ ocaml-3.11.2.new/byterun/md5.c	2010-03-18 16:04:25.000000000 +0100
@@ -21,9 +21,107 @@
 #include "mlvalues.h"
 #include "io.h"
 #include "reverse.h"
+#include "custom.h"
+#include "intext.h"
 
 /* MD5 message digest */
 
+static void caml_md5_context_finalize(value context)
+{
+  struct MD5Context *ctx = *(struct MD5Context**)Data_custom_val(context);
+  free(ctx);
+}
+
+static int caml_md5_context_compare(value v1, value v2)
+{
+  struct MD5Context *ctx1 = *(struct MD5Context**)Data_custom_val(v1);
+  struct MD5Context *ctx2 = *(struct MD5Context**)Data_custom_val(v2);
+  int i;
+#define CMP(x) if (ctx1->x != ctx2->x) return ctx1->x < ctx2->x ? -1 : 1
+  for(i = 0; i < 4; ++i) CMP(buf[i]);
+  for(i = 0; i < 2; ++i) CMP(bits[i]);
+  for(i = 0; i < 64; ++i) CMP(in[i]);
+#undef CMP
+  return 0;
+}
+
+static intnat caml_md5_context_hash(value v)
+{
+  struct MD5Context *ctx = *(struct MD5Context**)Data_custom_val(v);
+  unsigned long long t = 0;
+  int i;
+  // FIXME: Find larger prime number smaller than max_int on 32bit
+#define UPDATE(x) t = ((t << (sizeof(x) * 8)) + x) % 1073741789
+  for(i = 0; i < 4; ++i) UPDATE(ctx->buf[i]);
+  for(i = 0; i < 2; ++i) UPDATE(ctx->bits[i]);
+  for(i = 0; i < 64; ++i) UPDATE(ctx->in[i]);
+#undef UPDATE
+  return t;
+}
+
+static void caml_md5_context_serialize(value v,
+				       uintnat * wsize_32,
+				       uintnat * wsize_64)
+{
+  struct MD5Context *ctx = *(struct MD5Context**)Data_custom_val(v);
+  *wsize_32 = sizeof(struct MD5Context);
+  *wsize_64 = sizeof(struct MD5Context);
+  caml_serialize_block_4(ctx->buf, 4);
+  caml_serialize_block_4(ctx->bits, 2);
+  caml_serialize_block_1(ctx->in, 64);
+}
+
+uintnat caml_md5_context_deserialize(void * dst)
+{
+  struct MD5Context **pctx = (struct MD5Context **)dst;
+  *pctx = malloc(sizeof(struct MD5Context));
+  if (*pctx == NULL) caml_deserialize_error("Out of memory");
+  caml_deserialize_block_4((*pctx)->buf, 4);
+  caml_deserialize_block_4((*pctx)->bits, 2);
+  caml_deserialize_block_1((*pctx)->in, 64);
+
+  return sizeof(struct MD5Context);
+}
+
+/* FIXME: write other custom functions */
+static struct custom_operations caml_md5_context_ops = {
+  "_md5_context",
+  caml_md5_context_finalize,
+  caml_md5_context_compare,
+  caml_md5_context_hash,
+  caml_md5_context_serialize,
+  caml_md5_context_deserialize
+};
+
+CAMLprim value caml_md5_context(void)
+{
+  value context = caml_alloc_custom(&caml_md5_context_ops,
+				    sizeof(struct MD5Context*),
+				    sizeof(struct MD5Context),
+				    sizeof(struct MD5Context) * 100);
+  struct MD5Context **ctx = (struct MD5Context **)Data_custom_val(context);
+  *ctx = malloc(sizeof(struct MD5Context));
+  if (*ctx == NULL) caml_raise_out_of_memory();
+  caml_MD5Init(*ctx);
+  return context;
+}
+
+CAMLprim value caml_md5_update_string(value context,
+				      value str, value ofs, value len)
+{
+  struct MD5Context *ctx = *(struct MD5Context**)Data_custom_val(context);
+  caml_MD5Update(ctx, &Byte_u(str, Long_val(ofs)), Long_val(len));
+  return Val_unit;
+}
+
+CAMLprim value caml_md5_final(value context)
+{
+  struct MD5Context ctx = **(struct MD5Context**)Data_custom_val(context);
+  value res = caml_alloc_string(16);
+  caml_MD5Final(&Byte_u(res, 0), &ctx);
+  return res;
+}
+
 CAMLprim value caml_md5_string(value str, value ofs, value len)
 {
   struct MD5Context ctx;
Index: ocaml-3.11.2.new/byterun/md5.h
===================================================================
--- ocaml-3.11.2.new.orig/byterun/md5.h	2010-03-18 12:08:19.000000000 +0100
+++ ocaml-3.11.2.new/byterun/md5.h	2010-03-18 12:09:23.000000000 +0100
@@ -22,6 +22,10 @@
 #include "mlvalues.h"
 #include "io.h"
 
+CAMLextern value caml_md5_context (void);
+CAMLextern value caml_md5_update_string (value context,
+					 value str, value ofs, value len);
+CAMLextern value caml_md5_final (value context);
 CAMLextern value caml_md5_string (value str, value ofs, value len);
 CAMLextern value caml_md5_chan (value vchan, value len);
 

From: Goswin von Brederlow <goswin-v-b@web.de>
Date: Wed, 17 Mar 2010 05:56:56 +0200
Subject: [PATCH] Rewrite digest module

---
 otherlibs/bigarray/bigarray.h       |    2 ++
 otherlibs/bigarray/bigarray.ml      |   11 +++++++++++
 otherlibs/bigarray/bigarray.mli     |   10 ++++++++++
 otherlibs/bigarray/bigarray_stubs.c |   15 +++++++++++++++
 stdlib/digest.ml                    |   13 +++++++++++++
 stdlib/digest.mli                   |   28 ++++++++++++++++++++++++++++
 6 files changed, 79 insertions(+)

Index: ocaml-3.11.2.new/stdlib/digest.ml
===================================================================
--- ocaml-3.11.2.new.orig/stdlib/digest.ml	2010-03-18 12:06:06.000000000 +0100
+++ ocaml-3.11.2.new/stdlib/digest.ml	2010-03-18 12:07:36.000000000 +0100
@@ -16,8 +16,13 @@
 (* Message digest (MD5) *)
 
 type t = string
+type context
 
+external context: unit -> context = "caml_md5_context"
 external unsafe_string: string -> int -> int -> t = "caml_md5_string"
+external unsafe_update_string: context -> string -> int -> int -> unit
+  = "caml_md5_update_string" "noalloc"
+external final: context -> t = "caml_md5_final"
 external channel: in_channel -> int -> t = "caml_md5_chan"
 
 let string str =
@@ -28,6 +33,14 @@
   then invalid_arg "Digest.substring"
   else unsafe_string str ofs len
 
+let update_string context str =
+  unsafe_update_string context str 0 (String.length str)
+
+let update_substring context str ofs len =
+  if ofs < 0 || len < 0 || ofs > String.length str - len
+  then invalid_arg "Digest.update_substring"
+  else unsafe_update_string context str ofs len
+
 let file filename =
   let ic = open_in_bin filename in
   let d = channel ic (-1) in
Index: ocaml-3.11.2.new/stdlib/digest.mli
===================================================================
--- ocaml-3.11.2.new.orig/stdlib/digest.mli	2010-03-18 12:06:06.000000000 +0100
+++ ocaml-3.11.2.new/stdlib/digest.mli	2010-03-18 12:07:36.000000000 +0100
@@ -24,6 +24,34 @@
 type t = string
 (** The type of digests: 16-character strings. *)
 
+type context
+(** The type of a digest context. *)
+
+external context : unit -> context = "caml_md5_context"
+(** Return a fresh digest context. *)
+
+external unsafe_update_string : context -> string -> int -> int -> unit
+  = "caml_md5_update_string" "noalloc"
+(** [Digest.unsafe_update_string ctx s ofs len] updates the context
+    to include the substring of [s] starting at character number [ofs]
+    and containing [len] characters. *)
+
+external unsafe_string: string -> int -> int -> t = "caml_md5_string"
+(** [Digest.unsafe_string s ofs len] returns the digest of the
+    substring of [s] starting at character number [ofs] and containing
+    [len] characters. *)
+
+val update_string : context -> string -> unit
+(** [Digest.update_string ctx s ] updates the context to include [s]. *)
+
+val update_substring : context -> string -> int -> int -> unit
+(** [Digest.update_substring ctx s ofs len] updates the context
+    to include the substring of [s] starting at character number [ofs]
+    and containing [len] characters. *)
+
+external final : context -> t = "caml_md5_final"
+(** [Digest.final ctx] computs the final digest from [ctx]. *)
+
 val string : string -> t
 (** Return the digest of the given string. *)
 
Index: ocaml-3.11.2.new/otherlibs/bigarray/bigarray.h
===================================================================
--- ocaml-3.11.2.new.orig/otherlibs/bigarray/bigarray.h	2010-03-18 12:06:06.000000000 +0100
+++ ocaml-3.11.2.new/otherlibs/bigarray/bigarray.h	2010-03-18 12:07:36.000000000 +0100
@@ -93,4 +93,6 @@
                                  ... /*dimensions, with type intnat */);
 CAMLBAextern uintnat caml_ba_byte_size(struct caml_ba_array * b);
 
+CAMLextern value caml_md5_update_bigarray (value context, value array);
+
 #endif
Index: ocaml-3.11.2.new/otherlibs/bigarray/bigarray.ml
===================================================================
--- ocaml-3.11.2.new.orig/otherlibs/bigarray/bigarray.ml	2010-03-18 12:06:06.000000000 +0100
+++ ocaml-3.11.2.new/otherlibs/bigarray/bigarray.ml	2010-03-18 12:07:36.000000000 +0100
@@ -124,6 +124,17 @@
     ba
   let map_file fd ?pos kind layout shared dim =
     Genarray.map_file fd ?pos kind layout shared [|dim|]
+
+  module Digest = struct
+    external update_bigarray: Digest.context -> ('a, 'b, 'c) t -> unit
+      = "caml_md5_update_bigarray"
+
+    let bigarray arr =
+      let context = Digest.context () in
+      let () = update_bigarray context arr
+      in
+	Digest.final context
+  end
 end
 
 module Array2 = struct
Index: ocaml-3.11.2.new/otherlibs/bigarray/bigarray.mli
===================================================================
--- ocaml-3.11.2.new.orig/otherlibs/bigarray/bigarray.mli	2010-03-18 12:06:06.000000000 +0100
+++ ocaml-3.11.2.new/otherlibs/bigarray/bigarray.mli	2010-03-18 12:07:36.000000000 +0100
@@ -507,6 +507,16 @@
       Use with caution and only when the program logic guarantees that
       the access is within bounds. *)
 
+  module Digest : sig
+    external update_bigarray : Digest.context -> ('a, 'b, 'c) t -> unit
+      = "caml_md5_update_bigarray"
+    (** Updates the context to include the bigarray. This function
+	runs concurrent with other threads. *)
+
+    val bigarray : ('a, 'b, 'c) t -> Digest.t
+    (** Return the digest of the given bigarray. This function
+	runs concurrent with other threads. *)
+  end
 end
 
 
Index: ocaml-3.11.2.new/otherlibs/bigarray/bigarray_stubs.c
===================================================================
--- ocaml-3.11.2.new.orig/otherlibs/bigarray/bigarray_stubs.c	2010-03-18 12:06:06.000000000 +0100
+++ ocaml-3.11.2.new/otherlibs/bigarray/bigarray_stubs.c	2010-03-18 12:07:36.000000000 +0100
@@ -23,6 +23,8 @@
 #include "intext.h"
 #include "memory.h"
 #include "mlvalues.h"
+#include "md5.h"
+#include "signals.h"
 
 #define int8 caml_ba_int8
 #define uint8 caml_ba_uint8
@@ -1097,3 +1099,16 @@
   caml_register_custom_operations(&caml_ba_ops);
   return Val_unit;
 }
+
+CAMLprim value caml_md5_update_bigarray(value context, value vb)
+{
+  CAMLparam2(context, vb);
+  struct MD5Context *ctx = *(struct MD5Context**)Data_custom_val(context);
+  struct caml_ba_array * b = Caml_ba_array_val(vb);
+  unsigned char *data = b->data;
+  uintnat len = caml_ba_byte_size(b);
+  caml_enter_blocking_section();
+  caml_MD5Update(ctx, data, len);
+  caml_leave_blocking_section();
+  CAMLreturn(Val_unit);
+}