[r2005-03-23 14:03:59 by afrisch] Empty log message

Original author: afrisch
Date: 2005-03-23 14:04:00+00:00

misc/inttbl.ml

@@ -8,6 +8,7 @@ module type S = sig
   val add: 'a t -> key -> 'a -> unit
   val find: 'a t -> key -> 'a
   val mem: 'a t -> key -> bool
+  val remove: 'a t -> key -> unit
 end
 
 type key = int
@@ -29,7 +30,6 @@ let fold t f x =
       aux (pred i) x
   in
   aux (pred (Array.length !t)) x
-    
 
 let add t i x =
   let l = Array.length !t in
@@ -41,6 +41,9 @@ let add t i x =
   );
   (!t).(i) <- Some x
 
+let remove t i =
+  if (i <= Array.length !t) then (!t).(i) <- None
+
 let find t i =
   if i >= Array.length !t then raise Not_found
   else match (!t).(i) with

misc/inttbl.mli

@@ -8,6 +8,7 @@ module type S = sig
   val add: 'a t -> key -> 'a -> unit
   val find: 'a t -> key -> 'a
   val mem: 'a t -> key -> bool
+  val remove: 'a t -> key -> unit
 end
 
 include S with type key = int

runtime/serial.ml

-module T = Custom.Array(Custom.Pair(Types)(Custom.List(Patterns.Node)))
+let cu = Types.CompUnit.mk (Encodings.Utf8.mk "OCAML")
+let () = Types.CompUnit.enter cu; Types.caml_mode := true
+let init = ref []
+let serialize = ref []
+
+module Mk(X : Custom.T) = struct
+  module A = Custom.Array(X)
+  
+  let lst = ref [] and nb = ref (-1)
+  let put x = lst := x :: !lst; incr nb; !nb
+    
+  let init () = lst := []; nb := (-1)
+  let serialize s = Serialize.Put.array X.serialize s 
+		      (Array.of_list (List.rev !lst))
+
+  type 'a entry = Serialized of X.t | Computed of 'a
+  type 'a chunk = 'a entry array
+
+  let deserialize s = 
+    Serialize.Get.array (fun s -> Serialized (X.deserialize s)) s
+
+  let get f a i =
+    match a.(i) with
+      | Serialized x ->
+	  let x = f x in
+	  a.(i) <- Computed x;
+	  x
+      | Computed x ->
+	  x
+end
+
+module PM = Mk(Custom.Pair(Types)(Custom.List(Patterns.Node)))
+module CONST = Mk(Types.Const)
 
 module P = struct
-  let () = Types.CompUnit.enter (Types.CompUnit.mk (Encodings.Utf8.mk "OCAML"))
+  let init () = 
+    PM.init ();
+    CONST.init ()
 
-  let pms = ref [] and nb_pms = ref (-1)
+  let serialize s () =
+    PM.serialize s;
+    CONST.serialize s
 
-  let init () = pms:=[]; nb_pms:=(-1)
-  let mk () = 
-    let pms = Array.of_list (List.rev !pms) in
-    Serialize.Put.run T.serialize pms
+  let pm = PM.put
+  let const = CONST.put
+
+  let mk () =
+    let s = Serialize.Put.run serialize () in
+    ignore (Types.CompUnit.close_serialize ());
+    s
 
-  let pm t = pms:=t::!pms; incr nb_pms; !nb_pms
 end
 
 module G = struct
-  type chunk = 
-      T.t * 
-      (Patterns.Compile.dispatcher * int Patterns.Compile.rhs array) 
-	option array
-	
-	
+  type chunk =
+      { pm :
+	  (Patterns.Compile.dispatcher * int Patterns.Compile.rhs array)
+	  PM.chunk;
+	cst : Value.t CONST.chunk;
+      }
+
+  let deserialize s =
+    let pm = PM.deserialize s in
+    let cst = CONST.deserialize s in
+    { pm = pm; cst = cst }
 
   let mk s = 
-    try
-      let a = Serialize.Get.run T.deserialize s in
-      (a, Array.create (Array.length a) None)
-    with _ -> assert false
-
-  let disp (spec,d) i =
-    match d.(i) with
-      | Some x -> x
-      | None ->
-	  let (t,brs) = spec.(i) in
-	  let brs = 
-	    Array.to_list (Array.mapi (fun i x -> (x,i)) (Array.of_list brs))
-	  in
-	  let x = Patterns.Compile.make_branches t brs in
-	  d.(i) <- Some x;
-	  x
+    Types.clear_deserialize_table ();
+    Serialize.Get.run deserialize s
+
+  let mk_pm (t,brs) =
+    let brs = Array.to_list (Array.mapi (fun i x -> (x,i)) (Array.of_list brs))
+    in
+    Patterns.Compile.make_branches t brs
 
-  let run (chunk : chunk) i v =
-    let (d,rhs) = disp chunk i in
+  let pm chunk i v =
+    let (d,rhs) = PM.get mk_pm chunk.pm i in
     let (code,bindings) = Run_dispatch.run_dispatcher d v in
     match rhs.(code) with
       | Patterns.Compile.Fail -> assert false
@@ -49,5 +83,10 @@ module G = struct
 	  Array.map
 	    (fun (_,i) -> if (i == -1) then v else bindings.(i))
 	    (Array.of_list bind)
+
+
+  let const chunk i =
+    CONST.get Value.const chunk.cst i
 	  
 end
+

runtime/serial.mli

@@ -3,13 +3,15 @@ module P : sig
   val mk: unit -> string
 
   val pm: Types.t * Patterns.Node.t list -> int
+  val const: Types.const -> int
 end
 
 module G : sig
   type chunk
   val mk: string -> chunk
 
-  val run: chunk -> int -> Value.t -> int * Value.t array
+  val pm: chunk -> int -> Value.t -> int * Value.t array
+  val const: chunk -> int -> Value.t
 end
 
 

types/types.ml

 open Ident
 open Encodings
 
+let caml_mode = ref false
+
+let count = State.ref "Types.count" 0
+		
+let () =
+  Stats.register Stats.Summary
+    (fun ppf -> Format.fprintf ppf "Allocated type nodes:%i@\n" !count)
+
 (* TODO:
    - I store hash in types to avoid computing it several times.
      Does not seem to help a lot.
@@ -26,6 +34,8 @@ module CompUnit = struct
     assert (!current != dummy_min);
     !current
 
+  let print ppf t = Format.fprintf ppf "%a" U.print (value t)
+
   let print_qual ppf t =
     if (t != !current) && (t != pervasives) then
       Format.fprintf ppf "%a." U.print (value t)
@@ -48,6 +58,8 @@ module CompUnit = struct
   let stack = ref []
 		
   let enter i = 
+(*    Format.fprintf Format.std_formatter "Types.CompUnit.enter: %a@." 
+      U.print (value i); *)
     stack := !current :: !stack; current := i
 		  
   let leave () =
@@ -357,6 +369,7 @@ sig
   val serialize: t Serialize.Put.f
   val deserialize: t Serialize.Get.f
   val mk: int -> Descr.t -> t
+  val clear_deserialize_table: unit -> unit
 end =
 
 struct
@@ -365,6 +378,7 @@ struct
   let dump ppf n = failwith "Types.Node.dump"
   let hash x = x.id + 17 * x.comp_unit
   let compare x y = 
+    assert(x.id != y.id || x.comp_unit != y.comp_unit || x == y);
     let c = x.id - y.id in
     if c = 0 then x.comp_unit - y.comp_unit else c
   let equal x y = x == y
@@ -375,6 +389,7 @@ struct
   let () =
     CompUnit.close_serialize_ref := 
     (fun () ->
+(*       Format.fprintf Format.std_formatter "Close_serialize@."; *)
        Inttbl.clear serialize_memo;
        counter_serialize := 0)
 
@@ -383,10 +398,15 @@ struct
       Serialize.Put.bool t true;
       try 
 	let i = Inttbl.find serialize_memo n.id in
+(*	Format.fprintf Format.std_formatter 
+	  "serialize node (memo) id=%i i=%i@."
+	  n.id i;  *)
 	Serialize.Put.int t i
       with Not_found ->
 	let i = !counter_serialize in
 	incr counter_serialize;
+(*	Format.fprintf Format.std_formatter "serialize node id=%i i=%i@."
+	  n.id i;  *)
 	Inttbl.add serialize_memo n.id i;
 	Serialize.Put.int t i;
 	Descr.serialize t n.descr
@@ -406,7 +426,12 @@ struct
       Inttbl.add deserialize_memo id tbl;
       tbl
 
+  let clear_deserialize_table () =
+    Inttbl.remove deserialize_memo !CompUnit.current
+
   let mk id d =
+(*    Format.fprintf Format.std_formatter "mk cu=%a i=%i@." 
+      CompUnit.print !CompUnit.current id; *)
     let n = { id = id; comp_unit = !CompUnit.current; descr = d } in
     if !CompUnit.current == CompUnit.pervasives then
       Inttbl.add (find_tbl CompUnit.pervasives) n.id n;
@@ -415,17 +440,21 @@ struct
   let deserialize t = 
     if Serialize.Get.bool t then
       let i = Serialize.Get.int t in
+(*      Format.fprintf Format.std_formatter "deserialize i=%i@." i; *)
       let tbl = find_tbl !CompUnit.current in
       try Inttbl.find tbl i
       with Not_found ->
-	let n = { id = i; comp_unit = !CompUnit.current;
-		  descr = Descr.empty } in
+	let id = if !caml_mode then (incr count;!count) else i in
+(*	Format.fprintf Format.std_formatter "... not found ==> %i@." id; *)
+	let n = mk id Descr.empty in
 	Inttbl.add tbl i n;
 	n.descr <- Descr.deserialize t;
 	n
     else
       let cu = CompUnit.deserialize t in
       let i = Serialize.Get.int t in
+(*      Format.fprintf Format.std_formatter "deserialize cu=%a i=%i@." 
+	CompUnit.print cu i; *)
       try Inttbl.find (Inttbl.find deserialize_memo cu) i 
       with Not_found -> assert false
 
@@ -462,15 +491,13 @@ type descr = Descr.t
 type node = Node.t
 include Descr
 
+let clear_deserialize_table = Node.clear_deserialize_table
+
+
 let forward_print = ref (fun _ _ -> assert false)
 
 let hash_cons = DescrHash.create 17000  
 
-let count = State.ref "Types.count" 0
-		
-let () =
-  Stats.register Stats.Summary
-    (fun ppf -> Format.fprintf ppf "Allocated type nodes:%i@\n" !count)
       
 let make () = 
   incr count; 

types/types.mli

@@ -12,7 +12,6 @@ type const =
 
 module Const: Custom.T with type t = const
 
-
 module CompUnit : sig
   include Custom.T
 
@@ -61,6 +60,9 @@ val internalize: Node.t -> Node.t
 val id: Node.t -> int
 val descr: Node.t -> t
 
+val caml_mode : bool ref
+val clear_deserialize_table: unit -> unit
+
 (** Boolean connectives **)
 
 val cup    : t -> t -> t