(* $Id: netshm_data.ml 1716 2012-02-20 16:59:27Z gerd $ *) type 'a data_manager = { to_int32_array : 'a -> Netshm.int32_array; of_int32_array : Netshm.int32_array list -> 'a; of_int32_array_prefix : (Netshm.int32_array list -> 'a option) option; hash_fn : 'a -> int32 } let int32_manager = { to_int32_array = (fun n -> let v = Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout 1 in v.{ 0 } <- n; v); of_int32_array = (fun l -> match l with | [ v ] -> if Bigarray.Array1.dim v <> 1 then raise(Netshm.Corrupt_file "Netshm_data.int32_manager: Cannot decode"); v.{ 0 } | _ -> raise(Netshm.Corrupt_file "Netshm_data.int32_manager: Cannot decode") ); of_int32_array_prefix = None; hash_fn = (fun n -> n) } let int64_manager = { to_int32_array = (fun n -> let v = Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout 2 in v.{ 0 } <- Int64.to_int32 (Int64.shift_right_logical n 32); v.{ 1 } <- Int64.to_int32 n; v); of_int32_array = (fun l -> match l with | [ v ] -> if Bigarray.Array1.dim v <> 2 then raise(Netshm.Corrupt_file "Netshm_data.int64_manager: Cannot decode"); Int64.logor (Int64.shift_left (Int64.of_int32 v.{ 0 }) 32) (Int64.logand (Int64.of_int32 v.{ 1 }) 0xffff_ffffL) | [ v; u ] -> (* Note: reverse order! *) if Bigarray.Array1.dim u <> 1 || Bigarray.Array1.dim v <> 1 then raise(Netshm.Corrupt_file "Netshm_data.int64_manager: Cannot decode"); Int64.logor (Int64.shift_left (Int64.of_int32 u.{ 0 }) 32) (Int64.logand (Int64.of_int32 v.{ 0 }) 0xffff_ffffL) | _ -> raise(Netshm.Corrupt_file "Netshm_data.int64_manager: Cannot decode") ); of_int32_array_prefix = None; hash_fn = Int64.to_int32 } let sel_32_or_64_manager to32 of32 to64 of64 = match Sys.word_size with | 32 -> { to_int32_array = (fun n -> int32_manager.to_int32_array (to32 n)); of_int32_array = (fun l -> of32 (int32_manager.of_int32_array l)); of_int32_array_prefix = None; hash_fn = to32 } | 64 -> { to_int32_array = (fun n -> int64_manager.to_int32_array (to64 n)); of_int32_array = (fun l -> of64 (int64_manager.of_int32_array l)); of_int32_array_prefix = None; hash_fn = (fun n -> Int64.to_int32 (to64 n)) } | _ -> assert false let nativeint_manager = sel_32_or_64_manager Nativeint.to_int32 Nativeint.of_int32 Int64.of_nativeint Int64.to_nativeint let int_manager = sel_32_or_64_manager Int32.of_int Int32.to_int Int64.of_int Int64.to_int let int32_array_manager = { to_int32_array = (fun v -> v); of_int32_array = (fun l -> let size = List.fold_left (fun acc v -> acc + Bigarray.Array1.dim v) 0 l in let v_total = Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout size in let size' = List.fold_left (fun start' v -> let len = Bigarray.Array1.dim v in let start = start' - len in Bigarray.Array1.blit v (Bigarray.Array1.sub v_total start len); start) size l in assert(size' = 0); v_total); of_int32_array_prefix = None; hash_fn = (fun v -> Int32.of_int (Hashtbl.hash v)) } let string_manager = { to_int32_array = (fun s -> let s_len = String.length s in if Int32.of_int s_len > Int32.max_int then failwith "Netshm_data: string too long"; let size = if s_len = 0 then 1 else (s_len - 1) / 4 + 2 in let v = Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout size in v.{ 0 } <- Int32.of_int s_len; let m = Netsys_mem.memory_of_bigarray_1 v in Netsys_mem.blit_string_to_memory s 0 m 4 s_len; v ); of_int32_array = (fun l -> if l = [] then raise(Netshm.Corrupt_file "Netshm_data.string_manager: Cannot decode"); let size = ref 0 in let v_last = ref None in List.iter (fun v -> size := !size + Bigarray.Array1.dim v; v_last := Some v ) l; let s_len = ( match !v_last with | None -> assert false | Some v -> if Bigarray.Array1.dim v = 0 then raise(Netshm.Corrupt_file "Netshm_data.string_manager: Cannot decode"); Int32.to_int v.{ 0 } ) in let s_len_4 = s_len mod 4 in let size' = if s_len = 0 then 1 else (s_len - 1) / 4 + 2 in if !size <> size' then raise(Netshm.Corrupt_file "Netshm_data.string_manager: Cannot decode"); let pos = ref !size in let s = String.create s_len in let s_pos = ref s_len in List.iter (fun v -> let l = Bigarray.Array1.dim v in let has_last_content_word = !pos = !size && s_len > 0 in pos := !pos - l; let has_length_word = !pos = 0 in let m = Netsys_mem.memory_of_bigarray_1 v in let bsize = 4 * l - (if has_last_content_word && s_len_4 <> 0 then 4 - s_len_4 else 0 ) - (if has_length_word then 4 else 0 ) in s_pos := !s_pos - bsize; Netsys_mem.blit_memory_to_string m (if has_length_word then 4 else 0) s !s_pos bsize; ) l; assert (!pos = 0); assert (!s_pos = 0); s ); of_int32_array_prefix = None; hash_fn = (fun v -> Int32.of_int (Hashtbl.hash v)) } let pair_manager x_manager y_manager = { to_int32_array = (fun (x,y) -> let vx = x_manager.to_int32_array x in let vy = y_manager.to_int32_array y in let lx = Bigarray.Array1.dim vx in let ly = Bigarray.Array1.dim vy in let size = lx + ly + 1 in let v = Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout size in v.{ 0 } <- Int32.of_int lx; Bigarray.Array1.blit vx (Bigarray.Array1.sub v 1 lx); Bigarray.Array1.blit vy (Bigarray.Array1.sub v (lx+1) ly); v ); of_int32_array = (fun l -> if l = [] then raise(Netshm.Corrupt_file "Netshm_data.pair_manager: Cannot decode"); let l' = List.rev l in let vl = List.hd l' in assert(Bigarray.Array1.dim vl > 0); let lx = Int32.to_int vl.{0} in let l1 = ref [] in let l2 = ref [] in let c1 = ref 0 in List.iter (fun v -> let l = Bigarray.Array1.dim v in let p0 = if !c1 = 0 then 1 else 0 in let p1 = if !c1 < lx then ( let r = min (l - p0) (lx - !c1) in if p0 = 0 && r = l then l1 := v :: !l1 else l1 := (Bigarray.Array1.sub v p0 r) :: !l1; c1 := !c1 + r; p0+r ) else p0 in if !c1 = lx then ( let r = l - p1 in if p1 = 0 then l2 := v :: !l2 else l2 := (Bigarray.Array1.sub v p1 r) :: !l2; ) ) l'; let x = x_manager.of_int32_array !l1 in let y = y_manager.of_int32_array !l2 in (x,y) ); of_int32_array_prefix = None; hash_fn = (fun v -> Int32.of_int (Hashtbl.hash v)) } let left_pair_manager x_manager = { to_int32_array = (fun x -> failwith "Netshm_data.left_pair_manager: Encoding not supported" ); of_int32_array = (fun l -> if l = [] then raise(Netshm.Corrupt_file "Netshm_data.left_pair_manager: Cannot decode"); let l' = List.rev l in let vl = List.hd l' in let lx = Int32.to_int vl.{0} in let l1 = ref [] in let c1 = ref 0 in List.iter (fun v -> let l = Bigarray.Array1.dim v in let p0 = if !c1 = 0 then 1 else 0 in if !c1 < lx then ( let r = min (l - p0) (lx - !c1) in if p0 = 0 && r = l then l1 := v :: !l1 else l1 := (Bigarray.Array1.sub v p0 r) :: !l1; c1 := !c1 + r; ); ) l'; x_manager.of_int32_array !l1 ); of_int32_array_prefix = Some (fun l -> let size = ref 0 in let last = ref None in List.iter (fun v -> size := !size + Bigarray.Array1.dim v; last := Some v ) l; ( match !last with | None -> None | Some last -> let lx = Int32.to_int last.{0} in if !size >= lx + 1 then ( let l1 = ref [] in let c1 = ref 0 in List.iter (fun v -> let l = Bigarray.Array1.dim v in let p0 = if !c1 = 0 then 1 else 0 in if !c1 < lx then ( let r = min (l - p0) (lx - !c1) in if p0 = 0 && r = l then l1 := v :: !l1 else l1 := (Bigarray.Array1.sub v p0 r) :: !l1; c1 := !c1 + r; ); ) (List.rev l); Some(x_manager.of_int32_array !l1) ) else None ) ); hash_fn = (fun v -> Int32.of_int (Hashtbl.hash v)) } let option_manager x_manager = { to_int32_array = (fun x_opt -> match x_opt with | Some x -> let vx = x_manager.to_int32_array x in let lx = Bigarray.Array1.dim vx in let v = Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout (lx+1) in v.{ 0 } <- 1l; Bigarray.Array1.blit vx (Bigarray.Array1.sub v 1 lx); v | None -> let v = Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout 1 in v.{ 0 } <- 0l; v ); of_int32_array = (fun l -> if l = [] then raise(Netshm.Corrupt_file "Netshm_data.option_manager: Cannot decode"); let l' = List.rev l in let vl = List.hd l' in let x0 = vl.{0} in if x0 = 0l then ( if Bigarray.Array1.dim vl <> 1 || List.length l <> 1 then raise(Netshm.Corrupt_file "Netshm_data.option_manager: Cannot decode"); None ) else if x0 = 1l then ( let l1 = ref [] in let is_first = ref true in List.iter (fun v -> if !is_first then ( let l = Bigarray.Array1.dim v in l1 := (Bigarray.Array1.sub v 1 (l-1)) :: !l1 ) else l1 := v :: !l1; is_first := false ) l'; Some(x_manager.of_int32_array !l1) ) else raise(Netshm.Corrupt_file "Netshm_data.option_manager: Cannot decode") ); of_int32_array_prefix = None; hash_fn = (fun v -> Int32.of_int (Hashtbl.hash v)) }