Commit 25342609 authored by Pietro Abate's avatar Pietro Abate

[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
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
......
......@@ -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
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
......@@ -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
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;
......
......@@ -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
......
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