Version 0.2.6 for release.

[virt-mem.git] / lib / virt_mem_mmap.ml

diff --git a/lib/virt_mem_mmap.ml b/lib/virt_mem_mmap.ml
index f6edee8..3b84a26 100644 (file)
--- a/lib/virt_mem_mmap.ml
+++ b/lib/virt_mem_mmap.ml
@@ -33,7 +33,7 @@ open Virt_mem_utils
 type ('a,'b) t = {
   mappings : mapping list;
   wordsize : wordsize option;
-  endian : Bitmatch.endian option;
+  endian : Bitstring.endian option;
 }
 and mapping = {
   start : addr;
@@ -78,6 +78,25 @@ let of_file fd addr =
   let t = create () in
   add_file t fd addr
 
+let add_string ({ mappings = mappings } as t) str addr =
+  if addr &^ 7L <> 0L then
+    invalid_arg "add_file: mapping address must be aligned to 8 bytes";
+  let size = String.length str in
+  (* Copy the string data to a Bigarray. *)
+  let arr = Array1.create char c_layout size in
+  for i = 0 to size-1 do
+    Array1.set arr i (String.unsafe_get str i)
+  done;
+  (* Create the mapping entry and keep the mappings sorted by start addr. *)
+  let mappings =
+    { start = addr; size = Int64.of_int size; arr = arr } :: mappings in
+  let mappings = sort_mappings mappings in
+  { t with mappings = mappings }
+
+let of_string str addr =
+  let t = create () in
+  add_string t str addr
+
 (* Find in mappings and return first predicate match. *)
 let _find_map { mappings = mappings } pred =
   let rec loop = function
@@ -89,6 +108,15 @@ let _find_map { mappings = mappings } pred =
   in
   loop mappings
 
+(* The following functions are actually written in C
+ * because memmem(3) is likely to be much faster than anything
+ * we could write in OCaml.
+ *
+ * Also OCaml bigarrays are specifically designed to be accessed
+ * easily from C:
+ *   http://caml.inria.fr/pub/docs/manual-ocaml/manual043.html
+ *)
+(*
 (* Array+offset = string? *)
 let string_at arr offset str strlen =
   let j = ref offset in
@@ -125,6 +153,10 @@ let _find_in start align str arr =
     loop ()
   )
   else Some start
+*)
+external _find_in :
+  int -> int -> string -> (char,int8_unsigned_elt,c_layout) Array1.t ->
+  int option = "virt_mem_mmap_find_in"
 
 (* Generic find function. *)
 let _find t start align str =
@@ -181,9 +213,9 @@ and string_of_addr t addr =
   let bits = bits_of_wordsize (get_wordsize t) in
   let e = get_endian t in
   let bs = BITSTRING { addr : bits : endian (e) } in
-  Bitmatch.string_of_bitstring bs
+  Bitstring.string_of_bitstring bs
 *)
-(* XXX bitmatch is missing 'construct_int64_le_unsigned' so we
+(* XXX bitstring is missing 'construct_int64_le_unsigned' so we
  * have to force this to 32 bits for the moment.
  *)
 and string_of_addr t addr =
@@ -191,12 +223,12 @@ and string_of_addr t addr =
   assert (bits = 32);
   let e = get_endian t in
   let bs = BITSTRING { Int64.to_int32 addr : 32 : endian (e) } in
-  Bitmatch.string_of_bitstring bs
+  Bitstring.string_of_bitstring bs
 
 and addr_of_string t str =
   let bits = bits_of_wordsize (get_wordsize t) in
   let e = get_endian t in
-  let bs = Bitmatch.bitstring_of_string str in
+  let bs = Bitstring.bitstring_of_string str in
   bitmatch bs with
   | { addr : bits : endian (e) } -> addr
   | { _ } -> invalid_arg "addr_of_string"
@@ -252,6 +284,30 @@ let get_bytes t addr len =
   with
     Invalid_argument _ -> invalid_arg "get_bytes"
 
+let get_int32 t addr =
+  let e = get_endian t in
+  let str = get_bytes t addr 4 in
+  let bs = Bitstring.bitstring_of_string str in
+  bitmatch bs with
+  | { addr : 32 : endian (e) } -> addr
+  | { _ } -> invalid_arg "follow_pointer"
+
+let get_int64 t addr =
+  let e = get_endian t in
+  let str = get_bytes t addr 8 in
+  let bs = Bitstring.bitstring_of_string str in
+  bitmatch bs with
+  | { addr : 64 : endian (e) } -> addr
+  | { _ } -> invalid_arg "follow_pointer"
+
+let get_C_int = get_int32
+
+let get_C_long t addr =
+  let ws = get_wordsize t in
+  match ws with
+  | W32 -> Int64.of_int32 (get_int32 t addr)
+  | W64 -> get_int64 t addr
+
 let get_string t addr =
   let chars = ref [] in
   try
@@ -317,7 +373,7 @@ let follow_pointer t addr =
   let e = get_endian t in
   let bits = bits_of_wordsize ws in
   let str = get_bytes t addr (bytes_of_wordsize ws) in
-  let bs = Bitmatch.bitstring_of_string str in
+  let bs = Bitstring.bitstring_of_string str in
   bitmatch bs with
   | { addr : bits : endian (e) } -> addr
   | { _ } -> invalid_arg "follow_pointer"