recursive.ml 4.1 KB
Newer Older
1
(* $Id: recursive.ml,v 1.1 2002/10/10 09:11:23 cvscast Exp $ *)
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163

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