Commit 25342609 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: afrisch
Date: 2005-03-23 14:04:00+00:00
parent 971dc658
...@@ -8,6 +8,7 @@ module type S = sig ...@@ -8,6 +8,7 @@ module type S = sig
val add: 'a t -> key -> 'a -> unit val add: 'a t -> key -> 'a -> unit
val find: 'a t -> key -> 'a val find: 'a t -> key -> 'a
val mem: 'a t -> key -> bool val mem: 'a t -> key -> bool
val remove: 'a t -> key -> unit
end end
type key = int type key = int
...@@ -29,7 +30,6 @@ let fold t f x = ...@@ -29,7 +30,6 @@ let fold t f x =
aux (pred i) x aux (pred i) x
in in
aux (pred (Array.length !t)) x aux (pred (Array.length !t)) x
let add t i x = let add t i x =
let l = Array.length !t in let l = Array.length !t in
...@@ -41,6 +41,9 @@ let add t i x = ...@@ -41,6 +41,9 @@ let add t i x =
); );
(!t).(i) <- Some x (!t).(i) <- Some x
let remove t i =
if (i <= Array.length !t) then (!t).(i) <- None
let find t i = let find t i =
if i >= Array.length !t then raise Not_found if i >= Array.length !t then raise Not_found
else match (!t).(i) with else match (!t).(i) with
......
...@@ -8,6 +8,7 @@ module type S = sig ...@@ -8,6 +8,7 @@ module type S = sig
val add: 'a t -> key -> 'a -> unit val add: 'a t -> key -> 'a -> unit
val find: 'a t -> key -> 'a val find: 'a t -> key -> 'a
val mem: 'a t -> key -> bool val mem: 'a t -> key -> bool
val remove: 'a t -> key -> unit
end end
include S with type key = int include S with type key = int
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 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 pm = PM.put
let mk () = let const = CONST.put
let pms = Array.of_list (List.rev !pms) in
Serialize.Put.run T.serialize pms 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 end
module G = struct module G = struct
type chunk = type chunk =
T.t * { pm :
(Patterns.Compile.dispatcher * int Patterns.Compile.rhs array) (Patterns.Compile.dispatcher * int Patterns.Compile.rhs array)
option 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 = let mk s =
try Types.clear_deserialize_table ();
let a = Serialize.Get.run T.deserialize s in Serialize.Get.run deserialize s
(a, Array.create (Array.length a) None)
with _ -> assert false let mk_pm (t,brs) =
let brs = Array.to_list (Array.mapi (fun i x -> (x,i)) (Array.of_list brs))
let disp (spec,d) i = in
match d.(i) with Patterns.Compile.make_branches t brs
| 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
let run (chunk : chunk) i v = let pm chunk i v =
let (d,rhs) = disp chunk i in let (d,rhs) = PM.get mk_pm chunk.pm i in
let (code,bindings) = Run_dispatch.run_dispatcher d v in let (code,bindings) = Run_dispatch.run_dispatcher d v in
match rhs.(code) with match rhs.(code) with
| Patterns.Compile.Fail -> assert false | Patterns.Compile.Fail -> assert false
...@@ -49,5 +83,10 @@ module G = struct ...@@ -49,5 +83,10 @@ module G = struct
Array.map Array.map
(fun (_,i) -> if (i == -1) then v else bindings.(i)) (fun (_,i) -> if (i == -1) then v else bindings.(i))
(Array.of_list bind) (Array.of_list bind)
let const chunk i =
CONST.get Value.const chunk.cst i
end end
...@@ -3,13 +3,15 @@ module P : sig ...@@ -3,13 +3,15 @@ module P : sig
val mk: unit -> string val mk: unit -> string
val pm: Types.t * Patterns.Node.t list -> int val pm: Types.t * Patterns.Node.t list -> int
val const: Types.const -> int
end end
module G : sig module G : sig
type chunk type chunk
val mk: string -> 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 end
open Ident open Ident
open Encodings 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: (* TODO:
- I store hash in types to avoid computing it several times. - I store hash in types to avoid computing it several times.
Does not seem to help a lot. Does not seem to help a lot.
...@@ -26,6 +34,8 @@ module CompUnit = struct ...@@ -26,6 +34,8 @@ module CompUnit = struct
assert (!current != dummy_min); assert (!current != dummy_min);
!current !current
let print ppf t = Format.fprintf ppf "%a" U.print (value t)
let print_qual ppf t = let print_qual ppf t =
if (t != !current) && (t != pervasives) then if (t != !current) && (t != pervasives) then
Format.fprintf ppf "%a." U.print (value t) Format.fprintf ppf "%a." U.print (value t)
...@@ -48,6 +58,8 @@ module CompUnit = struct ...@@ -48,6 +58,8 @@ module CompUnit = struct
let stack = ref [] let stack = ref []
let enter i = let enter i =
(* Format.fprintf Format.std_formatter "Types.CompUnit.enter: %a@."
U.print (value i); *)
stack := !current :: !stack; current := i stack := !current :: !stack; current := i
let leave () = let leave () =
...@@ -357,6 +369,7 @@ sig ...@@ -357,6 +369,7 @@ sig
val serialize: t Serialize.Put.f val serialize: t Serialize.Put.f
val deserialize: t Serialize.Get.f val deserialize: t Serialize.Get.f
val mk: int -> Descr.t -> t val mk: int -> Descr.t -> t
val clear_deserialize_table: unit -> unit
end = end =
struct struct
...@@ -365,6 +378,7 @@ struct ...@@ -365,6 +378,7 @@ struct
let dump ppf n = failwith "Types.Node.dump" let dump ppf n = failwith "Types.Node.dump"
let hash x = x.id + 17 * x.comp_unit let hash x = x.id + 17 * x.comp_unit
let compare x y = let compare x y =
assert(x.id != y.id || x.comp_unit != y.comp_unit || x == y);
let c = x.id - y.id in let c = x.id - y.id in
if c = 0 then x.comp_unit - y.comp_unit else c if c = 0 then x.comp_unit - y.comp_unit else c
let equal x y = x == y let equal x y = x == y
...@@ -375,6 +389,7 @@ struct ...@@ -375,6 +389,7 @@ struct
let () = let () =
CompUnit.close_serialize_ref := CompUnit.close_serialize_ref :=
(fun () -> (fun () ->
(* Format.fprintf Format.std_formatter "Close_serialize@."; *)
Inttbl.clear serialize_memo; Inttbl.clear serialize_memo;
counter_serialize := 0) counter_serialize := 0)
...@@ -383,10 +398,15 @@ struct ...@@ -383,10 +398,15 @@ struct
Serialize.Put.bool t true; Serialize.Put.bool t true;
try try
let i = Inttbl.find serialize_memo n.id in 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 Serialize.Put.int t i
with Not_found -> with Not_found ->
let i = !counter_serialize in let i = !counter_serialize in
incr counter_serialize; incr counter_serialize;
(* Format.fprintf Format.std_formatter "serialize node id=%i i=%i@."
n.id i; *)
Inttbl.add serialize_memo n.id i; Inttbl.add serialize_memo n.id i;
Serialize.Put.int t i; Serialize.Put.int t i;
Descr.serialize t n.descr Descr.serialize t n.descr
...@@ -406,7 +426,12 @@ struct ...@@ -406,7 +426,12 @@ struct
Inttbl.add deserialize_memo id tbl; Inttbl.add deserialize_memo id tbl;
tbl tbl
let clear_deserialize_table () =
Inttbl.remove deserialize_memo !CompUnit.current
let mk id d = 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 let n = { id = id; comp_unit = !CompUnit.current; descr = d } in
if !CompUnit.current == CompUnit.pervasives then if !CompUnit.current == CompUnit.pervasives then
Inttbl.add (find_tbl CompUnit.pervasives) n.id n; Inttbl.add (find_tbl CompUnit.pervasives) n.id n;
...@@ -415,17 +440,21 @@ struct ...@@ -415,17 +440,21 @@ struct
let deserialize t = let deserialize t =
if Serialize.Get.bool t then if Serialize.Get.bool t then
let i = Serialize.Get.int t in let i = Serialize.Get.int t in
(* Format.fprintf Format.std_formatter "deserialize i=%i@." i; *)
let tbl = find_tbl !CompUnit.current in let tbl = find_tbl !CompUnit.current in
try Inttbl.find tbl i try Inttbl.find tbl i
with Not_found -> with Not_found ->
let n = { id = i; comp_unit = !CompUnit.current; let id = if !caml_mode then (incr count;!count) else i in
descr = Descr.empty } in (* Format.fprintf Format.std_formatter "... not found ==> %i@." id; *)
let n = mk id Descr.empty in
Inttbl.add tbl i n; Inttbl.add tbl i n;
n.descr <- Descr.deserialize t; n.descr <- Descr.deserialize t;
n n
else else
let cu = CompUnit.deserialize t in let cu = CompUnit.deserialize t in
let i = Serialize.Get.int 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 try Inttbl.find (Inttbl.find deserialize_memo cu) i
with Not_found -> assert false with Not_found -> assert false
...@@ -462,15 +491,13 @@ type descr = Descr.t ...@@ -462,15 +491,13 @@ type descr = Descr.t
type node = Node.t type node = Node.t
include Descr include Descr
let clear_deserialize_table = Node.clear_deserialize_table
let forward_print = ref (fun _ _ -> assert false) let forward_print = ref (fun _ _ -> assert false)
let hash_cons = DescrHash.create 17000 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 () = let make () =
incr count; incr count;
......
...@@ -12,7 +12,6 @@ type const = ...@@ -12,7 +12,6 @@ type const =
module Const: Custom.T with type t = const module Const: Custom.T with type t = const
module CompUnit : sig module CompUnit : sig
include Custom.T include Custom.T
...@@ -61,6 +60,9 @@ val internalize: Node.t -> Node.t ...@@ -61,6 +60,9 @@ val internalize: Node.t -> Node.t
val id: Node.t -> int val id: Node.t -> int
val descr: Node.t -> t val descr: Node.t -> t
val caml_mode : bool ref
val clear_deserialize_table: unit -> unit
(** Boolean connectives **) (** Boolean connectives **)
val cup : t -> t -> t val cup : t -> t -> t
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment