Commit 0df4d8f1 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-10-30 02:05:41 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-30 02:05:42+00:00
parent 31d5678e
(* $Id: recursive.ml,v 1.3 2002/10/17 15:38:34 cvscast Exp $ *)
(* $Id: recursive.ml,v 1.4 2002/10/30 02:05:41 cvscast Exp $ *)
exception NotEqual
exception Incomplete
......@@ -136,11 +136,12 @@ struct
let m = Prehash.find known nr in
nr := m;
nr
with Not_found ->
with Not_found ->
n.state <- Intern;
Prehash.add known nr n
;
;
n.descr <- X.map internalize n.descr;
nr
(* Cannot change descr ! If copied to another node, this would break (=) !!! *)
)
......
(* A fast replacement of Recursive without sharing at all *)
exception NotEqual
exception Incomplete
module type S =
sig
type 'a t
val map: ('a -> 'b) -> ('a t -> 'b t)
val equal: ('a -> 'a -> unit) -> ('a t -> 'a t -> unit)
val iter: ('a -> unit) -> ('a t -> unit)
val hash: ('a -> int) -> ('a t -> int)
val deep: int
end
module Make(X : S) =
struct
type state = Undefined | Defined
type node = {
id : int;
mutable descr : descr;
}
and descr = node X.t
let id n = n.id
let counter = ref 0
let make () =
incr counter;
{
id = !counter;
descr = Obj.magic 0;
}
let equal x y = x.id = y.id
let internalize n = n
let internalize_descr d = d
let descr n = n.descr
let define n d = n.descr <- d
let hash_descr d = X.hash (fun n -> n.id) d
let equal_descr d1 d2 =
(d1 == d2) ||
try
X.equal
(fun n1 n2 -> if n1.id <> n2.id then raise NotEqual)
d1 d2;
true
with NotEqual -> false
end
(* $Id: recursive_share.ml,v 1.1 2002/10/30 02:05:42 cvscast Exp $ *)
exception NotEqual
exception Incomplete
module type S =
sig
type 'a t
val map: ('a -> 'b) -> ('a t -> 'b t)
val equal: ('a -> 'a -> unit) -> ('a t -> 'a t -> unit)
val iter: ('a -> unit) -> ('a t -> unit)
val hash: ('a -> int) -> ('a t -> int)
val deep: int
end
module Make(X : S) =
struct
type state = Undefined | Defined | Hashed | Intern
(* Two values of this type have either different id or the
same fields (but they are not necessarily == if they have the same id).
This ensures that Pervasives.compare always terminates in O(1). *)
type node_content = {
mutable id : int;
mutable descr : node X.t;
mutable hash : int;
mutable state : state;
mutable hashs : int array;
} and node = node_content ref
type descr = node X.t
(* To avoid the creation of closures when computing hash values.
Need some profiling to see how much we gain, and if
a complete inlining for small values of deep is better *)
let deep_hash_tab = Array.create (X.deep + 1)
(fun {contents=n} ->
if n.state = Undefined then raise Incomplete;
13
)
let _ =
for i = 1 to X.deep do
deep_hash_tab.(i) <-
(fun {contents=n} ->
if n.hashs.(i) <> max_int then n.hashs.(i) else
(if n.state = Undefined then raise Incomplete;
let r = X.hash deep_hash_tab.(i-1) n.descr in
let r = if r = max_int then max_int - 1 else r in
n.hashs.(i) <- r;
r)
)
done
let deep_hash = deep_hash_tab.(X.deep)
(*
let rec deep_hash_rec k n =
if n.state = Undefined then raise Incomplete;
if k = 0 then 1 else X.hash (deep_hash_rec (k-1)) n.descr
let deep_hash = deep_hash_rec X.deep *)
let hash ({contents=n} as nr) =
match n.state with
| Defined ->
n.hash <- (deep_hash nr) land max_int;
(* Up to OCaml 3.04, Hashtbl.Make requires hash to return
non-negative integers ... *)
n.state <- Hashed;
n.hash
| Undefined -> raise Incomplete
| Hashed | Intern -> n.hash
let id n = !n.id
let counter = ref 0
let make () =
incr counter;
ref {
id = !counter;
descr = Obj.magic 0;
state = Undefined;
hash = 0;
hashs = Array.make (X.deep+1) max_int;
}
let c = Hashtbl.create 64
let rec equal_rec a b =
if (a != b) then
if (hash a <> hash b) then raise NotEqual else
let a = !a and b = !b in
if (a != b) then
match (a.state,b.state) with
| (Intern,Intern) -> raise NotEqual
| _ ->
let m = if a.id < b.id then (a.id,b.id) else (b.id,a.id) in
if not (Hashtbl.mem c m) then
(Hashtbl.add c m (); X.equal equal_rec a.descr b.descr)
let equal ({contents=a} as ar) ({contents=b} as br) =
match (a.state,b.state) with
| (Intern,Intern) -> a.id = b.id
| _ ->
let r = try equal_rec ar br; true with NotEqual -> false in
Hashtbl.clear c;
r
(* Possible optimization: if r = true, one knows
that all pairs in c are equal. Could merge them here ? *)
module Prehash = Hashtbl.Make
(struct
type t = node
let hash = hash
let equal = equal
end)
let known = Prehash.create 1023
let rec internalize (({contents=n} as nr) : node) =
match n.state with
| Intern -> nr
| Undefined -> raise Incomplete
| Hashed
| Defined ->
(
try
let m = Prehash.find known nr in
nr := m;
nr
with Not_found ->
n.state <- Intern;
Prehash.add known nr n
;
n.descr <- X.map internalize n.descr;
nr
(* Cannot change descr ! If copied to another node, this would break (=) !!! *)
)
let internalize_descr = X.map internalize
let descr {contents=n} =
if n.state = Undefined then raise Incomplete else n.descr
let define ({contents=n} as nr) d =
if n.state != Undefined then failwith "Already defined";
n.state <- Defined;
n.descr <- d;
(* Special support for bottom-up hash-consing non-recursive objects *)
try
X.iter (fun m -> if !m.state <> Intern then raise Exit) d;
ignore (internalize nr)
with Exit -> ()
let hash_descr d = X.hash (fun n -> !n.id) d
let equal_descr d1 d2 =
(d1 == d2) ||
try
X.equal
(fun n1 n2 -> if !n1.id <> !n2.id then raise NotEqual)
d1 d2;
true
with NotEqual -> false
end
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