viewcvs.cgi/types/recursive_share.ml

(* $Id: recursive_share.ml,v 1.3 2002/11/10 02:21:46 cvscast Exp $ *)
open Recursive

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 = State.ref "Recursive_share" 0

                  (* TODO: need to save the Hashtbl ... *)

  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
1	(* $Id: recursive_share.ml,v 1.3 2002/11/10 02:21:46 cvscast Exp $ *)
2	open Recursive
3
4	module Make(X : S) =
5	struct
6	type state = Undefined \| Defined \| Hashed \| Intern
7
8	(* Two values of this type have either different id or the
9	same fields (but they are not necessarily == if they have the same id).
10	This ensures that Pervasives.compare always terminates in O(1). *)
11
12	type node_content = {
13	mutable id : int;
14	mutable descr : node X.t;
15	mutable hash : int;
16	mutable state : state;
17	mutable hashs : int array;
18	} and node = node_content ref
19
20	type descr = node X.t
21
22	(* To avoid the creation of closures when computing hash values.
23	Need some profiling to see how much we gain, and if
24	a complete inlining for small values of deep is better *)
25
26	let deep_hash_tab = Array.create (X.deep + 1)
27	(fun {contents=n} ->
28	if n.state = Undefined then raise Incomplete;
29	13
30	)
31
32	let _ =
33	for i = 1 to X.deep do
34	deep_hash_tab.(i) <-
35	(fun {contents=n} ->
36	if n.hashs.(i) <> max_int then n.hashs.(i) else
37	(if n.state = Undefined then raise Incomplete;
38	let r = X.hash deep_hash_tab.(i-1) n.descr in
39	let r = if r = max_int then max_int - 1 else r in
40	n.hashs.(i) <- r;
41	r)
42	)
43	done
44
45	let deep_hash = deep_hash_tab.(X.deep)
46
47	(*
48	let rec deep_hash_rec k n =
49	if n.state = Undefined then raise Incomplete;
50	if k = 0 then 1 else X.hash (deep_hash_rec (k-1)) n.descr
51
52	let deep_hash = deep_hash_rec X.deep *)
53
54	let hash ({contents=n} as nr) =
55	match n.state with
56	\| Defined ->
57	n.hash <- (deep_hash nr) land max_int;
58	(* Up to OCaml 3.04, Hashtbl.Make requires hash to return
59	non-negative integers ... *)
60	n.state <- Hashed;
61	n.hash
62	\| Undefined -> raise Incomplete
63	\| Hashed \| Intern -> n.hash
64
65	let id n = !n.id
66
67	let counter = State.ref "Recursive_share" 0
68
69	(* TODO: need to save the Hashtbl ... *)
70
71	let make () =
72	incr counter;
73	ref {
74	id = !counter;
75	descr = Obj.magic 0;
76	state = Undefined;
77	hash = 0;
78	hashs = Array.make (X.deep+1) max_int;
79	}
80
81	let c = Hashtbl.create 64
82
83	let rec equal_rec a b =
84	if (a != b) then
85	if (hash a <> hash b) then raise NotEqual else
86	let a = !a and b = !b in
87	if (a != b) then
88	match (a.state,b.state) with
89	\| (Intern,Intern) -> raise NotEqual
90	\| _ ->
91	let m = if a.id < b.id then (a.id,b.id) else (b.id,a.id) in
92	if not (Hashtbl.mem c m) then
93	(Hashtbl.add c m (); X.equal equal_rec a.descr b.descr)
94
95	let equal ({contents=a} as ar) ({contents=b} as br) =
96	match (a.state,b.state) with
97	\| (Intern,Intern) -> a.id = b.id
98	\| _ ->
99	let r = try equal_rec ar br; true with NotEqual -> false in
100	Hashtbl.clear c;
101	r
102	(* Possible optimization: if r = true, one knows
103	that all pairs in c are equal. Could merge them here ? *)
104
105
106	module Prehash = Hashtbl.Make
107	(struct
108	type t = node
109	let hash = hash
110	let equal = equal
111	end)
112
113	let known = Prehash.create 1023
114
115	let rec internalize (({contents=n} as nr) : node) =
116	match n.state with
117	\| Intern -> nr
118	\| Undefined -> raise Incomplete
119	\| Hashed
120	\| Defined ->
121	(
122	try
123	let m = Prehash.find known nr in
124	nr := m;
125	nr
126	with Not_found ->
127	n.state <- Intern;
128	Prehash.add known nr n
129	;
130	n.descr <- X.map internalize n.descr;
131
132	nr
133	(* Cannot change descr ! If copied to another node, this would break (=) !!! *)
134	)
135
136	let internalize_descr = X.map internalize
137
138	let descr {contents=n} =
139	if n.state = Undefined then raise Incomplete else n.descr
140
141	let define ({contents=n} as nr) d =
142	if n.state != Undefined then failwith "Already defined";
143	n.state <- Defined;
144	n.descr <- d;
145	(* Special support for bottom-up hash-consing non-recursive objects *)
146	try
147	X.iter (fun m -> if !m.state <> Intern then raise Exit) d;
148	ignore (internalize nr)
149	with Exit -> ()
150
151
152	let hash_descr d = X.hash (fun n -> !n.id) d
153	let equal_descr d1 d2 =
154	(d1 == d2) \|\|
155	try
156	X.equal
157	(fun n1 n2 -> if !n1.id <> !n2.id then raise NotEqual)
158	d1 d2;
159	true
160	with NotEqual -> false
161	end