viewcvs.cgi/types/recursive.ml

(* $Id: recursive.ml,v 1.1 2002/10/10 09:11:23 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 -> ()

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